diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,83 @@ # Changelog +## 0.10.0.0 - 2026-11-04 + +On Windows, CI builds the start of a toolchain from source as derivations on x64 and ARM64: stage0-pe32's chain from a 1,623-byte seed up to kaem, mescc-tools-extra's programs, and GNU Mes 0.27.1. A build tries a derivation's outputs before its inputs, as upstream does, so a package a cache holds no longer pulls in what it was built from, and a cache that fails stops the build unless `--fallback` is given. + +### Library API + +Breaking changes for code that uses nova-nix as a library: + +- **`Nix.Eval.Types.MonadEval` has a new method with no default, `qualifyPath`, and `Nix.Store.Path.storeTextToFilePath` puts a rooted path with no drive on the store's drive.** Every instance defined outside this package needs the method; one with no filesystem answers `pure`, as `PureEval` does. The new `Nix.Store.Path.qualifyPathText` gives a rooted path with no drive, other than one under `/nix/store`, the store directory's drive, and leaves every other path, and every path when the store directory has no drive, as it is. `Nix.Eval.Policy.uriAccess` takes the `StoreDir` first, `Nix.Eval.Policy` exports `fileUrlPrefix`, and `Nix.Eval` exports `localFileUrl` and `gitRemote`. (#363) +- **`Nix.Parser.parseNix` and `parseNixWithScope` take a `SourceOrigin` and the source's bytes, where they took its name and its decoded `Text`:** `parseNix :: FilePath -> SourceOrigin -> ByteString -> Either SourceError Expr`. They read a UTF-8 or UTF-16 byte order mark themselves, so a caller passes what `Data.ByteString.readFile` returns, and `Nix.Parser.readFileAutoEncoding` is removed. `SourceOrigin` (`SourceFile` or `SourceText`) and `sourceName` are new in `Nix.Expr.Types`, and `Nix.Parser` re-exports the type. `Nix.Parser.Lexer.tokenize` takes a `ByteString`, and the new `positionAfter` gives the line and column `tokenize` reaches at the end of a source. `Nix.Parser.Internal.ParseState` holds `psOrigin` where it held `psFile`, `currentPos` is new, and `pMany` is removed. (#361, #368, #372) +- **The AST records where each binding was written, and its string pieces are bytes.** `Nix.Expr.Types.NamedBinding` and `Inherit` carry the new `SrcPos` they were parsed at, and `InheritFrom` holds `InheritedName`s, each with its own. `StrLit` and `StrEsc`, and the lexer's `TokStringLit` and `TokStringEsc`, hold a `ByteString` where they held `Text`, and `EPathStr` holds its head piece as `Text` ahead of its other parts. (#361, #368) +- **Attribute positions reach the bytecode and the C attribute set.** `Nix.Eval.Compile`'s `BcNamed`, `BcInherit` and `BcInheritedName` carry a `PosIdx`, `Nix.Eval.CAttrSet.cattrsetInsert` takes the entry's `PosIdx`, and `cattrsetGetPos` reads it back. The new module `Nix.Eval.SourcePos` records positions (`PosIdx`, `noPos`, `PosRecorder`, `newPosRecorder`, `recordPos`) and reads them back (`RecordedPos`, `lookupPos`), and `Nix.Eval.Types` exports `AttrEntry`, `attrSetLookupEntry` and `attrSetFromEntries`. (#361) +- **`Nix.Eval.Types.NixValue`'s `VBuiltin` holds `[BuiltinArg]` where it held `[NixValue]`, and `Nix.Eval.BuiltinDef` gives a builtin's argument modes where it gave its arity.** `BuiltinArg` is `ArgForced` or `ArgDeferred`. `bdArgs :: NonEmpty ArgMode` (`ForceOnApply` or `ForceOnUse`) replaces `bdArity`, and `bdApply` takes `[BuiltinArg]`. `Nix.Eval` exports both types, and `Nix.Eval.Types` exports `BuiltinArg`. (#351) +- **`Nix.Hash`'s `makeStorePath`, `makeTextPath`, `makeFixedOutputPath` and `makeOutputPath` return `Either BadStorePath StorePath`, where they returned `Either StorePathNameError StorePath`.** The new `Nix.Store.Path.BadStorePath` holds the hash part the path would have had (`bspHashPart`) and why its name is refused (`bspNameError`), and `badStorePathText` renders upstream's message. `Nix.Eval.Types.storePathOrThrow` takes no context argument. (#345) +- **`Nix.Builder.buildDerivation` takes the derivation's `.drv` path after the derivation, and `BuildConfig` has two new strict fields, `bcFallback :: Fallback` and `bcBuildLog :: Handle`.** `defaultBuildConfig` sets them to `NoFallback` and stderr; code that builds a `BuildConfig` with the constructor needs both. A builder that exits unsuccessfully gives `BuildFailure "builder failed" code`, its output written to `bcBuildLog` rather than into the message. (#346, #349, #353) +- **`Nix.Config.NixConfig` has two new strict fields, `ncFallback` and `ncTraceVerbose`, and `Nix.Eval.Policy.EvalPolicy` one, `epTraceVerbose`.** `defaultNixConfig` and `unrestrictedPolicy` leave them off, as upstream's defaults are; code that builds either record with the constructor needs them. (#346, #348) +- **The new module `Nix.Realise` decides, root first, what a build substitutes and what it builds.** `substituteClosure` runs over the effects in `SubstEffects`, whose `seReferences` answers an `Offer` and `seFetch` a `FetchOutcome`, and returns a `ClosureOutcome`. `realise` takes a `Fallback` and the effects in `RealiseEffects`, whose `reBuild` takes the `.drv` path after the derivation, and returns `Either RealiseFailure ()`, which `realiseFailureMessage` renders. `Nix.Builder` exports `substitutePaths`, which returns a `FetchOutcome`, and `Nix.Substituter` exports `queryReferencesWith`, which takes a `Fallback` and returns an `Offer`. `Nix.Substituter.narInfoPreflight` is removed, and `NarInfoAnswer` and `judgeNarInfo` are added. `Fallback` (`NoFallback` or `BuildFromSource`), which `BuildConfig`'s `bcFallback` holds, and `Realised` (`AlreadyValid`, `Substituted` or `Built`), which `reReport` receives, are also new in `Nix.Realise`. (#331, #346) +- **`Nix.Store.scanTempReferences` is removed, and `rewriteStoreHashes` and `rewriteBytes` are added.** `scanReferences` also scans entry names. (#328) +- **The new module `Nix.Builder.Log` holds the build log's line discipline (`PendingLine`, `emptyPendingLine`, `feedBuildLog`, `endBuildLog`), its terminal filter (`EscapeFilter`, `filterLogLine`) and the streaming around them (`openLogPipe`, `streamBuildLog`).** (#349) +- **`Nix.Builder` exports `AttrsDelivery` and `attrsDelivery`, how a derivation's attributes reach its builder; `closureUnder`, the closure of a list of roots under a references lookup in any monad; and `orderByReferences` with `ReferenceCycle`, the ordering of outputs by the siblings they reference.** (#333, #343, #353) + +### CLI + +- **An I/O failure no command handles prints `error:` and its message and exits 1, as upstream's commands do, where it printed GHC's `Uncaught exception` report with a backtrace.** The store's refusal of an unregistered reference, for one, printed `nova-nix: Uncaught exception ghc-internal:GHC.Internal.IO.Exception.IOException:`, its message inside `user error (...)`, and a `HasCallStack backtrace`. Upstream's `handleExceptions` (libmain/shared.cc at 2.24.9) logs an error after `error:` and exits with its status, 1 unless the error sets another, and the CLI now does the same for an `IOException`, which sets none: a `userError` prints its message, and any other also names the operation and the file that failed. A failed build still prints behind nova-nix's own prefixes (#397). (#395) + +### Evaluation + +- **`builtins.nixVersion` is `"2.24.9"`, where it was `"2.24.0"`.** Upstream reports the version of the Nix evaluating the expression (`nixVersion` in `globals.cc` at 2.24.9), and 2.24.9 is the release whose source nova-nix's parity work cites, so an expression that branches on the value takes the branch it takes there. `nova-nix --version` still names nova-nix's own release. (#344) +- **Ten builtins force an argument at the point upstream's primop forces it, so `map (throw "a") [ ]` is `[ ]`, and when two arguments throw, the error is the one upstream reports.** A builtin's arguments were forced as they were applied, left to right, so `map`, `filter`, `sort`, `mapAttrs` and `elem` failed on an empty collection whose function or needle throws, where upstream succeeds, and with both arguments throwing the first one's error was reported where upstream reports the second's. Upstream's `prim_map`, `prim_filter` and `prim_sort` force the list and return an empty one before they force the function; `prim_mapAttrs` never forces the function itself, so `mapAttrs (throw "a") { x = 1; }` has the attribute `x`; `prim_elem` forces the needle only to compare it with an element; `prim_elemAt` and `prim_genList` force their second argument first; `prim_foldlStrict` hands its initial accumulator to the first step unforced and forces it itself only for an empty list; and `prim_filterSource` and `scopedImport` coerce the path before they force the filter or the scope (primops.cc at 2.24.9). Each of these builtins now takes that argument unforced and forces it at the same point, in a partial application too, so `builtins.typeOf (map (throw "a"))` is `"lambda"`. A function argument forced there is checked as upstream's `forceFunction` checks it, so `builtins.length (map 1 [ 1 ])` fails with `expected a function but found an integer: 1`, where it returned 1. Their other arguments are still forced as they are applied, where upstream forces nothing before a primop has all its arguments, so a partial application such as `builtins.foldl' (throw "a")` still fails when forced. (#351) +- **`builtins.traceVerbose` returns its second argument without forcing or printing its first, unless `trace-verbose` is on, set by `--trace-verbose` on `eval` and `build`, or by `trace-verbose` in nix.conf or `NIX_CONFIG`.** It was `builtins.trace` under another name, so every call forced its first argument and printed it to stderr, and `builtins.traceVerbose (throw "a") 1` failed where upstream gives `1`. Upstream binds the name to `prim_second` by default and to `prim_trace` under the setting (`primops.cc` at 2.24.9), and both are matched: without the setting `traceVerbose` never forces its first argument, applied directly, through a partial application or by a higher-order builtin, and with it `traceVerbose` forces and prints its first argument as `builtins.trace` does before it forces its second. Like `--restrict-eval` and `--pure-eval`, the flag only turns the setting on; upstream also derives a `--no-trace-verbose` from the setting, which nova-nix does not have. (#348) +- **A store path refused for its name is refused in upstream's words, naming the path it would have had.** `builtins.toFile "a b" "x"` fails with `path 'dm85kbl5cy82j2dzvy1874s14y3salv3-a b' is not a valid store path: name 'a b' contains illegal character ' '`, as on Nix 2.24.9. It failed with a message of nova-nix's own behind a `builtins.toFile:` prefix. Upstream refuses the name where it builds the path, once the hash exists (the `StorePath` constructor in `path.cc` at 2.24.9), and names the builtin only in its trace. nova-nix's path constructors now refuse it the same way, so the same text comes from `builtins.path`, `builtins.filterSource`, a path copied to the store by interpolation, and a derivation whose name fits but whose `.drv` name or `-` name does not. A source copy hashes its tree before refusing its name, as upstream's does, since the hash part is the tree's. A `builtins.path` with `sha256` is refused under the pinned hash before the tree is read, as upstream's `addPath` builds the pinned path first. Of two outputs past the length cap, the one refused is the first by name, as upstream builds the paths over its sorted output set. (#345) +- **On Windows a path with a root but no drive, such as `/probe/f.txt`, names that path on the store's drive, whatever drive is current.** It resolved against the current drive, so with `C:\probe\f.txt` in place `builtins.pathExists "/probe/f.txt"` was `true` from `C:\` and `false` from `D:\`, and one value named different files depending on where the evaluator ran. The drive is now fixed by configuration: `C:` for the default `C:\nix\store`, or the drive of the directory `--store` names. The value keeps its spelling, so `toString /probe/f.txt` is still `"/probe/f.txt"`, and a `/nix/store` path resolves through the store directory as before, not through the store drive's `\nix\store`. The rule holds at every place a path reaches the filesystem: `readFile`, `pathExists`, `readDir`, `readFileType`, `hashFile`, `import`, `scopedImport`, search path lookups, copies into the store, and the local paths `fetchurl`, `fetchTarball` and `fetchGit` hand to curl and git, which receive the drive as `file://C:/...` or `C:/...`. Under `--restrict-eval` and `--pure-eval` the check uses the same drive as the read, so a search path root given without a drive admits the drive-qualified spelling of the same files, and the reverse. A path that names a drive, and every path on macOS and Linux, behaves as before. Upstream still resolves such a path against the current drive; NixOS/nix issue 16412 is open on that design. (#363) +- **`builtins.unsafeGetAttrPos` gives the position an attribute was defined at, `{ column; file; line; }` for one defined in a file, where it gave `null` for every attribute.** Upstream answers with `EvalState::mkPos` of the attribute's position (`prim_unsafeGetAttrPos`, primops.cc at 2.24.9), and its positions are matched: a binding is at the first token of its attribute path, every level of a dotted `a.b.c = v;` at the path's, and an inherited name at the name, as upstream's parser records them (parser.y, parser-state.hh); a binding merged into an earlier path keeps its own position and the path its first; `//`, `removeAttrs` and `intersectAttrs` keep the positions of the attributes they copy, `listToAttrs` gives each attribute the position of its element's `value` attribute, and every other set a builtin makes, `mapAttrs`'s included, has none. A missing attribute, one with no position and one defined in an `--expr` argument give `null`, as upstream's do for text with no file behind it. The name is checked before the set is forced, as upstream's `forceStringNoCtx` of it runs first. nixpkgs reads the position for `meta.position`. A derivation's own attributes report the lines of the `derivation` wrapper in `/derivation-internal.nix`, which differ from upstream's. Columns count characters where upstream's count bytes, so they differ on a line with non-ASCII text before the attribute; they follow the lexer, whose parse errors count the same way. The `file` of a file outside the store is the path the import read, with every symlink on the way to it resolved, where upstream keeps the path as written and follows only a symlink at its end (`resolveExprPath`, eval.cc), so the two differ for a file reached through a symlinked directory. `builtins.functionArgs` gives its attributes no position, where upstream gives each formal's. (#361) +- **A string literal in a file evaluates to the bytes written in it, so bytes that are not UTF-8 reach the eval string as they are, where they became U+FFFD.** A source was decoded to text before lexing, and what was not UTF-8 was replaced. Upstream reads a file's bytes (`SourcePath::readFile` at 2.24.9) and its flex scanner lexes them (lexer.l), so a literal's value is its source bytes with escapes resolved, and the lexer here now reads bytes too. Upstream drops a double-quoted literal's bytes from a NUL to its next interpolation or its closing quote (`unescapeStr` stops at the NUL, lexer.l), where nova-nix keeps them. The lexer's token classes are upstream's, all ASCII: a letter outside ASCII, such as U+00E9, starts no identifier and continues none, so a name holding one is a syntax error, as it is upstream; a byte outside ASCII ends a path, a search path or a URI; and whitespace is space, tab, carriage return and newline, so a vertical tab, a form feed or a space outside ASCII such as U+00A0 is a syntax error. A comment may hold bytes that are not UTF-8. Columns still count characters where upstream's count bytes, a byte that continues a UTF-8 sequence taking its character's column, and a newline escaped in an indented string (`''\` before it) now ends a line for the positions after it. A string used as an attribute name (`{ "x" = 1; }`, `inherit "x";`) must be UTF-8, since attribute names are text here: one that is not is a syntax error at its string, where upstream makes a symbol of any bytes (the `attrpath` and `attrs` rules, parser.y). A key after a dot in an attribute path that fails to parse is reported at the key, where the error blamed the dot. An `--expr` argument is still decoded as text before it is lexed, which #370 tracks. (#368) +- **A source opening with a UTF-16 byte order mark is transcoded to UTF-8 before it is lexed, and malformed UTF-16 is a syntax error at the bad code unit, rather than being replaced.** An unpaired surrogate or an odd final byte has no UTF-8 spelling, and replacing it changed the source. Upstream reads no byte order mark (`EvalState::parseExprFromFile`, eval.cc at 2.24.9): no rule of its scanner but the catch-all takes a mark's first byte, and the grammar refuses the token that rule returns, so a file marked UTF-16 or UTF-8 fails to parse there. nova-nix reads a UTF-16 mark in either byte order, for the Windows tools that write one, and drops a UTF-8 mark as before. (#368) +- **A carriage return ends a line, as in upstream: a `#` comment ends at the first CR or LF, and an LF, a CRLF and a bare CR each end one line in every position the lexer reports.** A comment ran to the next LF, so in a file with bare CR line endings it swallowed the code after it, and positions ended a line at a bare CR only where a double-quoted string reads it as an LF, so parse errors put what followed any other bare CR on the wrong line. Upstream's line comment is `\#[^\r\n]*` (lexer.l at 2.24.9) and its position table splits a source at an LF, a CRLF or a bare CR (`Pos::LinesIterator`, position.cc), and both now hold here for whitespace, comments, both kinds of string, their escapes, and the position of a malformed UTF-16 source's error. A string's value is unchanged: a double-quoted string still reads a raw CR or CRLF as an LF, and an indented string keeps its CRs. A syntax error at the end of input after a trailing line comment stands past the comment, at the end of input as upstream reports it (`yyerror`, parser.y), where it stood at the `#`. (#372) +- **`derivation` is a lambda written for nova-nix, and `NOTICE` lists the material nova-nix carries from other projects.** `derivation` evaluated upstream's `src/libexpr/primops/derivation.nix` expression (LGPL-2.1). The replacement gives the same result as upstream's for every argument wherever nova-nix's evaluator agrees with upstream's: the same attributes and values, `derivationStrict` reached only through `drvPath` and `outPath`, the same step failing first for each malformed `outputs`, and the arguments' own values in the result, which `==` shows for a function argument. The parity job probes it against upstream's `nix-instantiate` over a corpus of arguments in `test/data/derivation-probes.txt`, with the rows where the evaluator is known to differ from upstream listed in `test/data/derivation-divergences.txt`, and the test suite pins what the probes read. `NOTICE` names what nova-nix carries from nixpkgs, with its license: `pkgs/windows/mirrors.nix`, copied from it, and the Mes package's `package.nix`, `libc.nix` and `nyacc.nix`, adapted from its minimal-bootstrap. The new wrapper's identifiers are interned at startup in place of upstream's, as upstream interns its own wrapper's, so an error that names attributes in interning order can name a different attribute from upstream's: a call with the unexpected arguments `zzz` and `x`, written in that order in a file, named `x`, as upstream does, and now names `zzz` (#378). (#373, #393) + +### Store + +- **A registration that references a path the store has not registered is refused with upstream's message, `path '/nix/store/...' is not valid`, naming the path under `/nix/store` wherever the store is kept.** The refusal read `registerPaths: references unregistered path `, with both paths spelled under the store's own directory, so on Windows or under `--store` it named `C:\nix\store\...` or the relocated directory. Upstream refuses the reference in `registerValidPaths` through `queryValidPathId` (local-store.cc at 2.24.9, and the same at 2.34.9 and 2.35.4), which names it with `printStorePath`. That spells a path under the logical store directory, which stays `/nix/store` for a store whose files live elsewhere (`realStoreDir`, local-fs-store.hh). Of several unregistered references the one named is the one upstream names, as the batch and each path's references are walked in path order. A build meets the refusal when a derivation or a `builtins.toFile` text carries string context naming a store path this store has not registered, as `builtins.appendContext` and `builtins.storePath` can give it. A cache that declares references looping between paths meets it too, and there it fails the substitution as any failed substitute does, so the build stops unless `--fallback` is given. Upstream's evaluation refuses such a context earlier, when `ensurePath` cannot substitute the path; among its own commands, `nix-store --register-validity` and `nix-store --import` reach it. (#388) + +### Builder + +- **An output that records an already-valid sibling now builds, with the sibling's real path in its bytes.** A rebuild of a partly valid derivation writes the valid output to a scratch path, and an output that recorded that path used to fail the build, because the scratch tree is discarded. Upstream rewrites the scratch hash to the final one in the output (`rewriteOutput` at 2.24.9) and the build succeeds. The hash is now rewritten across file contents, symlink targets and entry names, so the output names its sibling and records the reference. Upstream scans and then rewrites; nova-nix rewrites and then scans, which finds the same references with no translation. Upstream's rewrite runs over a serialized NAR, so a rename that changes a directory's sort order fails there, depending on the hash values, and succeeds here. Reference scanning also now covers entry names, as upstream's scan of the NAR does, so a hash held only in a file name records its reference. (#328) +- **A build records a reference to any path in its inputs' closure that an output embeds, not only to its direct inputs.** Reference scanning looked for the input sources, the input derivations' outputs and their `.drv` files, so an output embedding a path an input only references, such as a library the input propagates, registered without that reference. A garbage collection could then delete a path a live output still used, and a pushed closure could lack it. Upstream scans for its `inputPaths`, the closures of the requested input outputs and of the input sources under their registered references (`derivation-goal.cc` at 2.24.9), plus the derivation's own outputs (`referenceablePaths` in `local-derivation-goal.cc`), and the scan now uses that set. An input derivation's `.drv` is not in it, so an output that embeds one no longer records it, as upstream's does not; a `.drv` an input source's closure reaches, as one a `drvPath`'s context brings in, is still recorded. (#333) +- **An attribute named in `passAsFile` reaches the builder as a file in the build directory, named by `Path`, rather than as a variable, as upstream passes it.** The builder put every attribute in the environment, so a builder that reads only the file failed: the minimal bootstrap's `writeTextFile` in nixpkgs runs `cp ${textPath} ${target}` with no fallback. Builders that fall back to the variable, as stdenv's `genericBuild` and `writeTextFile` do, got the value through the environment, subject to the size limit `passAsFile` exists to avoid, and an attribute holding bytes that are not UTF-8 failed the build although it never needed to be text. Upstream (`initTmpDir`, local-derivation-goal.cc at 2.24.9) splits `passAsFile` at spaces, tabs, newlines and carriage returns, writes each attribute it names to `.attr-` followed by the Nix base-32 SHA-256 of the attribute's name, sets `Path` to that file and leaves the attribute itself out of the environment. A name with no attribute is ignored, an attribute literally called `Path` keeps its own value, and a structured-attributes derivation ignores `passAsFile`. nova-nix now does each of these, and its file name for `foo` is the one upstream's own test pins. The file holds the bytes the variable would have held, store paths and placeholders rewritten and every other byte as the derivation has it, and an output passed this way holds the path the build writes it to. On Windows the variable joins the build directory and the file name with a backslash, as `NIX_BUILD_TOP` is spelled, where upstream writes `/`. (#343) +- **A builder's standard output reaches the build log with its standard error, in the order the builder wrote them, and `build` prints each line on stderr as it completes.** Standard output was discarded, and standard error was held until the builder exited and then shown only inside a failure message. Upstream hands the builder one channel for both, its standard output a copy of its standard error (`commonChildInit`, child.cc at 2.24.9), and its default logger prints every build-log line to stderr as it arrives (`SimpleLogger`, logging.cc). `nix-build` keeps that logger, so it shows the whole log while the build runs and adds no `log-lines` tail to the failure (derivation-goal.cc). A failed builder's `BuildFailure` message is now `builder failed`, with its output in the log rather than the message. Lines follow upstream's discipline (`DerivationGoal::handleChildOutput`): a carriage return returns to the start of the line, so a Windows program's CRLF ends a line without its CR and a progress counter redrawn after CRs leaves its last state, and an unterminated last line is flushed when the output ends. Upstream's channel is a pseudoterminal and this one is a pipe, which `System.Process` offers on Windows as well as POSIX, so a program that line-buffers or colours its output only on a terminal block-buffers and stays plain here. On POSIX both ends of the pipe are close-on-exec, so the builder holds it only as its standard output and standard error, as upstream's child does after `closeMostFDs`, and a daemon that closes those lets the build finish. Each line is filtered as upstream's logger filters it (`filterANSIEscapes`, terminal.cc): a tab becomes spaces to the next multiple of eight columns, a bell is dropped, and an escape sequence is dropped, except that colour (an SGR sequence) is kept on a terminal whose `TERM` is set and not `dumb` with neither `NO_COLOR` nor `NOCOLOR` set (`isTTY`), so a builder cannot move the cursor, clear the screen or set the title of the terminal running the build. A line that cannot be written to stderr is dropped and the build goes on, as upstream's `writeToStderr` ignores a failing write, so a closed reader of stderr does not fail the build. Upstream reads a line beginning `@nix ` as a JSON log message and does not print one that parses (`handleJSONLogMessage`); here every line is printed, and since nova-nix sets no `NIX_LOG_FD`, where upstream sets it to 2, nixpkgs' stdenv writes no such lines, and its `nixErrorLog` family writes nothing. Upstream also keeps the log in a file that `nix log` reads back (`keep-build-log`); nova-nix keeps none. (#349) +- **A build whose outputs reference each other in a cycle fails with upstream's message, `cycle detected in build of '/nix/store/...-foo.drv' in the references of output 'dev' from output 'out'`, and registers none of them.** Both outputs used to register, each naming the other, which left a reference cycle that upstream's own registration refuses (`registerValidPaths`, local-store.cc at 2.24.9) and a pair of paths neither of which could be deleted alone, since each had a referrer. Upstream scans every output first, orders the outputs so that each follows the siblings it references, and fails the build on a cycle before any output is registered (`registerOutputs`, local-derivation-goal.cc, and `topoSort`, topo-sort.hh). The ordering here is upstream's depth-first walk, so the outputs are placed in upstream's order and a cycle is reported through the same two outputs upstream names. A self-reference and a one-way reference between outputs still build. An output registered before the build, as in a partial rebuild, counts as referencing nothing, as upstream counts it, so a rebuilt output may reference it whatever its discarded copy references. The CLI prints the message after its own `build failed (exit 1): building failed: exit 1: ` prefix, where upstream prints `error: ` (#397). (#353) +- **`builtin:unpack` reads `.tar.gz` archives, a format GitHub serves a commit's tree in.** It read `.tar.zst` and plain `.tar`, which covers MSYS2's packages, and GitHub's archive endpoint offers only gzip and zip, so a repository pinned at a commit could not be unpacked before a tool to unpack it existed. The decompressor is still chosen by the archive's name. A corrupt or truncated stream fails the build with the decoder's message, as a corrupt zstd frame does. The pax global header `git archive` writes first, which carries the commit id, is skipped like any other. (#347) + +### Substitution + +- **`build` with a substituter tries a derivation's outputs before its inputs, and a substituted path arrives with its runtime closure.** Dependencies used to be walked leaves first, so every build-time input was fetched or built before the root's own outputs were tried: `pkgsCross.mingwW64.hello`, one 0.19 MB path on cache.nixos.org, was still fetching at its 270th path after 90 seconds, and now takes one substitution and no builds. Upstream tries outputs first (`DerivationGoal::haveDerivation` at 2.24.9) and only then falls back to inputs, so a derivation the cache holds no longer realises its inputs. A narinfo's references are realised before the path that names them, as upstream's `PathSubstitutionGoal` does, after the narinfo passes the same identity and signature checks as a substitution, so the store stays closed under references. A reference no cache holds leaves that substitution incomplete, so the inputs are realised and the substitution is retried once, matching upstream's `retrySubstitution`; if the hole remains, the derivation builds. (#331) +- **A cache that fails now stops the build, as upstream's does, and `--fallback` or the `fallback` setting builds from source instead.** A failed substitution was treated like a path the cache lacks, so a 503 that outlived its retries, a NAR that did not verify, a compression nova-nix cannot decode or a narinfo that would not parse sent the build on from source, and with outputs tried before inputs one transient failure on a root started its whole input tree. Upstream tells the two apart (`substitution-goal.cc` and `derivation-goal.cc` at 2.24.9). A NAR a cache offers and fails to deliver, once every cache has been tried, fails the derivation with upstream's message, `some substitutes for the outputs of derivation '...' failed (usually happens due to networking issues); try '--fallback' to build derivation from source`, and exit status 1; the CLI prints it after its own `build failed (exit 1): ` prefix (#397). The `.drv` is named under `/nix/store` wherever the store's files live, on Windows and under `--store` too, as upstream's `printStorePath` prints a relocated store's logical directory. A narinfo query that fails stops the build with that failure before a later cache is asked, as upstream rethrows it. Under `--fallback`, or `fallback = true` (alias `build-fallback`) in nix.conf, a failed query is reported and the next cache asked, and a failed substitute is reported and the derivation builds. A cache without the narinfo, a narinfo for another path or one no trusted key signed, and a NAR the cache answers with 401, 403, 404, 407 or 410, the statuses upstream reads as the file being absent, are passed over as before, so what no cache holds still builds with no flag. Upstream also disables a failing cache for 60 seconds under `fallback`; here each path asks it again. (#346, #355) +- **A substitution takes its output locks in the same order as a build, so the two cannot deadlock.** A multi-output substitution locked its outputs in the derivation's order and held each until the batch registered, while a build locks them in store path order. Two processes working on the same derivation could each hold the lock the other was waiting for, and the blocking lock has no timeout, so both would hang. Both now take their locks through one ordering. (#323) + +### Windows packages + +- **`pkgs/windows` builds stage0-pe32's chain as derivations, from a 1,623-byte seed to hex0, hex1, hex2, catm, M0, cc_x86, M2-Planet, M1, hex2-new and kaem.** The Windows stdenv starts from prebuilt MSYS2 and MinGW-w64 packages, and this is the first part of a path that starts from source instead. Each derivation is one command of stage0-pe32's `x86/mescc-tools-mini.cmd`, its builder the link that command runs and its output the one file the command writes, the shape nixpkgs gives stage0-posix's chain in `minimal-bootstrap/stage0-posix/mescc-tools-boot.nix`. Each link is `stage0-pe32.`, with M2-Planet as `M2` and kaem as `kaem-unwrapped`. The links are 32-bit PE, so each step is an `i686-windows` derivation, which x64 Windows runs through WoW64 and ARM64 Windows through its x86 emulator. Nothing in the chain runs `cmd.exe` or a shell, and nothing comes from the MSYS2 seed: its only inputs are the seed, fetched on its own, and stage0-pe32 at ff1c2ad with the M2-Planet, M2libc and mescc-tools commits it pins, each repository fetched as GitHub's archive with `builtin:fetchurl` and unpacked with `builtin:unpack`. hex0 is fixed-output to the seed's own hash, as nixpkgs' is, so a seed that does not reproduce itself fails the build. CI builds the chain on x64 and ARM64 Windows, with the x64 nova-nix on both, and checks each link against the SHA-256 stage0-pe32's own CI prints for the same commit. (#347, #354) +- **`pkgs/windows` builds mescc-tools-extra's thirteen programs from stage0-pe32's links, as `stage0-pe32.mescc-tools-extra.`: sha256sum, match, mkdir, untar, ungz, unbz2, unxz, catm, cp, chmod, rm, replace and wrap.** nixpkgs builds them with M2-Mesoplanet in `minimal-bootstrap/stage0-posix/mescc-tools-extra/build.kaem`, and M2-Mesoplanet has no Windows target. Here one function in the stage0-pe32 package set turns a program's name, sources and C library files into the five steps stage0-pe32's `x86/mescc-tools-mini.cmd` gives kaem: M2-Planet with `-D __windows__=1`, catm, M0, catm and the hand-written hex2, each its own `i686-windows` derivation. M2-Planet skips every `#include` line unless given `--expand-includes`, which the .cmd does not pass, so each program's M2libc files are what its `#include` lines reach on the M2libc fork's `x86/windows` target, listed in the package. hex2-new and `kaem-unwrapped` are built by the same function. The sources are upstream's mescc-tools-extra at d1d8146, the commit stage0-pe32 pins. CI builds all thirteen on x64 and ARM64 Windows and runs each, checking its output against committed fixtures or bytes the job writes. On Windows, untar stops at a symlink unless given `--non-strict`, because M2libc's Windows `symlink` always fails; chmod sets only the executable bit; `mkdir -p` and cp's copy into a directory split paths on `/` only; replace needs `--output`, because its default `/dev/stdout` does not exist; and wrap stops at its first mount, which M2libc's Windows `mount` always refuses. (#350, #354, #365) +- **`pkgs/windows`' stage0-pe32 installs kaem, mescc-tools and mescc-tools-extra as bin directories, and gives kaem nixpkgs' `runCommand`, with `writeText` beside it.** nixpkgs builds Mes and the stages after it up to bash 2.05b as scripts run by kaem's `runCommand` (`minimal-bootstrap/stage0-posix/kaem/default.nix`), which call their tools by name, and each link of stage0-pe32's chain is a single `.exe` file with no `bin/`. `stage0-pe32.kaem`, `mescc-tools` and `mescc-tools-extra` hold kaem, M2-Planet (the `M2` link), M1, hex2 (from `hex2-new`) and mescc-tools-extra's thirteen programs at `bin/.exe`, and keep each program as an attribute, so `stage0-pe32.mescc-tools-extra.` names the program itself; the single-file kaem is `stage0-pe32.kaem-unwrapped`, as nixpkgs names it. kaem lays each directory out itself with mescc-tools-extra's mkdir, cp and chmod, as nixpkgs installs its kaem, so nothing runs but the chain's own programs. `kaem.runCommand name env buildCommand` runs the script with `kaem --verbose --strict`, so the first command that fails fails the build. Its PATH is the three bin directories joined with `;`, which kaem splits PATH on under Windows, and kaem tries each bare name as given and then with `.exe`. `writeText name text` passes the text through `passAsFile`, as nixpkgs' does, since kaem refuses an environment entry of 4,096 bytes or more. Two things in `runCommand` differ from nixpkgs'. A store path in a script is spelled from `${NIX_STORE}`, because the builder spells the store `C:\nix\store` and kaem reads a backslash in a script as an escape, so `C:\nix` would reach a command as `C:`, a newline and `ix`, while kaem substitutes a variable's value as it stands. And `env` reaches the derivation as it stands, without nixpkgs' handling of `nativeBuildInputs`, `meta` and `passthru`, which nothing here passes. mescc-tools-extra's Windows limits apply to these scripts: cp is given the file it writes, not a directory, since it takes a destination that does not begin with `/` as relative; `mkdir -p` makes only the parents a path names before a `/`, and exits 0 even when it fails, as rm does. CI builds the bin directories on x64 and ARM64 Windows, checks each file against the program it was copied from, runs a script that calls mkdir, cp and catm by bare name, and checks that a script whose command fails fails its build. (#359) +- **On Windows a file that a program built on `pkgs/windows`' stage0 tools marks executable with `chmod` is executable in its NAR, as on Linux, and the bin directories of those tools mark their programs.** nova-nix keeps a regular file's executable bit on Windows as an NTFS alternate data stream, `:nova.exec`, and only `builtin:unpack`, NAR restores, store copies and `builtins.fetchGit` ever wrote one, so nothing a builder made was executable: a program built on Windows had a NAR hash different from the same output's built elsewhere, and a copy substituted from a Windows build was not executable. `pkgs/windows`' stage0-pe32 builds on its M2libc fork at 13e57eb, whose Windows `chmod` creates the stream when the owner execute bit is set and removes it when that bit is clear, the bit upstream's NAR serialisation reads (`S_IXUSR`), so a builder marks a program as it would on POSIX, and hex2-new's own `chmod(output_file, 0750)` marks what it links. The same M2libc's Windows `malloc` rounds each block's start and size to 8 bytes, the alignment Windows' own gives on x86, since Windows fails a file call whose name's buffer is at an odd address, and an unaligned heap left `chmod` failing silently in any program whose data ends at an odd byte, mescc-tools-extra's `chmod` among them. `stage0-pe32.kaem`, `mescc-tools` and `mescc-tools-extra` follow each `cp` with `chmod 555`, as nixpkgs' kaem and mescc-tools do. The single-file links stay unmarked: the seed writes hex0, hex0 writes hex1 and hex1 writes hex2, and hex0 has to stay byte-identical to the seed; the hand-written hex2 links the rest, and none of them calls chmod. A file a builder creates with M2libc's `open` and an execute mode is still not marked, since that `open` ignores its mode (#383), and neither is one marked with MSYS2's `chmod`, which writes no stream; MSYS2 is to be replaced by the source bootstrap (#26). CI checks on x64 and ARM64 Windows that every program in the bin directories carries the stream, and builds a fixed-output script whose declared hash is its tree's NAR hash on POSIX, with the file `chmod 555` marked executable and the one `chmod 755` and then `chmod 644` left plain. (#365) +- **On Windows a program built on `pkgs/windows`' stage0 tools can open a file to read while another holds it open to write, as on POSIX.** Every program from M0 up, mescc-tools-extra's included, carries one routine that opens a file, the `open_file` in stage0-pe32's `x86/ntdll-i386.hex2`, and M2libc's `open` and `fopen` reach it. Windows refuses an open whose sharing does not admit the access an earlier open already holds, where POSIX does not refuse an open because another process has the file open to read or write, so at ff1c2ad, the commit `pkgs/windows` pins, the routine shares a file for reading, writing and deletion. GNU Mes keeps each file it writes open until it exits, and MesCC runs M1 on the assembly it has just written, which M1 could not open if the routine shared for reading alone. hex0, hex1, hex2 and catm carry their own copies, which share a file for reading alone. (#374) +- **`pkgs/windows` builds GNU Mes 0.27.1 on the Windows stage0 tools: `mes.srcPost` (with mes-m2.exe), `mes.libs` (the Mes C library compiled by MesCC), `mes.compiler` (mes.exe compiled by MesCC) and `mes.libc` (the library's sources for TinyCC).** They are nixpkgs' `minimal-bootstrap/mes` derivations, each an `i686-windows` `kaem.runCommand` script on stage0-pe32's bin directories, built from the Novavero-AI/mes fork at d9ab4ea, which ports Mes 0.27.1 to Windows and carries nixpkgs' i686 C library fixes as commits. NYACC is nixpkgs' 1.09.1, fetched from the `mirror://savannah` sites in the mirror list copied from nixpkgs. Five things differ from nixpkgs. The paths Mes reads from the environment, `MES_PREFIX`, `GUILE_LOAD_PATH` and MesCC's `M1` and `HEX2`, stay there, set by every derivation that runs Mes and given to callers as `mes.env`, where nixpkgs writes them into Mes's C and Scheme source: the builder spells a store path `C:\nix\store/...`, and the backslash would start an escape in a string of either language. Mes's arena is 20,000,000 cells, set in the environment as well, since nixpkgs' 100,000,000 with its stack is more than the 1 GiB the Windows port reserves for all of Mes's memory; the cells Mes keeps across a collection have to fit in the tenth past the arena, and CI measures them while MesCC compiles libc+tcc, the largest library. MesCC is given `--base-address 0x400000`, the ImageBase of the port's PE header, where it links at Linux's 0x1000000 by default, and starts a program from a crt1 assembled from the port's M1 startup, which splits the command line Windows hands a program into argc and argv. `mes.libc` holds `crt1.c` alone of the startup files and has no `include` link: lib/windows has no `crti.c` or `crtn.c`, and nixpkgs makes the link with `ln-boot`, which needs a `symlink` the Windows Mes C library does not have. And `mes.libc` carries no `CFLAGS`, where nixpkgs' passes `-std=c11` through `passthru`. CI builds all of it on x64 and ARM64 Windows from the seed, runs mes-m2 and mes with `--version`, and runs a program MesCC compiled with mes, checking what it prints and the status it exits with. (#371, #385) +- **On Windows a file that a program built on Mes libc marks executable, with `chmod` or by creating it with `open` and a mode that has the owner execute bit, is executable in its NAR, as on Linux.** nova-nix keeps a regular file's executable bit on Windows as the `:nova.exec` stream, and Windows has no such bit for a C library to set, so a Mes libc that accepted a mode and ignored it would leave plain whatever a program linked with it marked executable, a compiler's output among them, and that output's NAR hash would differ from the same output's built elsewhere. `pkgs/windows`' Mes builds from the Novavero-AI/mes fork at d9ab4ea, whose Windows `chmod` creates the stream when the mode has the owner execute bit (`S_IXUSR`), the bit upstream's NAR serialisation reads, and removes it when that bit is clear, as the stage0 tools' M2libc `chmod` does. Its `open` marks a file it creates when the mode has that bit, since Linux applies the mode only to a file `open` creates. Mes libc keeps no umask on Windows, so `open` uses the mode as given; upstream runs its builders under umask 022 (`initNix`), which never clears the owner execute bit, so the bit comes out the same. CI on x64 and ARM64 Windows builds a fixed-output derivation in which a program MesCC compiles and links against `mes.libs` creates one file with `open` and mode 0755, one with 0644, and one with 0644 that it then `chmod`s to 0755, and whose declared hash is that tree's NAR hash on POSIX with the first and third executable. (#385) + +### Distribution + +- **Every export has Haddock, and no reference in the Hackage documentation is out of scope or ambiguous.** Haddock was built only when a release was uploaded, so five exports had no documentation and 72 references named no identifier or more than one, rendering as plain text or as links to anchors that do not exist. Every module's coverage is 100%; a reference is qualified, given its namespace, or set as code when nothing exports it; and the Linux build runs Haddock on every change and fails on a gap. (#319, #396) +- **The README's links resolve on Hackage.** Hackage renders a relative link as `/package/`, so the README's links to LICENSE, NOTICE and CONTRIBUTING.md returned 404 there. They point to the files on GitHub, and the Linux build fails on a relative README link or a README command `--help` does not list. (#392) + +### Dependencies + +- **The `nova-cache` bound admits 0.12, at `>= 0.11.1.1 && < 0.13` in the library and the test suite.** 0.12.0.0's major version marks a change to its server, which nova-nix does not use, and no module nova-nix imports changes beyond its comments, so the floor stays. (#322) +- **The library depends on `zlib >= 0.7 && < 0.8`, for `builtin:unpack`'s gzip decoder.** 0.7 is the first release whose `Codec.Compression.GZip` exports `DecompressError`, the error a corrupt stream throws. zlib was already in the build through http-client's dependency on streaming-commons. (#347) +- **The test suite adds `mtl >= 2.2 && < 2.4` and `zlib >= 0.7 && < 0.8`.** (#331, #347) + ## 0.9.0.0 - 2026-10-31 On nixpkgs 26.05 and unstable, where 0.8.0.0 failed, CI now holds 22 derivations to the store paths upstream computes, on Nix 2.34.9 and 2.35.4 respectively, alongside Nix 2.24.9 with nixpkgs 24.11. diff --git a/NOTICE b/NOTICE --- a/NOTICE +++ b/NOTICE @@ -4,3 +4,60 @@ This product is licensed under the Apache License, Version 2.0. A copy of the License is provided in the LICENSE file, or at http://www.apache.org/licenses/LICENSE-2.0 + +This product includes material from other projects, under their own +licenses: + +pkgs/windows/mirrors.nix + Sets copied from pkgs/build-support/fetchurl/mirrors.nix in nixpkgs + (https://github.com/NixOS/nixpkgs) at commit + 50ab793786d9de88ee30ec4e4c24fb4236fc2674. Licensed under the MIT + License: + + Copyright (c) 2003-2024 Eelco Dolstra and the Nixpkgs/NixOS contributors + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +pkgs/windows/by-name/me/mes/package.nix, libc.nix and nyacc.nix + Adapted from pkgs/os-specific/linux/minimal-bootstrap/mes/default.nix, + libc.nix and nyacc.nix in nixpkgs (https://github.com/NixOS/nixpkgs) at + commit 1d060086d60cb76a40cf37109f979d88a5bd6396. Licensed under the MIT + License: + + Copyright (c) 2003-2026 Eelco Dolstra and the Nixpkgs/NixOS contributors + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE + LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION + OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,81 +2,74 @@ [![CI](https://github.com/Novavero-AI/nova-nix/actions/workflows/ci.yml/badge.svg)](https://github.com/Novavero-AI/nova-nix/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/nova-nix.svg)](https://hackage.haskell.org/package/nova-nix) -[![License](https://img.shields.io/badge/license-Apache--2.0-blue)](LICENSE) - -nova-nix exists to make [Nix](https://nixos.org) work natively on Windows: -the same language, the same `/nix/store` paths and the same binary caches as -upstream Nix, without WSL or an existing Nix installation. +[![License](https://img.shields.io/badge/license-Apache--2.0-blue)](https://github.com/Novavero-AI/nova-nix/blob/main/LICENSE) -It is an implementation of Nix in Haskell with a C99 data layer, and it has -its own parser, evaluator, store, builder and binary-cache substituter. It -also builds and runs on macOS and Linux. +nova-nix is an implementation of [Nix](https://nixos.org) that runs natively on +Windows, without WSL or an existing Nix installation: the same language, the +same `/nix/store` paths as upstream Nix on Linux and macOS, and the same binary +caches. It is written in Haskell with a C99 data layer, has its own parser, +evaluator, store, builder and binary-cache substituter, and also runs on macOS +and Linux. nova-nix is experimental. Read [Limitations](#limitations) before relying on it. ## Status -- **Evaluation matches upstream Nix on the cases CI checks.** 22 derivations - evaluate to the same store paths as upstream on three pinned pairings: Nix - 2.24.9 with nixpkgs 24.11, Nix 2.34.9 with nixpkgs 26.05, and Nix 2.35.4 - with nixpkgs unstable. They span the native, i686 and musl stdenv - bootstraps, cross-compilation to aarch64 Linux and Windows, multi-output - packages such as curl and systemd, sources fetched through git, GitHub, - PyPI and the cargo and Go vendoring fetchers, a NixOS initrd and system, - and fixtures for derivation inputs, `builtins.toFile` and - `builtins.fetchGit`. 49 smaller evaluation cases produce the same output. - CI runs this comparison on every change. A matching `drvPath` means the - whole build-time closure behind it matches too. How much of the rest of - nixpkgs evaluates has not been measured yet ([#29]). -- **Windows builds run natively.** CI builds GNU Hello on a Windows runner - through a stage-1 stdenv. Its toolchain is 17 MinGW-w64 packages and 22 - MSYS2 packages, each fetched as a fixed-output derivation pinned by SHA-256 - and unpacked into the store. sed, zlib and a small library-linking example - also have recipes, but CI does not build them. Replacing these binary seeds - with a toolchain built from source is tracked in [#26]. -- **Binary caches work in both directions.** `nova-nix push` uploads a - closure, and `build --substituter` downloads signed NARs instead of - building. CI checks this two ways. On Linux, two fixtures are pushed to a - local nova-cache server and substituted into a second empty store with - signature verification on: a small tree whose two copies must serialize - to the same NAR, and a 320 MiB tree that must substitute under a 128 MiB - heap cap. On every push to main, a Windows job builds the Hello closure, - runs Hello and publishes the closure to the public cache at - [cache.novavero.ai](https://cache.novavero.ai), and a second Windows job - builds the same closure into an empty store with that cache as its only - substituter, fails if any path is built locally, and runs the result. +- **Evaluation matches upstream Nix on the cases CI checks.** On every change, + CI evaluates the nixpkgs derivations in [`drvpath-cases.txt`] and the + expressions in [`eval-cases.sh`] with nova-nix and with upstream Nix, on each + pairing of Nix and nixpkgs that [`parity.yml`] pins, and requires the same + results. A matching `drvPath` means the whole build-time closure behind it + matches too. It also probes `derivation` against upstream's over a corpus of + calls, apart from the differences [`derivation-divergences.txt`] lists. How + much of the rest of nixpkgs evaluates is not measured ([#29]). +- **Windows builds run natively.** CI builds GNU Hello on Windows through a + stage-1 stdenv whose toolchain is prebuilt MinGW-w64 and MSYS2 packages, + each pinned by SHA-256 ([`pkgs/windows/bootstrap`]). Replacing them with a + toolchain built from source is tracked in [#26]. CI builds the start of it + on x64 and ARM64 Windows from the 1,623-byte seed of [stage0-pe32]: the + chain up to kaem, mescc-tools-extra, and [a Windows port] of GNU Mes 0.27.1. +- **Binary caches work in both directions.** `nova-nix push` uploads a closure + to a [nova-cache] server, which signs it, and a build given a substituter + downloads signed NARs from an HTTP binary cache instead of building. CI + substitutes from a local nova-cache server on Linux. On every push to main + it publishes the Windows Hello closure to the public cache at + [cache.novavero.ai](https://cache.novavero.ai), then builds that closure into + an empty store with the cache as its only substituter and fails if any path + is built locally. ### Limitations - No flakes, no `nix-shell` or `nix develop`, and no daemon or multi-user mode. -- Evaluation is slower than upstream's. CI's 22 `drvPath` cases take 10 to 13 - times as long in total, and a full NixOS system takes 22 to 30 times as long. -- `build --substituter` works through a package's build closure from the - leaves up, so a package a cache holds still downloads its build-time - dependencies ([#307]). +- Evaluation is slower than upstream's, most of all on large evaluations such + as a NixOS system. The Parity job logs both evaluators' times for each + derivation case. - Garbage collection has no runtime roots: `nova-nix store gc` keeps what `build --out-link` registered and what the operator roots under the store's `.nova-nix/gcroots`, not what a running program has open. `keep-derivations` - and `keep-outputs` are not implemented, so an unrooted `.drv` is collected. - `build` creates no result link unless `--out-link` is given, where - `nix-build` defaults to `./result`. -- `--restrict-eval` and `--pure-eval` exist (and `restrict-eval`, `pure-eval` - and `allowed-uris` in nix.conf), gating reads, the environment and fetches - the way upstream's modes do. The closure of a search path root that is a - store path is not allowed along with it, and the bundled `` directory - stays listed in `builtins.nixPath` under `--pure-eval`, where upstream - shows an empty list. -- The Windows store is `C:\nix\store`, where upstream's Windows default is - `%PROGRAMDATA%\nix\store`, so the two do not share store paths on Windows - ([#309]). -- On Windows a build's process tree runs in a job object, so stopping a build - stops everything it started. No platform has filesystem or network - isolation yet ([#25]). -- nova-nix itself needs neither WSL nor Cygwin, but the current Windows stdenv - runs its build scripts with MSYS2's bash. + and `keep-outputs` are not implemented, so a rooted output does not keep the + `.drv` that built it. `build` creates no result link unless `--out-link` is + given, where `nix-build` defaults to `./result`. +- `--restrict-eval` and `--pure-eval`, and `restrict-eval`, `pure-eval` and + `allowed-uris` in nix.conf, gate reads, the environment and fetches as + upstream's modes do, with three differences: the closure of a search path + root that is a store path is not allowed along with it, + `builtins.findFile` treats a path the policy refuses as absent, and under + `--pure-eval` `builtins.nixPath` lists the bundled `` directory, + where upstream's is empty. - `builtins.fetchurl` runs `curl`, `builtins.fetchTarball` runs `sh`, `curl` and `tar`, and `builtins.fetchGit` runs `git`, each from `PATH`. +- A store path's hash covers the spelling of the store directory. On Windows + nova-nix hashes over `/nix/store`, as Linux and macOS do. Upstream's local + store on Windows hashes over its native directory, `%ProgramData%\nix\store` + by default since Nix 2.35, so the same derivation has a different store path + in each. +- On Windows a build's process tree runs in a job object, so stopping a build + stops everything it started. No platform isolates a build's filesystem or + network; a Windows filesystem sandbox is tracked in [#194]. +- nova-nix itself needs neither WSL nor Cygwin, but the Windows stdenv runs its + build scripts with MSYS2's bash. - Store paths that contain symlinks need Windows Developer Mode or an elevated shell. nova-nix creates native symlinks and fails rather than falling back to a copy. @@ -92,11 +85,11 @@ | macOS arm64 | [`nova-nix-macos-arm64.tar.gz`](https://github.com/Novavero-AI/nova-nix/releases/latest/download/nova-nix-macos-arm64.tar.gz) | | Windows x86_64 | [`nova-nix-windows-x64.zip`](https://github.com/Novavero-AI/nova-nix/releases/latest/download/nova-nix-windows-x64.zip) | -Each archive unpacks to a single directory holding `bin/`, `share/nova-nix/` -and `pkgs/`. `share/nova-nix/` provides the `` search path, so the -binary works wherever the directory is unpacked, and `pkgs/` holds the package -recipes. Check the download against the `SHA256SUMS` file attached to the same -release. +Each archive unpacks to a single directory holding `bin/`, `share/nova-nix/`, +`pkgs/` and the license files. `share/nova-nix/` provides the `` search +path, so the binary works wherever the directory is unpacked, and `pkgs/` holds +the package recipes. Check the download against the `SHA256SUMS` file attached +to the same release, with `sha256sum --ignore-missing -c SHA256SUMS`. In a GitHub Actions workflow: @@ -110,105 +103,55 @@ ```console $ nova-nix eval --expr '1 + 2' 3 -$ nova-nix eval --strict --expr 'builtins.map (x: x * x) [ 1 2 3 4 5 ]' -[ 1 4 9 16 25 ] -``` - -```console -$ nova-nix eval FILE.nix # evaluate a file -$ nova-nix build FILE.nix -A ATTR # build an attribute of it -$ nova-nix build FILE.nix --substituter URL --trusted-key KEY # try a cache first -$ nova-nix build FILE.nix --out-link result # link the result and root it -$ nova-nix store gc # delete everything unrooted -$ nova-nix push --cache URL --key-file FILE --all # upload every path except derivations -$ nova-nix --help +$ nova-nix build FILE.nix -A ATTR --out-link result +$ nova-nix build FILE.nix --substituter URL --trusted-key KEY --fallback +$ nova-nix store gc ``` -Evaluating a package from nixpkgs, on the 24.11 revision CI pins: - -```console -$ NIX_PATH=nixpkgs=/path/to/nixpkgs nova-nix eval --expr \ - '(import { system = "x86_64-linux"; config = {}; overlays = []; }).hello.drvPath' -"/nix/store/gciipqhqkdlqqn803zd4a389v86ran45-hello-2.12.1.drv" -``` +`nova-nix --help` lists every command and flag. -Building GNU Hello on Windows, from the unpacked release directory: +Building GNU Hello on Windows, from the unpacked release directory, with the +[public cache](https://cache.novavero.ai) as its substituter: ```console -> bin\nova-nix build pkgs\windows\hello.nix +> bin\nova-nix build pkgs\windows\hello.nix --substituter https://cache.novavero.ai --trusted-key cache.novavero.ai-1:9gQ7tLWMM+2tdC9H5sKMJltDIPfD7X2GWlZe8Aa8hHQ= ... C:\nix\store\-hello > C:\nix\store\-hello\bin\hello.exe Hello, world! ``` -The first build fetches 40 pinned archives (the 39 toolchain packages and the -Hello source), then builds the MSYS2 seed, the MinGW-w64 seed and Hello. The -[public cache](https://cache.novavero.ai) holds this closure as CI last built -it from main, so a build that names the cache downloads what it holds and -builds only what it lacks: - -```console -> bin\nova-nix build pkgs\windows\hello.nix --substituter https://cache.novavero.ai --trusted-key cache.novavero.ai-1:9gQ7tLWMM+2tdC9H5sKMJltDIPfD7X2GWlZe8Aa8hHQ= -``` - -## How it works +The cache holds this closure as CI last built it from main, so the build +downloads what the cache holds and builds only what it lacks. Without a +substituter it fetches the pinned toolchain packages and builds the toolchain +before Hello. -- **Parser** (`Nix.Parser`): a hand-written recursive-descent parser for the - Nix language. -- **Evaluator** (`Nix.Eval`): the AST compiles to a small bytecode that a lazy - evaluator runs, memoizing thunks and detecting infinite recursion. The - evaluator is generic over `MonadEval`, with a pure instance for tests and an - IO instance for real evaluation. `derivation` is a lazy wrapper over the - strict `derivationStrict` primop, as in upstream's - `src/libexpr/primops/derivation.nix`, so referring to a package does not - force its build closure. -- **Data layer** (`cbits/`): attribute sets, lists, thunks, environments, - symbols, context strings, lambdas and bytecode are C99 structures outside - the GHC heap, freed together when an evaluation session ends. Haskell calls - into C, and C never calls back. -- **Store** (`Nix.Store`): a store at `/nix/store`, or `C:\nix\store` on - Windows, with SQLite metadata, reference scanning and per-path locks. -- **Builder** (`Nix.Builder`): orders derivations by their dependencies, - substitutes each one a cache holds, and runs the rest in a scrubbed - environment. -- **Substituter** (`Nix.Substituter`): the HTTP binary-cache protocol, with - Ed25519 signature checks and xz, zstd and bzip2 decompression, built on - [nova-cache](https://github.com/Novavero-AI/nova-cache). +## On Windows -On Windows, derivations keep the canonical `/nix/store` spelling that hashes -are computed over, and it is mapped to the real store directory only when a -builder is started. NTFS has no executable bit, so nova-nix keeps it in an +The store is `C:\nix\store` by default. Derivations keep the `/nix/store` +spelling that hashes are computed over, and it is mapped to the real directory +only when a builder starts. A file's executable bit is kept in an NTFS alternate data stream. A store path therefore serializes to the same NAR, with the same hash, as it does on other platforms. -## Library - -```haskell -{-# LANGUAGE OverloadedStrings #-} - -import Control.Exception (bracket_) -import Nix.Builtins (builtinEnv) -import Nix.Eval (eval, runPureEval) -import Nix.Eval.Arena (arenaDestroy, arenaInit) -import Nix.Eval.Policy (unrestrictedPolicy) -import Nix.Parser (parseNix) +A path with a root but no drive, such as `/src/default.nix`, names that path on +the store's drive, whichever drive is current: `C:` for the default store, or +the drive of the directory `--store` names. -main :: IO () -main = bracket_ arenaInit arenaDestroy $ - -- The first argument is what relative path literals resolve against. - case parseNix "/tmp" "" "let x = 5; in x * 2 + 1" of - Left err -> print err - Right expr -> print (runPureEval (eval (builtinEnv unrestrictedPolicy 0 []) expr)) -``` +## Library -This prints `Right (VInt 11)`. Evaluation needs the C data layer, so it must -run between `arenaInit` and `arenaDestroy`. +nova-nix is also a Haskell library, documented on +[Hackage](https://hackage.haskell.org/package/nova-nix). `Nix.Parser` parses, +`Nix.Eval` evaluates, and `Nix.Store`, `Nix.Builder`, `Nix.Realise` and +`Nix.Substituter` keep the store, build and substitute. Evaluation needs the C +data layer, so it runs between `arenaInit` and `arenaDestroy`, as +`Nix.Eval.Arena` describes. ## Building from source -Tested with GHC 9.14.1. CI uses the latest cabal-install release. You only -need this to work on nova-nix itself, not to use a release. +You need this only to work on nova-nix itself, not to use a release. It needs +GHC and cabal-install; `tested-with` in `nova-nix.cabal` names the GHC version +CI uses. ```bash git clone https://github.com/Novavero-AI/nova-nix.git @@ -220,7 +163,7 @@ ## Contributing -See [CONTRIBUTING.md](CONTRIBUTING.md). Planned work is on the +See [CONTRIBUTING.md]. Planned work is on the [Nova roadmap](https://github.com/orgs/Novavero-AI/projects/1) project. Please report security issues privately through [GitHub's vulnerability reporting](https://github.com/Novavero-AI/nova-nix/security/advisories/new) @@ -228,10 +171,19 @@ ## License -Apache-2.0. See [LICENSE](LICENSE) and [NOTICE](NOTICE). +Apache-2.0. See [LICENSE] and [NOTICE]. -[#25]: https://github.com/Novavero-AI/nova-nix/issues/25 +[`drvpath-cases.txt`]: https://github.com/Novavero-AI/nova-nix/blob/main/.github/parity/drvpath-cases.txt +[`eval-cases.sh`]: https://github.com/Novavero-AI/nova-nix/blob/main/.github/parity/eval-cases.sh +[`parity.yml`]: https://github.com/Novavero-AI/nova-nix/blob/main/.github/workflows/parity.yml +[`derivation-divergences.txt`]: https://github.com/Novavero-AI/nova-nix/blob/main/test/data/derivation-divergences.txt +[`pkgs/windows/bootstrap`]: https://github.com/Novavero-AI/nova-nix/tree/main/pkgs/windows/bootstrap +[stage0-pe32]: https://github.com/Novavero-AI/stage0-pe32 +[a Windows port]: https://github.com/Novavero-AI/mes +[nova-cache]: https://github.com/Novavero-AI/nova-cache +[CONTRIBUTING.md]: https://github.com/Novavero-AI/nova-nix/blob/main/CONTRIBUTING.md +[LICENSE]: https://github.com/Novavero-AI/nova-nix/blob/main/LICENSE +[NOTICE]: https://github.com/Novavero-AI/nova-nix/blob/main/NOTICE [#26]: https://github.com/Novavero-AI/nova-nix/issues/26 [#29]: https://github.com/Novavero-AI/nova-nix/issues/29 -[#307]: https://github.com/Novavero-AI/nova-nix/issues/307 -[#309]: https://github.com/Novavero-AI/nova-nix/issues/309 +[#194]: https://github.com/Novavero-AI/nova-nix/issues/194 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -6,13 +6,12 @@ -- The command and flag tables are deliberately not repeated here. -- 'usageLines' is the one place they live, and both @--help@ and the -- usage-error path print it, so the flag that adds itself to the parser --- documents itself in the same edit. A second copy in this header went --- nine flags and two commands stale before anyone noticed, because --- nothing renders it: Haddock builds library targets by default, and --- this module is in the executable stanza. +-- documents itself in the same edit. A copy here would go stale +-- unnoticed: Haddock builds library targets by default, and this module +-- is in the executable stanza, so nothing renders it. module Main (main) where -import Control.Exception (AsyncException (UserInterrupt), IOException, displayException, handleJust, try) +import Control.Exception (AsyncException (UserInterrupt), IOException, displayException, handle, handleJust, try) import Control.Monad (join, mfilter, void, (>=>)) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB @@ -42,10 +41,11 @@ import Nix.Expr.Resolve (undefinedVariableMessage) import Nix.Expr.Types (Expr) import Nix.HostPath (hostPathFromBytes, hostPathText) -import Nix.Parser (SourceError (..), parseNixWithScope, readFileAutoEncoding) +import Nix.Parser (SourceError (..), SourceOrigin (..), parseNixWithScope) import Nix.Push (PushCompression (..), PushConfig (..), PushSummary (..), isDerivationPath, loadApiKeyFile, outputPathsOnly, parsePushCompression, pushCompressionValues, pushPaths, storePathBasename) +import Nix.Realise (Fallback (..)) import Nix.Store (DeleteOutcome (..), GcRoot (..), LiveSet, Store (..), addOutLinkRoot, canonicalStoreDir, closeStore, collectGarbage, deleteStorePathChecked, findRoots, gcSummaryLine, materializeEvalSources, materializeEvalStoreWrites, openStore, queryAllValidPaths, resolveDeleteTarget, withLiveSet, writeDrv, writeDrvClosure) -import Nix.Store.Path (StoreDir (..), StorePath, defaultStoreDir, parseStorePath, parseStorePathBaseName, platformStoreDir, storePathToFilePath, storePathToText) +import Nix.Store.Path (StoreDir (..), StorePath, defaultStoreDir, parseStorePath, parseStorePathBaseName, platformStoreDir, qualifyPathText, storePathToFilePath, storePathToText) import Nix.Substituter (CacheConfig (..)) import Paths_nova_nix (getDataDir, version) import System.Directory (Permissions (executable), canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory, getPermissions, getTemporaryDirectory, makeAbsolute) @@ -55,7 +55,7 @@ import qualified System.File.OsPath as OsFile import System.FilePath (takeDirectory, takeFileName, ()) import System.IO (BufferMode (..), hPutStrLn, hSetBinaryMode, hSetBuffering, hSetEncoding, stderr, stdout, utf8) -import System.IO.Error (isDoesNotExistError) +import System.IO.Error (ioeGetErrorString, isDoesNotExistError, isUserError) import qualified System.Info as SI import System.OsPath (OsPath) import qualified System.OsPath as OP @@ -82,6 +82,10 @@ optRestrictEval :: !Bool, -- | @--pure-eval@: upstream's pure-eval, turned on for this run. optPureEval :: !Bool, + -- | @--trace-verbose@: upstream's trace-verbose, turned on for this run. + optTraceVerbose :: !Bool, + -- | @--fallback@: upstream's fallback, turned on for this run. + optFallback :: !Bool, optCommand :: !Command } @@ -138,7 +142,7 @@ -- silent drop: an unknown or typo'd flag once ended parsing and quietly -- discarded everything after it (e.g. a requested @--substituter@). parseArgs :: [String] -> Either String CliOpts -parseArgs = go (CliOpts [] False False Nothing Nothing Nothing [] False False CmdUsage) +parseArgs = go (CliOpts [] False False Nothing Nothing Nothing [] False False False False CmdUsage) where go opts [] = Right opts -- Answered before anything else is looked at, and the rest of the line @@ -164,6 +168,10 @@ go (opts {optRestrictEval = True}) rest go opts ("--pure-eval" : rest) = go (opts {optPureEval = True}) rest + go opts ("--trace-verbose" : rest) = + go (opts {optTraceVerbose = True}) rest + go opts ("--fallback" : rest) = + go (opts {optFallback = True}) rest go opts ("eval" : rest) = goEval opts rest go opts ("build" : rest) = goBuild opts emptyBuildArgs rest go opts ("push" : rest) = goPush opts emptyPushArgs rest @@ -186,6 +194,10 @@ goEval (opts {optRestrictEval = True}) rest goEval opts ("--pure-eval" : rest) = goEval (opts {optPureEval = True}) rest + goEval opts ("--trace-verbose" : rest) = + goEval (opts {optTraceVerbose = True}) rest + goEval opts ("--fallback" : rest) = + goEval (opts {optFallback = True}) rest goEval opts ("--expr" : expr : rest) = go (opts {optCommand = CmdEvalExpr (T.pack expr)}) rest goEval _ [flag] @@ -216,6 +228,10 @@ goBuild (opts {optRestrictEval = True}) buildArgs rest goBuild opts buildArgs ("--pure-eval" : rest) = goBuild (opts {optPureEval = True}) buildArgs rest + goBuild opts buildArgs ("--trace-verbose" : rest) = + goBuild (opts {optTraceVerbose = True}) buildArgs rest + goBuild opts buildArgs ("--fallback" : rest) = + goBuild (opts {optFallback = True}) buildArgs rest goBuild opts buildArgs ("--expr" : expr : rest) = withTarget opts buildArgs (TargetExpr (T.pack expr)) rest goBuild opts buildArgs (flag : path : rest) @@ -386,10 +402,13 @@ config <- loadNixConfig storeDir <- chosenStoreDir opts -- SIGINT reaches the main thread as UserInterrupt, which uncaught ends - -- the process by the signal with nothing said. Upstream's checkInterrupt - -- throws Interrupted, a BaseError its handleExceptions logs and exits 1 - -- with (libmain/shared.cc at 2.24.9). - handleJust userInterrupt (const reportInterrupt) $ case optCommand opts of + -- the process by the signal with nothing said, and an I/O failure no + -- command handles reaches GHC's default handler, which prints an + -- "Uncaught exception" report with a backtrace. Upstream's + -- handleExceptions logs either as one error line and exits 1 + -- (libmain/shared.cc at 2.24.9): checkInterrupt throws Interrupted, a + -- BaseError like any other failure. + handleJust userInterrupt (const reportInterrupt) . handle reportIOFailure $ case optCommand opts of CmdEvalFile filePath -> evalFile config opts storeDir dataDir filePath CmdEvalExpr expr | optAterm opts -> evalExprAterm config opts storeDir dataDir expr @@ -413,6 +432,21 @@ hPutStrLn stderr "error: interrupted by the user" exitWith (ExitFailure 1) +-- | An I/O failure no command handled, reported as upstream reports an +-- error: @error: @ and the message, then exit status 1. +reportIOFailure :: IOException -> IO a +reportIOFailure failure = do + hPutStrLn stderr ("error: " <> ioFailureMessage failure) + exitWith (ExitFailure 1) + +-- | A 'userError' is its message alone, which 'show' would wrap in +-- @user error (...)@; any other 'IOException' also names the operation +-- and the file that failed. +ioFailureMessage :: IOException -> String +ioFailureMessage failure + | isUserError failure = ioeGetErrorString failure + | otherwise = displayException failure + -- | What @--version@ reports. Cabal's version, which is the one the publish -- workflow's tag guard checks a tag against, so a downloaded binary names -- exactly the release it came from and a bug report can say which build. @@ -450,18 +484,21 @@ " --store DIR Use DIR as the store (default: the platform store)", " --substituter URL Try this binary cache before building", " --trusted-key K Public key (name:base64) for the substituter", + " --fallback Build from source if substitution fails", " --restrict-eval Confine reads to the search path roots and what the", " evaluation itself writes; fetch only allowed-uris", " --pure-eval Confine reads as --restrict-eval does, with no search", " path, no currentTime, currentSystem or storePath, and", " pinned fetches only (allowed-uris applies only under", " --restrict-eval)", + " --trace-verbose Make builtins.traceVerbose behave as builtins.trace;", + " without it, the first argument is never forced", "", - " substituters, trusted-public-keys, max-call-depth, restrict-eval,", - " pure-eval and allowed-uris also read from nix.conf, in upstream's", - " order: $NIX_CONF_DIR (default " <> systemConfDirName <> "), the XDG", - " nix/nix.conf files or $NIX_USER_CONF_FILES, then $NIX_CONFIG; the", - " flags above add to whatever those configure.", + " substituters, trusted-public-keys, fallback, max-call-depth,", + " restrict-eval, pure-eval, allowed-uris and trace-verbose also read from", + " nix.conf, in upstream's order: $NIX_CONF_DIR (default " <> systemConfDirName <> "),", + " the XDG nix/nix.conf files or $NIX_USER_CONF_FILES, then $NIX_CONFIG;", + " the flags above add to whatever those configure.", "", " --help Print this text and exit", " --version Print the version and exit" @@ -474,32 +511,33 @@ -- a directory, no permission) is a clean CLI error, never an uncaught -- exception. Only 'IOException' is caught: an interrupt or any other -- async exception must abort the run, not print as a read failure. -readSourceFile :: FilePath -> IO (FilePath, T.Text) +readSourceFile :: FilePath -> IO (FilePath, BS.ByteString) readSourceFile rawPath = do attempt <- try $ do path <- canonicalizePath rawPath - source <- readFileAutoEncoding path + source <- BS.readFile path pure (path, source) case attempt of Left (e :: IOException) -> failWith ("cannot read " <> T.pack rawPath <> ": " <> T.pack (displayException e)) Right ok -> pure ok --- | What a parse error names when the source came from @--expr@ and there is --- no file to point at. -exprSourceName :: T.Text -exprSourceName = "" +-- | Where @--expr@ source comes from: text with no file to point at, which +-- its parse errors name @@ and its positions name no file. +exprOrigin :: SourceOrigin +exprOrigin = SourceText "" -- | The evaluation policy for this run: the config cascade's settings, --- with either flag turning its mode on. A flag only turns a mode on, so --- a machine configured for pure evaluation stays that way whatever the +-- with each flag turning its setting on. A flag only turns a setting on, +-- so a machine configured for pure evaluation stays that way whatever the -- command line says, which is the direction a confinement should fail in. evalPolicyFor :: CliOpts -> NixConfig -> EvalPolicy evalPolicyFor opts config = EvalPolicy { epRestrictEval = optRestrictEval opts || ncRestrictEval config, epPureEval = optPureEval opts || ncPureEval config, - epAllowedUris = ncAllowedUris config + epAllowedUris = ncAllowedUris config, + epTraceVerbose = optTraceVerbose opts || ncTraceVerbose config } -- | The evaluation state and root environment for one command. Upstream's @@ -533,8 +571,10 @@ esCallDepth = topLevelCallDepth (ncMaxCallDepth config) } -- A relative root resolves against the working directory, as upstream's - -- absPath does. A pseudo-URL entry (channel:, flake:, a listed scheme) - -- names a download this evaluator never performs and allows nothing: + -- absPath does, and a rooted one with no drive lands on the store's + -- drive, where its lookups read ('qualifyPathText'). A pseudo-URL + -- entry (channel:, flake:, a listed scheme) names a download this + -- evaluator never performs and allows nothing: -- upstream allows such an entry's working-directory spelling only by -- falling through after a failed download (resolveLookupPathPath), and -- a run that cannot fetch should not widen what it may read. A root @@ -546,20 +586,20 @@ where textRoot = either (const Nothing) Just . TE.decodeUtf8' rootSpellings root = do - given <- makeAbsolute (T.unpack root) + given <- makeAbsolute (T.unpack (qualifyPathText storeDir root)) resolved <- canonicalizePath given pure (map (canonPathValue . T.pack) [given, resolved]) -- | Parse and bind source against the names the root environment -- 'setUpEval' builds will bind, which depend on the policy. -parseForEval :: CliOpts -> NixConfig -> FilePath -> T.Text -> T.Text -> Either SourceError Expr +parseForEval :: CliOpts -> NixConfig -> FilePath -> SourceOrigin -> BS.ByteString -> Either SourceError Expr parseForEval opts config = parseNixWithScope (rootScopeNames (evalPolicyFor opts config)) -- | Evaluate a .nix file and print the result. evalFile :: NixConfig -> CliOpts -> StoreDir -> FilePath -> FilePath -> IO () evalFile config opts storeDir dataDir rawFilePath = do (filePath, source) <- readSourceFile rawFilePath - case parseForEval opts config (takeDirectory filePath) (T.pack filePath) source of + case parseForEval opts config (takeDirectory filePath) (SourceFile (T.pack filePath)) source of Left err -> failSource err Right expr -> do (st, env) <- setUpEval opts config storeDir dataDir (takeDirectory filePath) @@ -574,7 +614,7 @@ evalExpr :: NixConfig -> CliOpts -> StoreDir -> FilePath -> T.Text -> IO () evalExpr config opts storeDir dataDir source = do cwd <- getCurrentDirectory - case parseForEval opts config cwd exprSourceName source of + case parseForEval opts config cwd exprOrigin (TE.encodeUtf8 source) of Left err -> failSource err Right expr -> do (st, env) <- setUpEval opts config storeDir dataDir cwd @@ -590,7 +630,7 @@ evalExprAterm :: NixConfig -> CliOpts -> StoreDir -> FilePath -> T.Text -> IO () evalExprAterm config opts storeDir dataDir source = do cwd <- getCurrentDirectory - case parseForEval opts config cwd exprSourceName source of + case parseForEval opts config cwd exprOrigin (TE.encodeUtf8 source) of Left err -> failSource err Right expr -> do (st, env) <- setUpEval opts config storeDir dataDir cwd @@ -615,13 +655,13 @@ -- The file argument is canonicalized for the same reason as in 'evalFile'. -- | Where a build reads its expression, and the directory relative paths -- inside it resolve against. -loadBuildSource :: BuildTarget -> IO (FilePath, T.Text, T.Text) +loadBuildSource :: BuildTarget -> IO (FilePath, SourceOrigin, BS.ByteString) loadBuildSource (TargetFile rawFilePath) = do (filePath, source) <- readSourceFile rawFilePath - pure (takeDirectory filePath, T.pack filePath, source) + pure (takeDirectory filePath, SourceFile (T.pack filePath), source) loadBuildSource (TargetExpr source) = do cwd <- getCurrentDirectory - pure (cwd, exprSourceName, source) + pure (cwd, exprOrigin, TE.encodeUtf8 source) -- | Force the attributes 'derivationPath' goes on to read. @derivation@ -- is a lazy wrapper, and 'readThunkValue' answers 'Nothing' for a thunk that @@ -645,8 +685,8 @@ buildCommand config opts storeDir dataDir target attrPath outLink = do let caches = resolveCaches config (optSubstituter opts) (optTrustedKey opts) wrappers <- either failWith pure (execWrapperConfig (optExecWrappers opts)) >>= checkExecWrappers - (baseDir, sourceName, source) <- loadBuildSource target - case parseForEval opts config baseDir sourceName source of + (baseDir, origin, source) <- loadBuildSource target + case parseForEval opts config baseDir origin source of Left err -> failSource err Right expr -> do (st, env) <- setUpEval opts config storeDir dataDir baseDir @@ -689,7 +729,7 @@ -- builtins.toFile wrote these during evaluation but could not -- register them; a derivation naming one needs them valid first. materializeEvalStoreWrites store storeWrites - buildResult <- buildAndRegister store caches wrappers drvClosure drv drvSP + buildResult <- buildAndRegister store caches (fallbackFor opts config) wrappers drvClosure drv drvSP -- The root is registered before the handle closes: the handle's -- lease is what keeps a concurrent collection from running -- between the build's end and the link's creation. The path @@ -789,6 +829,13 @@ | url <- ncSubstituters config ] +-- | What a failed substitute leads to on this run. The flag only turns +-- fallback on, as upstream's does, so it adds to the config's setting. +fallbackFor :: CliOpts -> NixConfig -> Fallback +fallbackFor opts config + | optFallback opts || ncFallback config = BuildFromSource + | otherwise = NoFallback + -- | The caches from the resolved config plus the CLI flags. The CLI -- @--substituter@ and @--trusted-key@ append on top, the highest -- precedence, so a flag adds to the configured set rather than being @@ -954,8 +1001,8 @@ -- | Write the .drv file to the store and build with dependency resolution. -- The drvPath is the store path of the .drv file itself, extracted from -- the evaluation result alongside the Derivation struct. -buildAndRegister :: Store -> [CacheConfig] -> Map.Map T.Text FilePath -> Map.Map T.Text BS.ByteString -> Derivation -> StorePath -> IO BuildResult -buildAndRegister store caches wrappers drvClosure drv drvSP = do +buildAndRegister :: Store -> [CacheConfig] -> Fallback -> Map.Map T.Text FilePath -> Map.Map T.Text BS.ByteString -> Derivation -> StorePath -> IO BuildResult +buildAndRegister store caches fallback wrappers drvClosure drv drvSP = do -- Materialize the full input-.drv closure (every transitive dependency's -- recipe) to the store. buildWithDeps reads these back to construct the -- dependency graph; without them it cannot realize any non-leaf derivation. @@ -969,6 +1016,7 @@ (defaultBuildConfig (stDir store)) { bcTmpDir = tmpDir, bcCaches = caches, + bcFallback = fallback, bcExecWrappers = wrappers } buildWithDeps config store drv drvSP diff --git a/cbits/nn_attrset.c b/cbits/nn_attrset.c --- a/cbits/nn_attrset.c +++ b/cbits/nn_attrset.c @@ -1,17 +1,21 @@ /* * nn_attrset.c - Sorted symbol-keyed attribute set. * - * Two contiguous arrays: keys (nn_symbol_t) and values (void*), - * sorted by symbol ID after freeze. Binary search for lookup. + * Three parallel arrays: keys (nn_symbol_t), positions (uint32_t) and + * values (void*), sorted by symbol ID after freeze. Binary search for + * lookup. Keys and positions share one allocation, the keys first and + * the positions after `capacity` of them, so carrying a position costs + * no allocation of its own. * - * Memory layout after freeze (example with 4 entries): - * keys: [ 3, 7, 12, 45 ] (sorted symbol IDs) - * values: [ p0, p1, p2, p3 ] (parallel opaque pointers) + * Memory layout after freeze (example with 4 entries, capacity 4): + * keys: [ 3, 7, 12, 45 ] (sorted symbol IDs) + * positions: [ 9, 0, 13, 17 ] (parallel, in the same block) + * values: [ p0, p1, p2, p3 ] (parallel opaque pointers) * * This replaces Haskell's Map.Bin tree: * Map.Bin: ~48 bytes/node (constructor + key + value + size + left + right) - * nn_attrset: ~12 bytes/entry (4-byte key + 8-byte pointer) - * For 30k entries: 1.4 MB down to 360 KB (4x reduction, plus cache-friendly) + * nn_attrset: ~16 bytes/entry (4-byte key + 4-byte position + 8-byte pointer) + * For 30k entries: 1.4 MB down to 480 KB (3x reduction, plus cache-friendly) */ #include "nn_attrset.h" @@ -57,7 +61,8 @@ /* --- Internal representation --- */ struct nn_attrset { - nn_symbol_t *keys; + nn_symbol_t *keys; /* the shared block: capacity keys, then positions */ + uint32_t *positions; /* keys + capacity */ void **values; uint32_t count; /* entries used */ uint32_t capacity; /* entries allocated */ @@ -69,6 +74,7 @@ typedef struct { nn_symbol_t key; uint32_t idx; + uint32_t pos; void *value; } nn_tagged_entry_t; @@ -78,10 +84,18 @@ /* --- Helpers --- */ +/* Bytes of the block holding `capacity` keys and as many positions. */ +static size_t names_block_bytes(uint32_t capacity) +{ + return (size_t)capacity * (sizeof(nn_symbol_t) + sizeof(uint32_t)); +} + /* Double the capacity, stopping at NN_ATTRSET_MAX_ENTRIES; the doubling * is computed in uint64_t so it cannot wrap. Returns 0, or -1 with the * capacity unchanged when the set is at the ceiling or an allocation - * fails (an array that did grow is kept, only larger). */ + * fails. The values grow first: a values array that grew is kept, only + * larger, and the shared block, whose positions sit at the capacity, + * changes only once nothing else can fail. */ static int grow(nn_attrset_t *set) { if (set->capacity >= NN_ATTRSET_MAX_ENTRIES) return -1; @@ -89,16 +103,19 @@ uint32_t new_cap = doubled > NN_ATTRSET_MAX_ENTRIES ? NN_ATTRSET_MAX_ENTRIES : (uint32_t)doubled; - nn_symbol_t *new_keys = (nn_symbol_t *)realloc( - set->keys, (size_t)new_cap * sizeof(nn_symbol_t)); - if (!new_keys) return -1; - set->keys = new_keys; - void **new_values = (void **)realloc( set->values, (size_t)new_cap * sizeof(void *)); if (!new_values) return -1; set->values = new_values; + nn_symbol_t *new_keys = (nn_symbol_t *)realloc( + set->keys, names_block_bytes(new_cap)); + if (!new_keys) return -1; + memmove(new_keys + new_cap, new_keys + set->capacity, + (size_t)set->count * sizeof(uint32_t)); + set->keys = new_keys; + set->positions = new_keys + new_cap; + set->capacity = new_cap; return 0; } @@ -131,7 +148,8 @@ if (capacity == 0) capacity = 8; - set->keys = (nn_symbol_t *)malloc((size_t)capacity * sizeof(nn_symbol_t)); + set->keys = (nn_symbol_t *)malloc(names_block_bytes(capacity)); + set->positions = set->keys ? set->keys + capacity : NULL; set->values = (void **)malloc((size_t)capacity * sizeof(void *)); set->count = 0; set->capacity = capacity; @@ -156,10 +174,11 @@ /* --- Construction --- */ -int nn_attrset_insert(nn_attrset_t *set, nn_symbol_t key, void *value) +int nn_attrset_insert(nn_attrset_t *set, nn_symbol_t key, void *value, uint32_t pos) { if (set->count >= set->capacity && grow(set) != 0) return -1; set->keys[set->count] = key; + set->positions[set->count] = pos; set->values[set->count] = value; set->count++; return 0; @@ -187,14 +206,17 @@ uint32_t i, j; for (i = 1; i < set->count; i++) { nn_symbol_t tmpk = set->keys[i]; + uint32_t tmpp = set->positions[i]; void *tmpv = set->values[i]; j = i; while (j > 0 && set->keys[j - 1] > tmpk) { set->keys[j] = set->keys[j - 1]; + set->positions[j] = set->positions[j - 1]; set->values[j] = set->values[j - 1]; j--; } set->keys[j] = tmpk; + set->positions[j] = tmpp; set->values[j] = tmpv; } } else { @@ -209,14 +231,17 @@ * fails. Falls through to the dedup block below. */ for (uint32_t i = 1; i < set->count; i++) { nn_symbol_t key = set->keys[i]; + uint32_t pos = set->positions[i]; void *val = set->values[i]; uint32_t j = i; while (j > 0 && set->keys[j-1] > key) { set->keys[j] = set->keys[j-1]; + set->positions[j] = set->positions[j-1]; set->values[j] = set->values[j-1]; j--; } set->keys[j] = key; + set->positions[j] = pos; set->values[j] = val; } } else { @@ -224,6 +249,7 @@ for (i = 0; i < set->count; i++) { tagged[i].key = set->keys[i]; tagged[i].idx = i; + tagged[i].pos = set->positions[i]; tagged[i].value = set->values[i]; } @@ -232,6 +258,7 @@ for (i = 0; i < set->count; i++) { set->keys[i] = tagged[i].key; + set->positions[i] = tagged[i].pos; set->values[i] = tagged[i].value; } free(tagged); @@ -251,6 +278,7 @@ } if (write != read) { set->keys[write] = set->keys[read]; + set->positions[write] = set->positions[read]; set->values[write] = set->values[read]; } write++; @@ -293,6 +321,12 @@ return set->keys[idx]; } +uint32_t nn_attrset_get_pos(const nn_attrset_t *set, uint32_t idx) +{ + NN_ASSERT(idx < set->count, "nn_attrset_get_pos: idx out of bounds"); + return set->positions[idx]; +} + uint32_t nn_attrset_size(const nn_attrset_t *set) { return set->count; @@ -325,25 +359,25 @@ while (ia < a->count && ib < b->count) { int status; if (a->keys[ia] < b->keys[ib]) { - status = nn_attrset_insert(result, a->keys[ia], a->values[ia]); + status = nn_attrset_insert(result, a->keys[ia], a->values[ia], a->positions[ia]); ia++; } else if (a->keys[ia] > b->keys[ib]) { - status = nn_attrset_insert(result, b->keys[ib], b->values[ib]); + status = nn_attrset_insert(result, b->keys[ib], b->values[ib], b->positions[ib]); ib++; } else { - /* Same key - b wins (right-biased //). */ - status = nn_attrset_insert(result, b->keys[ib], b->values[ib]); + /* Same key - b wins (right-biased //), its position too. */ + status = nn_attrset_insert(result, b->keys[ib], b->values[ib], b->positions[ib]); ia++; ib++; } if (status != 0) return NULL; } while (ia < a->count) { - if (nn_attrset_insert(result, a->keys[ia], a->values[ia]) != 0) return NULL; + if (nn_attrset_insert(result, a->keys[ia], a->values[ia], a->positions[ia]) != 0) return NULL; ia++; } while (ib < b->count) { - if (nn_attrset_insert(result, b->keys[ib], b->values[ib]) != 0) return NULL; + if (nn_attrset_insert(result, b->keys[ib], b->values[ib], b->positions[ib]) != 0) return NULL; ib++; } @@ -372,7 +406,7 @@ break; } } - if (!skip && nn_attrset_insert(result, set->keys[i], set->values[i]) != 0) { + if (!skip && nn_attrset_insert(result, set->keys[i], set->values[i], set->positions[i]) != 0) { return NULL; } } diff --git a/cbits/nn_attrset.h b/cbits/nn_attrset.h --- a/cbits/nn_attrset.h +++ b/cbits/nn_attrset.h @@ -2,8 +2,9 @@ * nn_attrset.h - Sorted symbol-keyed attribute set for nova-nix. * * Replaces Haskell's Data.Map.Strict (48 bytes per Bin node, pointer- - * chasing balanced tree) with a contiguous sorted array of (symbol, slot) - * pairs. Binary search for O(log n) lookup; linear scan for iteration. + * chasing balanced tree) with a contiguous sorted array of (symbol, + * position, slot) entries. Binary search for O(log n) lookup; linear + * scan for iteration. * * Construction is two-phase: * 1. nn_attrset_new(cap) + nn_attrset_insert() - append unsorted @@ -16,6 +17,12 @@ * Values are opaque void* - Haskell passes StablePtr Thunk. The C * side never dereferences them. * + * Each entry also carries the position it was defined at, an opaque + * uint32_t the evaluator assigns and resolves, as each attribute of + * upstream's Bindings carries a PosIdx (attr-set.hh at 2.24.9). + * Positions travel with their entries through freeze, union and key + * removal. + * * Lifecycle: arena-managed. Every set is tracked at creation and bulk-freed * by nn_attrset_free_all at evaluation teardown; nn_attrset_free is that * teardown's per-set primitive and must not be called on a tracked set (it @@ -59,13 +66,13 @@ /* --- Construction (before freeze) --- */ -/* Append a key-value pair. Keys need not be sorted or unique at this - * stage - duplicates are resolved at freeze time (last insert wins, - * matching Nix // merge semantics). +/* Append a key-value pair defined at `pos`. Keys need not be sorted or + * unique at this stage - duplicates are resolved at freeze time (last + * insert wins, position included, matching Nix // merge semantics). * Grows the internal arrays if capacity is exceeded. Returns 0, or -1 * with the set unchanged when it already holds NN_ATTRSET_MAX_ENTRIES * entries or cannot grow. */ -int nn_attrset_insert(nn_attrset_t *set, nn_symbol_t key, void *value); +int nn_attrset_insert(nn_attrset_t *set, nn_symbol_t key, void *value, uint32_t pos); /* Sort entries by symbol ID and deduplicate (last writer wins). * Must be called exactly once before any lookup/keys/values access. @@ -92,6 +99,9 @@ /* Return the key at a known index. */ nn_symbol_t nn_attrset_get_key(const nn_attrset_t *set, uint32_t idx); +/* Return the position of the entry at a known index. */ +uint32_t nn_attrset_get_pos(const nn_attrset_t *set, uint32_t idx); + /* --- Bulk access --- */ /* Number of entries (after freeze: unique keys). */ @@ -111,7 +121,8 @@ /* --- Set operations --- */ /* Create a new set that is the right-biased union of `a` and `b` - * (keys in `b` override `a`). Both inputs must be frozen. + * (keys in `b` override `a`, positions with them). Both inputs must be + * frozen. * The result is returned frozen and is arena-tracked (freed by * nn_attrset_free_all) - do NOT pass it to nn_attrset_free. Returns * NULL when the union would pass NN_ATTRSET_MAX_ENTRIES or an diff --git a/cbits/nn_bytecode.h b/cbits/nn_bytecode.h --- a/cbits/nn_bytecode.h +++ b/cbits/nn_bytecode.h @@ -7,7 +7,8 @@ * referenced by their index in the instruction array (post-order * traversal guarantees children < parent). Variable-length data * (string parts, bindings, formals, capture info, attr paths) is - * stored in the data buffer, referenced by offset from instructions. + * stored in the data buffer, referenced by offset from instructions, + * and so are the source positions bindings refer to. * * Goal: eliminate StablePtr (Expr, Env) in pending thunks. After * compilation, pending thunks hold (bc_idx, nn_env_t*) -- both diff --git a/nova-nix.cabal b/nova-nix.cabal --- a/nova-nix.cabal +++ b/nova-nix.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: nova-nix -version: 0.9.0.0 +version: 0.10.0.0 synopsis: Windows-native Nix implementation in Haskell and C99 description: An implementation of Nix for Windows, written in Haskell with a C99 @@ -9,12 +9,12 @@ derivation builder and binary-cache substituter, and does not need an existing Nix installation. - On the 22 derivations its CI checks, over pinned pairs of Nix and - nixpkgs from 2.24.9 with nixpkgs 24.11 to 2.35.4 with nixpkgs unstable, - the derivation paths it computes match upstream. On Windows it builds - packages from source through a stage-1 stdenv over a store-pinned - MinGW-w64 toolchain. The project is experimental; see the README for - what is not implemented yet. + On the derivations its CI checks, over pinned pairs of Nix and nixpkgs, + the derivation paths it computes match upstream's. On Windows it builds + packages from source through a stage-1 stdenv over prebuilt MinGW-w64 + and MSYS2 packages pinned by SHA-256, and builds GNU Mes from a + 1,623-byte seed. The project is experimental; see the README for what + is not implemented. Evaluation needs the C data layer, so library code must run it between @Nix.Eval.Arena.arenaInit@ and @Nix.Eval.Arena.arenaDestroy@. @@ -71,6 +71,7 @@ Nix.Eval.Operator Nix.Eval.Print Nix.Eval.SourceError + Nix.Eval.SourcePos Nix.Eval.StringInterp Nix.Eval.Symbol Nix.Eval.CAttrSet @@ -100,12 +101,14 @@ Nix.Derivation Nix.Derivation.StructuredAttrs Nix.Builder + Nix.Builder.Log Nix.Builder.Unpack Nix.Compression Nix.Config Nix.Environment Nix.HostPath Nix.Push + Nix.Realise Nix.Substituter Nix.Builtins Nix.Hash @@ -131,7 +134,7 @@ , ram >= 0.20 && < 1 , filelock >= 0.1.1 && < 0.2 , mtl >= 2.2 && < 2.4 - , nova-cache:{nova-cache, xz, zstandard, bzip2} >= 0.11.1.1 && < 0.12 + , nova-cache:{nova-cache, xz, zstandard, bzip2} >= 0.11.1.1 && < 0.13 , process >= 1.6 && < 1.7 , random >= 1.2 && < 1.4 , regex-tdfa >= 1.3 && < 1.4 @@ -139,12 +142,16 @@ , tar >= 0.7.1 && < 0.8 , text >= 2.0 && < 2.2 , time >= 1.9 && < 1.17 + -- 0.7 is the first whose Codec.Compression.GZip exports the + -- DecompressError a corrupt stream throws, which builtin:unpack catches. + , zlib >= 0.7 && < 0.8 , zstd >= 0.1 && < 0.2 -- Platform calls base cannot express: the exclusive create behind NAR - -- unpacking (Nix.Store.Exclusive), and reading the environment as - -- bytes on POSIX (Nix.Environment; getenv, as upstream reads it), where - -- Windows reads it through base's UTF-16 API. Win32 2.9 is the first + -- unpacking (Nix.Store.Exclusive), reading the environment as bytes on + -- POSIX (Nix.Environment; getenv, as upstream reads it), where Windows + -- reads it through base's UTF-16 API, and marking a builder's log pipe + -- close-on-exec on POSIX (Nix.Builder.Log). Win32 2.9 is the first -- whose hANDLEToHandle serves the native Windows I/O manager; unix 2.8 -- is the first whose openFd takes creat and cloexec in its flags. if os(windows) @@ -234,18 +241,20 @@ , async >= 2.2 && < 2.3 , bytestring >= 0.11 && < 0.13 , containers >= 0.6 && < 0.9 + , mtl >= 2.2 && < 2.4 , directory >= 1.3 && < 1.4 , filepath >= 1.4.100 && < 1.6 , http-client >= 0.7 && < 0.8 , http-types >= 0.12 && < 0.13 , network >= 3.2 && < 3.3 - , nova-cache:{nova-cache, zstandard} >= 0.11.1.1 && < 0.12 + , nova-cache:{nova-cache, zstandard} >= 0.11.1.1 && < 0.13 , nova-nix , process >= 1.6.12 && < 1.7 , QuickCheck >= 2.12.5 && < 2.19 , sqlite-simple >= 0.4 && < 0.5 , tar >= 0.7.1 && < 0.8 , text >= 2.0 && < 2.2 + , zlib >= 0.7 && < 0.8 , zstd >= 0.1 && < 0.2 source-repository head diff --git a/src/Nix/Builder.hs b/src/Nix/Builder.hs --- a/src/Nix/Builder.hs +++ b/src/Nix/Builder.hs @@ -23,7 +23,7 @@ -- The key difference is process creation. Upstream on Linux uses -- @fork\/exec@ with namespace isolation. nova-nix spawns builders through -- "System.Process", which reaches @CreateProcess@ on Windows with no POSIX --- layer, and does not sandbox them yet (#25). +-- layer, and runs them without filesystem or network isolation. -- -- The builder's process tree runs inside a Win32 job object with -- kill-on-job-close ('Proc.use_process_jobs'), so an interrupt or a @@ -38,17 +38,23 @@ BuildResult (..), buildDerivation, buildWithDeps, + substitutePaths, -- * Build configuration BuildConfig (..), defaultBuildConfig, -- * Pure pieces (exported for tests) + AttrsDelivery (..), + attrsDelivery, BuilderSpawn (..), buildPath, + closureUnder, execWrapperConfig, execWrapperFor, spawnFor, + ReferenceCycle (..), + orderByReferences, rewriteEnv, rewritePlaceholders, scrubAmbient, @@ -59,13 +65,13 @@ ) where -import Control.Exception (IOException, catch, catches, displayException, finally, onException, try) -import Control.Monad (filterM, unless, when) -import Control.Monad.Except (ExceptT (..), liftEither, runExceptT) +import Control.Exception (IOException, bracket, catch, catches, displayException, finally, onException, try) +import Control.Monad (filterM, foldM, unless, when) +import Control.Monad.Except (ExceptT (..), liftEither, runExceptT, throwError) +import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (first) import qualified Data.ByteString as BS import Data.Char (isAscii, isSpace, toLower, toUpper) -import Data.Either (fromRight) import Data.Foldable (for_) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.List (sort) @@ -73,7 +79,9 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, maybeToList) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -82,17 +90,19 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTPS import qualified Network.HTTP.Types.Status as HTTP +import Nix.Builder.Log (openLogPipe, streamBuildLog) import Nix.Builder.Unpack (UnpackLimits, builtinUnpackBuilder, defaultUnpackLimits, runBuiltinUnpack) -import Nix.DependencyGraph (DepGraph, TopoResult (..), buildDepGraph, topoSort) -import qualified Nix.DependencyGraph +import Nix.DependencyGraph (TopoResult (..), buildDepGraph, topoSort) import Nix.Derivation (Derivation (..), DerivationOutput (..), Platform, currentPlatform, extraPlatforms, fromATerm, platformToText) import Nix.Derivation.StructuredAttrs (decodeStructuredAttrs, renderAttrsJson, renderAttrsShell, stringsAttr, structuredAttrsKey, withOutputPlaceholders) -import Nix.Hash (IncrementalHash, bytesToHexText, hashFinalizeBytes, hashInitWithAlgo, hashPlaceholder, hashUpdateChunk, hexToBytes, makeStorePath, rawHashWithAlgo) +import Nix.Hash (IncrementalHash, bytesToHexText, hashFinalizeBytes, hashInitWithAlgo, hashPlaceholder, hashUpdateChunk, hexToBytes, makeStorePath, rawHashWithAlgo, sha256Digest) import Nix.Http (AttemptFailure (..), FetchRetryPolicy, attemptFailureMessage, catchSync, defaultFetchRetryPolicy, fetchStatusFailure, ioRetryEffects, retryTransient, transferFailureHandlers, withTransfer, withUserAgent) -import Nix.Store (PathLock, PathRegistration, Store (..), acquirePathLock, isValid, placeInStore, registerPaths, releasePathLock, scanReferences, scanTempReferences, volumeCaseHack) +import Nix.Realise (Fallback (..), FetchOutcome (..), RealiseEffects (..), Realised (..), SubstEffects (..), realise, realiseFailureMessage) +import Nix.Store (PathLock, PathRegistration, Store (..), acquirePathLock, isValid, placeInStore, queryReferences, registerPaths, releasePathLock, rewriteBytes, rewriteStoreHashes, scanReferences, volumeCaseHack) import qualified Nix.Store.ExecBit as ExecBit -import Nix.Store.Path (StoreDir (..), StorePath (spHash, spName), StorePathNameError, defaultStoreDir, defaultStoreDirText, storePathToFilePath, unStoreDir) -import Nix.Substituter (CacheConfig, SubstResult (..), trySubstituteWith) +import Nix.Store.Path (BadStorePath, StoreDir (..), StorePath (spHash, spName), defaultStoreDir, defaultStoreDirText, parseStorePath, storePathToFilePath, storePathToText, unStoreDir) +import Nix.Substituter (CacheConfig, SubstResult (..), queryReferencesWith, trySubstituteWith) +import qualified NovaCache.Base32 as Nix32 import qualified NovaCache.NAR as NAR import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesPathExist, removeDirectoryRecursive, removePathForcibly) import qualified System.Environment @@ -194,6 +204,23 @@ attrsJsonFileName = ".attrs.json" attrsShellFileName = ".attrs.sh" +-- | The attribute listing the attributes a derivation passes as files. +envPassAsFile :: Text +envPassAsFile = "passAsFile" + +-- | What upstream adds to an attribute's name to name the variable holding +-- the path of its file, and what it puts before the hash of that name to +-- name the file. +passedFileVarSuffix, passedFilePrefix :: Text +passedFileVarSuffix = "Path" +passedFilePrefix = ".attr-" + +-- | The bytes upstream's @tokenizeString@ splits a list attribute at by +-- default (@src\/libutil\/util.hh@ at 2.24.9). Not 'isSpace': a form feed, +-- a vertical tab or a non-ASCII space does not separate there. +tokenSeparators :: BS.ByteString +tokenSeparators = " \t\n\r" + -- | The fixed build timestamp handed to every builder: 1980-01-01 UTC. -- Determinism-aware tools (binutils @ld@ writes it into the PE header -- instead of the wall clock; gcc uses it for @__DATE__@\/@__TIME__@) @@ -215,6 +242,8 @@ bcTmpDir :: !FilePath, -- | Binary caches to try before building (checked in priority order). bcCaches :: ![CacheConfig], + -- | What a failed substitute leads to: upstream's @fallback@. + bcFallback :: !Fallback, -- | Extraction budget for @builtin:unpack@ builds. bcUnpackLimits :: !UnpackLimits, -- | How a download is retried: each URL of a @builtin:fetchurl@ @@ -229,7 +258,12 @@ -- derivation itself - and its store paths - stay identical to a native -- build's. A foreign system with no entry here is refused rather than -- spawned natively; see 'execWrapperFor'. - bcExecWrappers :: !(Map Text FilePath) + bcExecWrappers :: !(Map Text FilePath), + -- | Where a builder's output goes, a line at a time as each line + -- completes ("Nix.Builder.Log"). Upstream's default logger prints + -- every build-log line to standard error, which is where + -- 'defaultBuildConfig' points this. + bcBuildLog :: !System.IO.Handle } deriving (Eq, Show) @@ -243,9 +277,11 @@ then "C:\\Temp\\nova-nix-build" else "/tmp/nova-nix-build", bcCaches = [], + bcFallback = NoFallback, bcExecWrappers = Map.empty, bcUnpackLimits = defaultUnpackLimits, - bcFetchRetry = defaultFetchRetryPolicy + bcFetchRetry = defaultFetchRetryPolicy, + bcBuildLog = System.IO.stderr } -- | Result of a build attempt. @@ -260,29 +296,31 @@ -- Build loop -- --------------------------------------------------------------------------- --- | Build a derivation: run its builder and capture output. +-- | Build a derivation, given its @.drv@ path, which names it in a failure +-- as upstream's do: run its builder and capture output. -- -- 1. Validate all inputs exist in the store --- 2. Create temp build directory with output subdirs +-- 2. Create temp build directory -- 3. Set up environment from derivation + standard vars --- 4. Run the builder process --- 5. On success: scan references, move outputs to store, register +-- 4. Run the builder process, which writes each output at its store path +-- 5. On success: scan the outputs for references and register them, +-- failing on a reference cycle between them ('registerOutputs') -- 6. On failure: clean up and report error -- 7. Exception safety: synchronous exceptions convert to BuildFailure; -- asynchronous exceptions propagate ('catchSync') - an interrupt -- must abort the build, never be reported as a build failure. -buildDerivation :: BuildConfig -> Store -> Derivation -> IO BuildResult -buildDerivation config store drv = - buildDerivationInner config store drv +buildDerivation :: BuildConfig -> Store -> Derivation -> StorePath -> IO BuildResult +buildDerivation config store drv drvPath = + buildDerivationInner config store drv drvPath `catchSync` \err -> pure (BuildFailure ("build exception: " <> T.pack (show err)) 1) -- | Build under the outputs' path locks. A derivation another process -- finished while we waited for them is adopted rather than redone: -- rebuilding would delete a registered path out from under whoever is -- already using it, which is why substitution adopts a finished path too. -buildDerivationInner :: BuildConfig -> Store -> Derivation -> IO BuildResult -buildDerivationInner config store drv = - withOutputLocks config store drv (maybe (buildUnderLock config store drv) (pure . BuildSuccess)) +buildDerivationInner :: BuildConfig -> Store -> Derivation -> StorePath -> IO BuildResult +buildDerivationInner config store drv drvPath = + withOutputLocks config store drv (maybe (buildUnderLock config store drv drvPath) (pure . BuildSuccess)) -- | Hold every output's path lock for the whole build, and report -- whether the derivation was already finished by the time they were @@ -295,12 +333,12 @@ -- single tree, and each registered it as valid. Nothing failed; the -- registered output was simply not what either build produced. -- --- Outputs are locked in 'StorePath' order so two processes racing the --- same multi-output derivation request them in the same sequence. A +-- Outputs are locked in 'lockOrder', so two processes racing the same +-- multi-output derivation request them in the same sequence and neither +-- can hold a lock the other needs while waiting on one it holds. A -- build holds locks for its own outputs only - dependencies are -- resolved before 'buildDerivation' is called, never underneath it - so --- no process holds one lock while waiting on another, and there is no --- cycle to deadlock on. +-- that sequence is the only one there is to agree on. -- -- The validity re-check happens under the locks, not before them: -- checked earlier it would answer about a moment that has already @@ -312,19 +350,26 @@ lock <- acquirePathLock (bcStoreDir config) sp atomicModifyIORef' heldLocks (\locks -> (lock : locks, ())) ( do - mapM_ takeLock (sort (map doPath (drvOutputs drv))) + mapM_ takeLock (lockOrder (map doPath (drvOutputs drv))) finishedElsewhere <- allOutputsValid store drv act finishedElsewhere ) `finally` (readIORef heldLocks >>= mapM_ releasePathLock) +-- | The order a process takes more than one path lock in. Substitution +-- holds each lock until its batch registers, and a build until it finishes, +-- so both have to use this order: the blocking lock has no timeout, and two +-- processes taking the same paths in different orders would wait forever. +lockOrder :: [StorePath] -> [StorePath] +lockOrder = sort + -- | The derivation's first output path when EVERY output is already -- registered, otherwise 'Nothing'. -- -- Every output, never just the first: a partially valid multi-output -- derivation still has to build, and treating it as finished would leave -- the missing outputs missing. Both the lock-held re-check and the gate --- in 'resolveDep' ask this one question, so the two cannot disagree. +-- in 'realiseEffects' ask this one question, so the two cannot disagree. allOutputsValid :: Store -> Derivation -> IO (Maybe StorePath) allOutputsValid store drv = case map doPath (drvOutputs drv) of [] -> pure Nothing @@ -333,13 +378,15 @@ pure (if and validity then Just firstOutput else Nothing) -- | The build itself, with every output's lock already held. -buildUnderLock :: BuildConfig -> Store -> Derivation -> IO BuildResult -buildUnderLock config store drv = do - -- 1. Validate inputs (sources + input-derivation outputs) exist - inputsOk <- validateInputs config store drv - case inputsOk of +buildUnderLock :: BuildConfig -> Store -> Derivation -> StorePath -> IO BuildResult +buildUnderLock config store drv drvPath = do + -- 1. Validate inputs (sources + input-derivation outputs) exist, and + -- take their closure: what an output may reference besides the + -- derivation's own outputs. + inputs <- validateInputs config store drv >>= either (pure . Left) (inputClosure store) + case inputs of Left errMsg -> pure (BuildFailure errMsg 1) - Right () -> do + Right inputPaths -> do -- 2. Create temp build directory. The location is deterministic -- (computeBuildDir), so a crashed earlier run may have left stale -- contents that builtin:unpack would misread as an archive @@ -358,7 +405,7 @@ outputValidity <- mapM (isValid store . doPath) (drvOutputs drv) case traverse outputPlan (zip (drvOutputs drv) outputValidity) of Left nameErr -> pure (BuildFailure ("output name is not a store path name: " <> T.pack (show nameErr)) 1) - Right plans -> runPlannedBuild config store drv buildDir plans + Right plans -> runPlannedBuild config store drv drvPath inputPaths buildDir plans -- | Where the builder writes each output, and where that has to end up. -- @@ -380,7 +427,7 @@ } -- | Plan one output, given whether its final path is already valid. -outputPlan :: (DerivationOutput, Bool) -> Either StorePathNameError OutputPlan +outputPlan :: (DerivationOutput, Bool) -> Either BadStorePath OutputPlan outputPlan (out, valid) | not valid = Right (OutputPlan (doName out) (doPath out) (doPath out) False) | otherwise = do @@ -394,10 +441,11 @@ -- @src/libstore/unix/build/local-derivation-goal.cc@ at 2.24.9) with the -- same shape: a bogus @rewrite:@ path type and an all-zeroes inner hash, -- keyed on the output path it stands in for. --- Upstream also keys on the @.drv@ path; that is not reachable here, and --- the output path already names one output of one derivation, so the --- result is just as unique. -fallbackOutputPath :: StorePath -> Either StorePathNameError StorePath +-- Upstream's type string also names the @.drv@ path +-- (@rewrite:\:\@), so the scratch path a builder sees differs +-- from upstream's. The output path already names one output of one +-- derivation, so the result is just as unique. +fallbackOutputPath :: StorePath -> Either BadStorePath StorePath fallbackOutputPath sp = makeStorePath defaultStoreDir @@ -467,9 +515,9 @@ system = platformToText platform -- | The build, once every output knows where it is written and where it --- belongs. -runPlannedBuild :: BuildConfig -> Store -> Derivation -> FilePath -> [OutputPlan] -> IO BuildResult -runPlannedBuild config store drv buildDir plans = do +-- belongs, and the closure of the inputs is known. +runPlannedBuild :: BuildConfig -> Store -> Derivation -> StorePath -> Set StorePath -> FilePath -> [OutputPlan] -> IO BuildResult +runPlannedBuild config store drv drvPath inputPaths buildDir plans = do let scratchDir p = storePathToFilePath (bcStoreDir config) (opScratch p) outputDirs = [(opName p, scratchDir p) | p <- plans] -- Every scratch path is the build's to use: the ones that are final @@ -491,31 +539,32 @@ -- 4. Decode builder/args/env for the spawn boundary. Derivation -- strings are BYTES (identity); spawning a process needs real -- text, so invalid UTF-8 in any of them is a clean build - -- failure, never a mojibake spawn. The builtin builders skip - -- this - they read the byte fields directly. + -- failure, never a mojibake spawn. An attribute that reaches + -- the builder as a file stays bytes ('attrsDelivery'). The + -- builtin builders skip this - they read the byte fields + -- directly. exitResult <- case drvBuilder drv of b - | b == builtinFetchurlBuilder -> runBuiltinFetchurl (bcFetchRetry config) drv outputDirs - | b == builtinUnpackBuilder -> runBuiltinUnpack (bcStoreDir config) (bcUnpackLimits config) drv outputDirs + | b == builtinFetchurlBuilder -> first (uncurry BuilderRefused) <$> runBuiltinFetchurl (bcFetchRetry config) drv outputDirs + | b == builtinUnpackBuilder -> first (uncurry BuilderRefused) <$> runBuiltinUnpack (bcStoreDir config) (bcUnpackLimits config) drv outputDirs _ -> case (execWrapperFor config drv, decodeBuilderStrings drv) of (SpawnUnsupported system, _) -> pure ( Left - ( 1, - "no way to run a " - <> system - <> " builder on this machine; pass --exec-wrapper " - <> system - <> "=PATH to name a launcher for it" + ( BuilderRefused + 1 + ( "no way to run a " + <> system + <> " builder on this machine; pass --exec-wrapper " + <> system + <> "=PATH to name a launcher for it" + ) ) ) - (_, Left errMsg) -> pure (Left (1, errMsg)) - (spawn, Right (builderText, argTexts, decodedEnv)) -> - let -- onStore first, so nothing a placeholder expands to gets - -- rewritten a second time. - rewrite = rewritePlaceholders outputDirs . onStore config - builderPath = T.unpack (onStore config builderText) - builderArgs = map (T.unpack . rewrite) argTexts + (_, Left errMsg) -> pure (Left (BuilderRefused 1 errMsg)) + (spawn, Right (builderText, argTexts)) -> + let builderPath = T.unpack (onStore config builderText) + builderArgs = map (T.unpack . buildRewrite config outputDirs) argTexts -- Env still names the real builder - a launcher only -- changes what's spawned, not what the derivation says. (spawnPath, spawnArgs) = case spawn of @@ -529,21 +578,21 @@ impureVars delivery | any carriesHash (drvOutputs drv) = adImpureEnvVars delivery | otherwise = Right [] - in case attrsDelivery rewrite buildDir outputDirs decodedEnv of - Left err -> pure (Left (1, "cannot process " <> structuredAttrsKey <> " attribute of '" <> formatDrvName drv <> "': " <> err)) + in case attrsDelivery config drv buildDir outputDirs of + Left err -> pure (Left (BuilderRefused 1 err)) Right delivery -> case impureVars delivery of - Left err -> pure (Left (1, err)) + Left err -> pure (Left (BuilderRefused 1 err)) Right passed -> do for_ (adFiles delivery) (uncurry BS.writeFile) -- 5. Run the builder - runBuilder spawnPath spawnArgs (buildEnvironment config (adEnv delivery) builderPath buildDir) passed buildDir + runBuilder (bcBuildLog config) spawnPath spawnArgs (buildEnvironment config (adEnv delivery) builderPath buildDir) passed buildDir case exitResult of - Left (exitCode, stderrText) -> do + Left failure -> do -- Whatever the builder wrote is in the store now, so failure has -- to take it back out: an unregistered tree there is invisible to -- the database and would only confuse the next run. clearScratch - pure (BuildFailure ("builder failed: " <> stderrText) exitCode) + pure (builderFailureResult failure) Right () -> do -- 6. Success: validate that the builder created all expected -- outputs. Outputs may be files or directories - both are @@ -559,7 +608,7 @@ clearScratch pure (BuildFailure ("builder succeeded but outputs missing: " <> names) 1) [] -> do - result <- registerOutputs config store drv buildDir plans + result <- registerOutputs config store drv drvPath inputPaths plans case result of BuildSuccess _ -> do writeIORef committed True @@ -572,23 +621,46 @@ ) `onException` cleanupUnlessCommitted --- | Decode a derivation's builder path, arguments, and env values from --- their identity bytes to the 'Text' the process-spawn boundary needs. --- @Left@ names the offending field. -decodeBuilderStrings :: Derivation -> Either Text (Text, [Text], Map Text Text) +-- | Why the builder step of a build failed, with the exit code the +-- build reports. +data BuilderFailure + = -- | The builder ran and exited unsuccessfully. What it wrote is + -- already in the build log, which upstream's default logger does not + -- repeat in the failure: it shows the log's last lines there only + -- when it has not been printing them (@log-lines@, derivation-goal.cc + -- at 2.24.9). + BuilderExited !Int + | -- | The builder did not run, or a builtin builder refused, for the + -- reason given. + BuilderRefused !Int !Text + +-- | The build result a failed builder step reports. +builderFailureResult :: BuilderFailure -> BuildResult +builderFailureResult failure = case failure of + BuilderExited code -> BuildFailure "builder failed" code + BuilderRefused code reason -> BuildFailure ("builder failed: " <> reason) code + +-- | Decode a derivation's builder path and arguments from their identity +-- bytes to the 'Text' the process-spawn boundary needs. @Left@ names the +-- offending field. The environment is decoded where 'attrsDelivery' +-- decides what of it reaches the builder as variables. +decodeBuilderStrings :: Derivation -> Either Text (Text, [Text]) decodeBuilderStrings drv = do - builderText <- decodeField "the builder path" (drvBuilder drv) - argTexts <- traverse (decodeField "a builder argument") (drvArgs drv) - envTexts <- - Map.traverseWithKey - (\key val -> decodeField ("environment variable '" <> key <> "'") val) - (drvEnv drv) - pure (builderText, argTexts, envTexts) - where - decodeField what bytes = case TE.decodeUtf8' bytes of - Right t -> Right t - Left _ -> Left ("cannot spawn builder: " <> what <> " contains invalid UTF-8") + builderText <- decodeSpawnField "the builder path" (drvBuilder drv) + argTexts <- traverse (decodeSpawnField "a builder argument") (drvArgs drv) + pure (builderText, argTexts) +-- | Decode one derivation string for the spawn, @what@ naming it in the +-- failure. +decodeSpawnField :: Text -> BS.ByteString -> Either Text Text +decodeSpawnField what bytes = case TE.decodeUtf8' bytes of + Right t -> Right t + Left _ -> Left ("cannot spawn builder: " <> what <> " contains invalid UTF-8") + +-- | 'decodeSpawnField' for an environment variable. +decodeVariable :: Text -> BS.ByteString -> Either Text Text +decodeVariable name = decodeSpawnField ("environment variable '" <> name <> "'") + -- --------------------------------------------------------------------------- -- Input validation -- --------------------------------------------------------------------------- @@ -597,21 +669,27 @@ -- canonical @\/nix\/store@ spelling) to where this machine actually keeps -- them, at the spawn boundary. A no-op when the two coincide. onStore :: BuildConfig -> Text -> Text -onStore config - | storeDirText == defaultStoreDirText = id - | otherwise = T.replace (defaultStoreDirText <> "/") (storeDirText <> "/") +onStore config = maybe id (uncurry T.replace) (storeRewrite config) + +-- | The replacement 'onStore' makes, when the two spellings differ. +storeRewrite :: BuildConfig -> Maybe (Text, Text) +storeRewrite config + | storeDirText == defaultStoreDirText = Nothing + | otherwise = Just (defaultStoreDirText <> "/", storeDirText <> "/") where storeDirText = T.pack (unStoreDir (bcStoreDir config)) --- | Check that all inputs needed to build a derivation are present in the store. +-- | Check that all inputs needed to build a derivation are present in the +-- store, and return them: the input sources, then the input derivations' +-- requested outputs. -- -- Input sources must be valid. For input derivations, the artifacts a build -- actually reads are their realized OUTPUT paths, not the @.drv@ recipe files, -- so we resolve each requested output (by reading the input @.drv@ the build --- driver materialized) and validate those outputs. Dependencies are realized --- in topological order, so a dependency's outputs are present by the time a --- dependent is validated. -validateInputs :: BuildConfig -> Store -> Derivation -> IO (Either Text ()) +-- driver materialized) and validate those outputs. "Nix.Realise" realizes a +-- derivation's inputs before it builds, so their outputs are present by the +-- time it is validated. +validateInputs :: BuildConfig -> Store -> Derivation -> IO (Either Text [StorePath]) validateInputs config store drv = do -- Check input sources srcResults <- mapM (isValid store) (drvInputSrcs drv) @@ -627,7 +705,7 @@ let missingOutputs = [sp | (sp, valid) <- zip requiredOutputs outResults, not valid] if not (null missingOutputs) then pure (Left ("missing input derivation outputs: " <> T.intercalate ", " (map formatSP missingOutputs))) - else pure (Right ()) + else pure (Right (drvInputSrcs drv ++ requiredOutputs)) -- | Resolve each input derivation's requested output names to their store -- paths by reading the input @.drv@ from the store. @Left@ if an input @.drv@ @@ -646,6 +724,40 @@ Nothing -> Left ("input derivation " <> formatSP inputDrvPath <> " has no output '" <> name <> "'") +-- | The closure of a build's inputs under the references the store records: +-- the paths besides its own outputs that an output may reference. This is +-- upstream's @inputPaths@, the closures of the requested input outputs and +-- of the input sources (derivation-goal.cc:601-613 at 2.24.9). An output +-- that embeds a dependency of a dependency must record it, or a collection +-- deletes it while the output still uses it. As in upstream's, an input +-- derivation's @.drv@ is in it only when an input source reaches it. +-- +-- A recorded reference that does not parse is a corrupt database, and fails +-- the build rather than dropping out of the scan. +inputClosure :: Store -> [StorePath] -> IO (Either Text (Set StorePath)) +inputClosure store = runExceptT . closureUnder recorded + where + recorded :: StorePath -> ExceptT Text IO [StorePath] + recorded sp = do + referenceTexts <- liftIO (queryReferences (stDB store) sp) + liftEither (traverse parseRecorded referenceTexts) + parseRecorded text = case parseStorePath (stDir store) text of + Just sp -> Right sp + Nothing -> Left ("unparseable reference in store DB: " <> text) + +-- | Every node reachable from the roots through the references lookup, the +-- roots included. Each node is looked up once, so a reference cycle (the +-- outputs of one derivation may reference each other) ends. +closureUnder :: (Monad m, Ord a) => (a -> m [a]) -> [a] -> m (Set a) +closureUnder references = go Set.empty + where + go !seen [] = pure seen + go !seen (node : pending) + | Set.member node seen = go seen pending + | otherwise = do + referenced <- references node + go (Set.insert node seen) (referenced ++ pending) + -- | Format a StorePath for error messages. formatSP :: StorePath -> Text formatSP sp = spHash sp <> "-" <> spName sp @@ -682,10 +794,31 @@ -- only @drv->args@ (local-derivation-goal.cc:2170,2176). rewritePlaceholders :: [(Text, FilePath)] -> Text -> Text rewritePlaceholders outputDirs value = - foldr substitute value outputDirs - where - substitute (name, path) = T.replace (hashPlaceholder name) (T.pack path) + foldr (uncurry T.replace) value (placeholderRewrites outputDirs) +-- | The replacements 'rewritePlaceholders' makes, one per output. +placeholderRewrites :: [(Text, FilePath)] -> [(Text, Text)] +placeholderRewrites outputDirs = [(hashPlaceholder name, T.pack path) | (name, path) <- outputDirs] + +-- | The build's rewrite of a derivation string: store paths to where this +-- machine keeps them, then each output's placeholder to its build-time +-- path. 'onStore' goes first, so nothing a placeholder expands to is +-- rewritten a second time. +buildRewrite :: BuildConfig -> [(Text, FilePath)] -> Text -> Text +buildRewrite config outputDirs = rewritePlaceholders outputDirs . onStore config + +-- | 'buildRewrite' over bytes, for an attribute that reaches the builder +-- as a file and so need not be text. The replacements go in the order +-- 'buildRewrite' makes them ('rewritePlaceholders' folds from the right), +-- and on UTF-8 the two agree: an encoded needle matches only at a +-- character boundary. +buildRewriteBytes :: BuildConfig -> [(Text, FilePath)] -> BS.ByteString -> BS.ByteString +buildRewriteBytes config outputDirs = + rewriteBytes + [ (TE.encodeUtf8 from, TE.encodeUtf8 to) + | (from, to) <- maybeToList (storeRewrite config) <> reverse (placeholderRewrites outputDirs) + ] + -- | Apply a build-time rewrite to an environment's names as well as its -- values. Upstream rewrites the whole @name=value@ string -- (local-derivation-goal.cc:2004), so a placeholder in a dynamic attribute @@ -707,6 +840,7 @@ -- derivation, so a malformed one fails only such a build, as upstream. adImpureEnvVars :: !(Either Text [Text]) } + deriving (Eq, Show) -- | How the derivation's attributes reach the builder: as environment -- variables, outputs included, or for a derivation carrying structured @@ -715,21 +849,38 @@ -- environment (upstream's @initTmpDir@ and @writeStructuredAttrs@, -- local-derivation-goal.cc at 2.24.9). -- --- @rewrite@ is the build's rewrite of store paths and placeholders. It --- applies to the shell file's text as upstream applies it, after --- rendering; the JSON file's strings take it before they are escaped, so --- a store directory holding backslashes still yields JSON. -attrsDelivery :: (Text -> Text) -> FilePath -> [(Text, FilePath)] -> Map Text Text -> Either Text AttrsDelivery -attrsDelivery rewrite buildDir outputDirs decodedEnv = case Map.lookup structuredAttrsKey decodedEnv of - Nothing -> +-- Without structured attributes, each attribute @passAsFile@ names +-- ('splitPassAsFile') is written to a file in the build directory instead, +-- holding the bytes its variable would have held, and @\Path@ +-- names the file. An attribute that is itself called @\Path@ +-- keeps its own value, as it does upstream, where it is assigned later. +-- The variable joins the build directory and the file name with the +-- platform's separator where upstream writes @\/@, so on Windows it is +-- spelled as @NIX_BUILD_TOP@ is. Structured attributes need no such +-- escape from the environment, and upstream ignores @passAsFile@ there. +-- +-- The build's rewrite ('buildRewrite') applies to the shell file's text +-- as upstream applies it, after rendering; the JSON file's strings take it +-- before they are escaped, so a store directory holding backslashes still +-- yields JSON. +attrsDelivery :: BuildConfig -> Derivation -> FilePath -> [(Text, FilePath)] -> Either Text AttrsDelivery +attrsDelivery config drv buildDir outputDirs = case Map.lookup structuredAttrsKey env of + Nothing -> do + let (variables, passed) = splitPassAsFile env + passedPath name = buildDir passedFileName name + pathVars = Map.fromList [(name <> passedFileVarSuffix, T.pack (passedPath name)) | name <- Map.keys passed] + decoded <- Map.traverseWithKey decodeVariable variables Right AttrsDelivery - { adEnv = unionEnvs [outputEnv, rewriteEnv rewrite decodedEnv], - adFiles = [], - adImpureEnvVars = Right (T.words (Map.findWithDefault "" envImpureEnvVars decodedEnv)) + { adEnv = unionEnvs [Map.withoutKeys outputEnv (Map.keysSet passed), rewriteEnv rewrite (unionEnvs [decoded, pathVars])], + adFiles = [(passedPath name, passedContents name value) | (name, value) <- Map.toList passed], + -- Read from the whole environment, as upstream's getStringsAttr + -- reads it, so passing the attribute as a file does not drop it. + adImpureEnvVars = T.words <$> decodeVariable envImpureEnvVars (Map.findWithDefault "" envImpureEnvVars env) } - Just encoded -> do - attrs <- decodeStructuredAttrs encoded + Just encodedBytes -> do + encoded <- decodeVariable structuredAttrsKey encodedBytes + attrs <- first (("cannot process " <> structuredAttrsKey <> " attribute of '" <> formatDrvName drv <> "': ") <>) (decodeStructuredAttrs encoded) let prepared = withOutputPlaceholders (map fst outputDirs) attrs jsonFile = buildDir attrsJsonFileName shellFile = buildDir attrsShellFileName @@ -743,8 +894,37 @@ adImpureEnvVars = fromMaybe [] <$> stringsAttr envImpureEnvVars attrs } where + env = drvEnv drv + rewrite = buildRewrite config outputDirs outputEnv = Map.fromList [(name, T.pack path) | (name, path) <- outputDirs] + -- An output's variable is the path it is written to, which is not + -- the derivation's value when that output is already valid, so its + -- file holds the same path. + passedContents name value = + maybe (buildRewriteBytes config outputDirs value) (TE.encodeUtf8 . T.pack) (lookup name outputDirs) +-- | Upstream's @passAsFile@: split off the attributes the @passAsFile@ +-- attribute names, as files rather than variables, leaving the rest. A +-- name with no attribute behind it is ignored, and @passAsFile@ itself +-- stays a variable unless it names itself. Names are compared as bytes, +-- as upstream compares them. +splitPassAsFile :: Map Text BS.ByteString -> (Map Text BS.ByteString, Map Text BS.ByteString) +splitPassAsFile env = (variables, passed) + where + named = Set.fromList (attrTokens (Map.findWithDefault "" envPassAsFile env)) + (passed, variables) = Map.partitionWithKey (\name _ -> Set.member (TE.encodeUtf8 name) named) env + +-- | Upstream's @tokenizeString@ with its default separators: the +-- non-empty runs between 'tokenSeparators'. +attrTokens :: BS.ByteString -> [BS.ByteString] +attrTokens = filter (not . BS.null) . BS.splitWith (`BS.elem` tokenSeparators) + +-- | The file an attribute passed as a file is written to: upstream's +-- @.attr-@ and the SHA-256 of the attribute's name in Nix base-32, so +-- whatever the name holds, the file is one entry of the build directory. +passedFileName :: Text -> FilePath +passedFileName name = T.unpack (passedFilePrefix <> Nix32.encode (sha256Digest (TE.encodeUtf8 name))) + -- | Build the process environment from the derivation's contribution -- ('adEnv') + standard vars. -- The builder path is used to derive PATH entries - the builder's own @@ -858,13 +1038,17 @@ -- Process execution -- --------------------------------------------------------------------------- --- | Run the builder process, returning either (exitCode, stderr) on failure --- or () on success. +-- | Run the builder process, copying what it writes to @buildLog@, and +-- report how it exited. -- +-- Its standard output and standard error are one pipe ('openLogPipe'), +-- so the log holds both in the order the builder wrote them, as +-- upstream's does. Its standard input is a pipe this process closes +-- as soon as the builder is spawned, so a read sees end-of-file. +-- -- The child's environment is exactly the build environment plus --- 'scrubAmbient''s allowance - the ambient environment does not flow --- through. Filesystem and process isolation remain future work; the --- environment no longer waits on them. +-- 'scrubAmbient'\'s allowance - the ambient environment does not flow +-- through. Filesystem and process isolation remain future work. -- -- @impureVars@ is the impureEnvVars carve-out: the caller passes the -- names a fixed-output derivation listed (empty otherwise), and each @@ -873,13 +1057,14 @@ -- Upstream writes these last in initEnv, so they win even over the -- derivation's own values. Names match exactly, as upstream's do. runBuilder :: + System.IO.Handle -> FilePath -> [String] -> Map Text Text -> [Text] -> FilePath -> - IO (Either (Int, Text) ()) -runBuilder builderPath builderArgs buildEnv impureVars workDir = do + IO (Either BuilderFailure ()) +runBuilder buildLog builderPath builderArgs buildEnv impureVars workDir = do systemEnv <- System.Environment.getEnvironment let systemMap = Map.fromList [(T.pack k, T.pack v) | (k, v) <- systemEnv] impureAllowance = @@ -888,12 +1073,16 @@ -- on Windows; the scrubbed ambient allowance fills underneath. mergedEnv = unionEnvs [impureAllowance, buildEnv, scrubAmbient systemMap] envList = [(T.unpack k, T.unpack v) | (k, v) <- Map.toList mergedEnv] - cp = + spawnWith toLog = (mkBuilderProcess builderPath builderArgs) { Proc.cwd = Just workDir, Proc.env = Just envList, - Proc.std_out = Proc.CreatePipe, - Proc.std_err = Proc.CreatePipe, + Proc.std_in = Proc.CreatePipe, + -- The spawn closes this process's copy of the write end, so + -- the builder's tree holds the only ones and its exit ends + -- the log. + Proc.std_out = Proc.UseHandle toLog, + Proc.std_err = Proc.UseHandle toLog, -- Wrap the builder's whole process tree in a Win32 job with -- kill-on-job-close. Without it, a builder's grandchildren -- (bash -> make -> cc, or anything cmd.exe spawns) outlive an @@ -901,16 +1090,23 @@ -- so the tree is orphaned and keeps running. With the job, -- terminateProcess becomes TerminateJobObject and reaps the -- tree, and waitForProcess waits for all of it. Ignored on - -- POSIX, where a process group already scopes the children. + -- POSIX, where terminateProcess signals the builder alone and + -- leaves its descendants running. -- A deliberately daemonizing grandchild changes from leaking -- to blocking the build until it exits; that is the correct -- trade for a build, which owns everything it spawned. Proc.use_process_jobs = True } - (exitCode, _stdout, stderrText) <- Proc.readCreateProcessWithExitCode cp "" - case exitCode of - ExitSuccess -> pure (Right ()) - ExitFailure code -> pure (Left (code, T.pack stderrText)) + closePipe (fromBuilder, toLog) = System.IO.hClose fromBuilder *> System.IO.hClose toLog + exitCode <- + bracket openLogPipe closePipe $ \(fromBuilder, toLog) -> + Proc.withCreateProcess (spawnWith toLog) $ \stdinEnd _ _ process -> do + for_ stdinEnd System.IO.hClose + streamBuildLog fromBuilder buildLog + Proc.waitForProcess process + pure $ case exitCode of + ExitSuccess -> Right () + ExitFailure code -> Left (BuilderExited code) -- | Create the appropriate process spec for the builder. -- @@ -1133,116 +1329,186 @@ -- Output registration -- --------------------------------------------------------------------------- --- | After a successful build, register every output in the store. +-- | After a successful build, register every output in the store, in +-- upstream's two passes (registerOutputs, local-derivation-goal.cc:2288-2751 +-- at 2.24.9). Every output is scanned first. Then the outputs are ordered +-- so that each follows the siblings it references ('orderByReferences'), +-- and placed in that order. Outputs that reference each other in a cycle +-- fail the build before any is placed, so none is registered. -- --- Outputs are placed first and registered together (one transaction) so --- intra-derivation cross-output references survive (see 'registerPaths'). +-- The placed outputs register together in one transaction, so a +-- cross-output reference finds its referent's row (see 'registerPaths'). registerOutputs :: BuildConfig -> Store -> Derivation -> - FilePath -> + StorePath -> + Set StorePath -> [OutputPlan] -> IO BuildResult -registerOutputs config store drv _buildDir plans = do - -- Candidates for reference scanning: input sources, the input - -- derivations' realized OUTPUT paths, and this derivation's own outputs. - inputOutputs <- fromRight [] <$> resolveInputOutputs config drv - let allCandidates = collectAllCandidates drv ++ inputOutputs - -- Deriver path is not available from the Derivation type alone; - -- the caller (buildWithDeps) would need to pass it through. - -- Register with no deriver for now - queryDeriver will return Nothing. - drvPathText = Nothing - -- (fallback dir, the output it stood in for) for every already-valid - -- output. Nothing may reference one: the tree is discarded after the - -- build, so a reference to it is a dangling edge, and upstream avoids - -- the same thing by rewriting the hashes back out of the contents. - -- Scanning for it and failing is louder and needs no rewriting. - fallbackPairs = - [ (storePathToFilePath (bcStoreDir config) (opScratch p), opFinal p) - | p <- plans, - opValid p - ] - -- Phase 1: scan references and move each output into the store, collecting a - -- PathRegistration (no DB writes yet). Already-valid outputs are skipped. - prepared <- mapM (prepareOutput config store allCandidates fallbackPairs drvPathText) (zip (drvOutputs drv) plans) - case sequence prepared of +registerOutputs config store drv drvPath inputPaths plans = do + let -- Candidates for reference scanning: the input closure and this + -- derivation's own outputs, upstream's @referenceablePaths@ + -- (local-derivation-goal.cc:2275-2278 at 2.24.9). + allCandidates = Set.toList inputPaths ++ map doPath (drvOutputs drv) + -- Outputs register with no deriver yet, so 'queryDeriver' answers + -- Nothing for a built path, where upstream records the @.drv@ + -- (local-derivation-goal.cc:2738). + deriver = Nothing + -- An output may record an already-valid sibling, whose build wrote to + -- a scratch path that is about to stop existing, so each scratch hash + -- becomes the final one. Upstream scans first and translates its hits; + -- rewriting first lets the scan see final hashes and needs no + -- translation, and the references come out the same. + scratchRewrites = [(spHash (opScratch p), spHash (opFinal p)) | p <- plans, opValid p] + scanned <- runExceptT (traverse (scanOutput config store allCandidates scratchRewrites) (zip (drvOutputs drv) plans)) + case orderByReferences (siblingsReferenced (drvOutputs drv)) . Map.fromList <$> scanned of Left errMsg -> pure (BuildFailure errMsg 1) - Right regs -> do - -- Phase 2: register ALL outputs in one transaction. - registerPaths (stDB store) (catMaybes regs) - case drvOutputs drv of - (firstOut : _) -> pure (BuildSuccess (doPath firstOut)) - [] -> pure (BuildFailure "no outputs defined" 1) + Right (Left cycleEdge) -> pure (BuildFailure (outputCycleMessage drvPath cycleEdge) 1) + Right (Right ordered) -> do + placed <- runExceptT (traverse (ExceptT . placeOutput store deriver . snd) ordered) + case placed of + Left errMsg -> pure (BuildFailure errMsg 1) + Right regs -> do + registerPaths (stDB store) (catMaybes regs) + case drvOutputs drv of + (firstOut : _) -> pure (BuildSuccess (doPath firstOut)) + [] -> pure (BuildFailure "no outputs defined" 1) --- | Prepare a single output for registration: skip if already valid in the DB, --- otherwise scan references (input refs plus self/cross-output temp refs) and --- place it in the store, returning its 'PathRegistration'. Returns @Nothing@ --- for an output already registered as valid. -prepareOutput :: +-- | Upstream's failure for outputs that reference each other in a cycle +-- (local-derivation-goal.cc:2406-2408 at 2.24.9), naming the @.drv@ and +-- the reference that closes the cycle. +outputCycleMessage :: StorePath -> ReferenceCycle Text -> Text +outputCycleMessage drvPath (ReferenceCycle node referrer) = + "cycle detected in build of '" + <> storePathToText defaultStoreDir drvPath + <> "' in the references of output '" + <> node + <> "' from output '" + <> referrer + <> "'" + +-- | One output after the scan and before it is placed: upstream's +-- @AlreadyRegistered@ and @PerhapsNeedToRegister@. +data ScannedOutput + = -- | Registered before the build, and left as it is. + AlreadyRegistered + | -- | Built here: the output, where the builder wrote it, and the + -- references the scan found in it. + NeedsRegistering !DerivationOutput !FilePath ![StorePath] + +-- | Scan one output, keyed by its name: skip it if it is already valid in +-- the DB, otherwise rewrite scratch hashes in it and scan it for +-- references to the input closure and this derivation's outputs. +scanOutput :: BuildConfig -> Store -> [StorePath] -> - [(FilePath, StorePath)] -> - Maybe Text -> + [(Text, Text)] -> (DerivationOutput, OutputPlan) -> - IO (Either Text (Maybe PathRegistration)) -prepareOutput config store candidates fallbackPairs drvPathText (output, plan) = do - let targetSP = doPath output - targetPath = storePathToFilePath (bcStoreDir config) targetSP - outDir = storePathToFilePath (bcStoreDir config) (opScratch plan) + ExceptT Text IO (Text, ScannedOutput) +scanOutput config store candidates scratchRewrites (output, plan) = do + let outDir = storePathToFilePath (bcStoreDir config) (opScratch plan) -- Check the build actually produced the output (file or directory). - exists <- doesPathExist outDir - if not exists - then pure (Left ("output missing: " <> T.pack outDir)) - else do - -- Validity is a DB fact, not mere disk presence: an output left on disk - -- by an interrupted run is NOT valid, and build outputs are not - -- content-addressed, so a leftover cannot be verified against its path. - -- Replace it with the freshly built output (upstream's delete-then-move - -- at output registration) rather than adopt unverifiable bytes; - -- 'removePathForcibly' clears read-only marks, so a tree an earlier run - -- already marked read-only cannot wedge the replacement. - valid <- isValid store targetSP - if valid - then pure (Right Nothing) - else do - -- The builder wrote straight into the store path, so there is - -- nothing to clear: outDir IS targetPath. A stale tree from an - -- interrupted run was removed before the build, not here. - -- - -- One scan, not two: 'candidates' already carries this - -- derivation's own outputs, and outDir is the final path, so a - -- self- or cross-output reference is an ordinary hit. - leaked <- scanTempReferences fallbackPairs outDir - case leaked of - _ : _ -> do - -- A fallback path is about to stop existing, so a produced - -- output naming one would be registered with a dangling - -- reference. Fail loudly instead, and take the tree back - -- out so no later run meets it. - removePathForcibly outDir - pure - ( Left - ( "output " - <> doName output - <> " refers to the scratch path of an already-valid output (" - <> T.intercalate ", " [spName sp <> "@" <> spHash sp | sp <- leaked] - <> "); rebuild every output of this derivation instead" - ) - ) - [] -> do - refs <- dedupStorePaths <$> scanReferences candidates outDir - reg <- placeInStore store outDir targetSP drvPathText refs - fixedCheck <- verifyFixedOutput (volumeCaseHack (stCaseSensitivity store)) output targetPath - case fixedCheck of - Left err -> do - -- Wrong bytes for a declared content address: remove the - -- placed tree so a later run cannot meet it on disk. - removePathForcibly targetPath - pure (Left err) - Right () -> pure (Right (Just reg)) + exists <- liftIO (doesPathExist outDir) + unless exists (throwError ("output missing: " <> T.pack outDir)) + -- Validity is a DB fact, not mere disk presence: an output left on disk + -- by an interrupted run is NOT valid, and build outputs are not + -- content-addressed, so a leftover cannot be verified against its path. + -- 'runPlannedBuild' removed any leftover before the builder ran, so the + -- tree here is this build's (upstream's delete-then-move). + valid <- liftIO (isValid store (doPath output)) + if valid + then pure (doName output, AlreadyRegistered) + else liftIO $ do + -- One scan, not two: 'candidates' already carries this + -- derivation's own outputs, and outDir is the final path, so a + -- self- or cross-output reference is an ordinary hit. + rewriteStoreHashes scratchRewrites outDir + refs <- dedupStorePaths <$> scanReferences candidates outDir + pure (doName output, NeedsRegistering output outDir refs) +-- | The names of the sibling outputs an output's scan found. An output +-- registered before the build references none: upstream uses the +-- registered copy and treats it as a leaf. +siblingsReferenced :: [DerivationOutput] -> ScannedOutput -> Set Text +siblingsReferenced outputs = referencedBy + where + nameByPath = Map.fromList [(doPath o, doName o) | o <- outputs] + referencedBy AlreadyRegistered = Set.empty + referencedBy (NeedsRegistering _ _ refs) = Set.fromList (mapMaybe (`Map.lookup` nameByPath) refs) + +-- | Place a scanned output in the store and check a fixed output's +-- content, returning its 'PathRegistration'; @Nothing@ for an output +-- registered before the build. +placeOutput :: Store -> Maybe Text -> ScannedOutput -> IO (Either Text (Maybe PathRegistration)) +placeOutput store deriver scanned = case scanned of + AlreadyRegistered -> pure (Right Nothing) + NeedsRegistering output outDir refs -> do + -- The builder wrote straight into the store path, so outDir IS the + -- target and placing it moves nothing. + let targetPath = storePathToFilePath (stDir store) (doPath output) + reg <- placeInStore store outDir (doPath output) deriver refs + fixedCheck <- verifyFixedOutput (volumeCaseHack (stCaseSensitivity store)) output targetPath + case fixedCheck of + Left err -> do + -- Wrong bytes for a declared content address: remove the placed + -- tree so a later run cannot meet it on disk. 'removePathForcibly' + -- clears the read-only marks placing set. + removePathForcibly targetPath + pure (Left err) + Right () -> pure (Right (Just reg)) + +-- | A reference cycle, named by the reference that closes it: the node +-- reached again while it is still on the walk's path, and the node whose +-- reference reached it. +data ReferenceCycle k = ReferenceCycle + { cycleNode :: !k, + cycleReferrer :: !k + } + deriving (Eq, Show) + +-- | Where the walk in 'orderByReferences' is: the nodes it has entered, +-- and the ones it has finished, the last finished first. +data Walk k v = Walk + { walkEntered :: !(Set k), + walkFinished :: ![(k, v)] + } + +-- | Order nodes so that each follows every node it references, or report +-- a cycle among them: upstream's @topoSort@ (src/libutil/topo-sort.hh at +-- 2.24.9) with the reversal its @registerOutputs@ applies to the result +-- (local-derivation-goal.cc:2411). +-- +-- The walk is upstream's depth-first one, so the order and the cycle it +-- reports are upstream's too: it starts from each node in ascending +-- order, follows each node's references in ascending order, ignores a +-- self-reference and a reference to a node not in the map, and lists a +-- node once everything it references is listed. The first reference that +-- leads back to a node still on the path is the cycle reported. +orderByReferences :: (Ord k) => (v -> Set k) -> Map k v -> Either (ReferenceCycle k) [(k, v)] +orderByReferences references nodes = + reverse . walkFinished <$> foldM (visit Set.empty) (Walk Set.empty []) (Map.toAscList nodes) + where + visit onPath walk node@(key, value) + | Set.member key (walkEntered walk) = Right walk + | otherwise = do + let referenced = + [ (child, childValue) + | child <- Set.toAscList (references value), + child /= key, + Just childValue <- [Map.lookup child nodes] + ] + finished <- + foldM + (follow (Set.insert key onPath) key) + walk {walkEntered = Set.insert key (walkEntered walk)} + referenced + pure finished {walkFinished = node : walkFinished finished} + follow onPath referrer walk child@(key, _) + | Set.member key onPath = Left (ReferenceCycle key referrer) + | otherwise = visit onPath walk child + -- | Re-check a placed fixed-output output against its declared hash. -- A fixed-output derivation declares both its store path and, via the -- output spec (@doHashAlgo@ + @doHash@), the exact content the path @@ -1310,31 +1576,22 @@ dedupStorePaths :: [StorePath] -> [StorePath] dedupStorePaths = Map.elems . Map.fromList . map (\sp -> (spHash sp, sp)) --- | Collect all candidate store paths from the derivation's inputs. --- Used for reference scanning. -collectAllCandidates :: Derivation -> [StorePath] -collectAllCandidates drv = - let inputSrcs = drvInputSrcs drv - inputDrvPaths = Map.keys (drvInputDrvs drv) - outputPaths = map doPath (drvOutputs drv) - in inputSrcs ++ inputDrvPaths ++ outputPaths - -- --------------------------------------------------------------------------- -- Dependency-aware build orchestration -- --------------------------------------------------------------------------- --- | Build a derivation and all its transitive dependencies. +-- | Realise a derivation and what it needs, root first ("Nix.Realise"). -- -- 1. Build the dependency graph by reading .drv files from the store. --- 2. Topologically sort: leaves (no deps) first. --- 3. For each dependency in build order: --- a. Already in store? Skip. --- b. Available in a binary cache? Substitute. --- c. Otherwise: build locally. --- 4. Build the root derivation last. +-- 2. Refuse a cycle. +-- 3. Try each derivation's outputs before its inputs, so a substituted +-- derivation needs only its runtime closure. What no cache supplies +-- builds locally, leaves first, and so does what a cache fails to +-- deliver when 'bcFallback' allows it. -- -- Returns 'BuildSuccess' with the root output path on success, or --- 'BuildFailure' if any dependency fails to build or substitute. +-- 'BuildFailure' with exit code 1 if a derivation fails to build, a +-- substitute fails under 'NoFallback', or a cache cannot be asked. buildWithDeps :: BuildConfig -> Store -> Derivation -> StorePath -> IO BuildResult buildWithDeps config store rootDrv rootDrvPath = do graph <- buildDepGraph (readDrvFromStore config) rootDrv rootDrvPath @@ -1344,21 +1601,15 @@ case topoSort depGraph of TopoCycle _ -> pure (BuildFailure "dependency cycle detected" 1) - TopoSorted buildOrder -> do - let drvMap = Map.fromList [(sp, drv) | sp <- buildOrder, Just drv <- [lookupDrv depGraph sp]] - result <- buildInOrder config store drvMap buildOrder + TopoSorted _ -> do + result <- realise (bcFallback config) (realiseEffects config store) depGraph rootDrvPath case result of - Left err -> pure (BuildFailure err 1) + Left failure -> pure (BuildFailure (realiseFailureMessage failure) 1) Right () -> case drvOutputs rootDrv of (firstOut : _) -> pure (BuildSuccess (doPath firstOut)) [] -> pure (BuildFailure "no outputs defined" 1) --- | Look up a derivation in the dependency graph. -lookupDrv :: DepGraph -> StorePath -> Maybe Derivation -lookupDrv (Nix.DependencyGraph.DepGraph g) sp = - Nix.DependencyGraph.dnDerivation <$> Map.lookup sp g - -- | Read and parse a .drv file from the store, as bytes (no locale -- decode, no newline translation). readDrvFromStore :: BuildConfig -> StorePath -> IO (Either Text Derivation) @@ -1370,73 +1621,59 @@ Right bytes -> fromATerm bytes -- --------------------------------------------------------------------------- --- Build in topological order +-- Realisation effects -- --------------------------------------------------------------------------- --- | Status tag for dependency resolution status messages. -data DepStatus = Cached | Substituted | Building +-- | The store, caches and builder that "Nix.Realise" drives. +realiseEffects :: BuildConfig -> Store -> RealiseEffects IO +realiseEffects config store = + RealiseEffects + { reSubst = + SubstEffects + { seValid = isValid store, + seReferences = queryReferencesWith (bcFetchRetry config) ioRetryEffects (bcFallback config) (bcCaches config), + seFetch = substitutePaths config store + }, + -- Every output, not just the first: a derivation whose first output is + -- valid and whose second was deleted would otherwise be logged cached + -- and skipped, and the missing output would stay missing. Upstream + -- skips a build only when all of them are valid. + reAllValid = fmap isJust . allOutputsValid store, + reBuild = buildReporting config store, + reReport = logRealised + } +-- | Build one derivation, naming it in any failure. +buildReporting :: BuildConfig -> Store -> Derivation -> StorePath -> IO (Either Text ()) +buildReporting config store drv drvPath = do + result <- buildDerivation config store drv drvPath + pure $ case result of + BuildSuccess _ -> Right () + BuildFailure msg code -> + Left ("building " <> formatDrvName drv <> " failed: exit " <> T.pack (show code) <> ": " <> msg) + -- | Format a status tag for display. -statusTag :: DepStatus -> Text -statusTag Cached = "[cached]" +statusTag :: Realised -> Text +statusTag AlreadyValid = "[cached]" statusTag Substituted = "[subst] " -statusTag Building = "[build] " - --- | Build dependencies in topological order. --- Skips paths already in the store, tries substitution, then builds. -buildInOrder :: BuildConfig -> Store -> Map StorePath Derivation -> [StorePath] -> IO (Either Text ()) -buildInOrder _ _ _ [] = pure (Right ()) -buildInOrder config store drvMap (sp : rest) = - case Map.lookup sp drvMap of - Nothing -> - -- Not a derivation we know about - might be a source path. Skip. - buildInOrder config store drvMap rest - Just drv -> do - status <- resolveDep config store drv - case status of - Right depStatus -> do - logDepStatus depStatus drv - buildInOrder config store drvMap rest - Left err -> - pure (Left ("building " <> formatDrvName drv <> " failed: " <> err)) - --- | Resolve a single dependency: check cache, try substitution, or build. -resolveDep :: BuildConfig -> Store -> Derivation -> IO (Either Text DepStatus) -resolveDep config store drv = do - -- Every output, not just the first: a derivation whose first output is - -- valid and whose second was deleted would otherwise be logged cached - -- and skipped, and the missing output would stay missing. Upstream - -- skips a build only when all of them are valid. - cached <- isJust <$> allOutputsValid store drv - if cached - then pure (Right Cached) - else do - substituted <- trySubstituteOutputs config store drv - if substituted - then pure (Right Substituted) - else do - result <- buildDerivation config store drv - case result of - BuildSuccess _ -> pure (Right Building) - BuildFailure msg code -> - pure (Left ("exit " <> T.pack (show code) <> ": " <> msg)) +statusTag Built = "[build] " --- | Log dependency resolution status to stderr. -logDepStatus :: DepStatus -> Derivation -> IO () -logDepStatus status drv = +-- | Log how a dependency was realised to stderr. +logRealised :: Realised -> Derivation -> IO () +logRealised status drv = TIO.hPutStrLn System.IO.stderr (" " <> statusTag status <> " " <> formatDrvName drv) --- | Try to substitute all outputs of a derivation from binary caches. --- Returns True if every output was substituted or already valid. +-- | Try to substitute paths from binary caches, every one of them or none +-- ('FetchOutcome'). -- --- Registration is all-or-nothing and batched: every output is verified --- and unpacked first, then recorded in one 'registerPaths' transaction, --- so cross-output reference edges land after both endpoints' rows exist --- and a partial substitution registers nothing (the subsequent build --- starts from unregistered outputs and 'prepareOutput' replaces the --- leftover unpacked trees). +-- Registration is all-or-nothing and batched: every path is verified and +-- unpacked first, then recorded in one 'registerPaths' transaction, so +-- reference edges between the outputs of one derivation land after both +-- endpoints' rows exist and a partial substitution registers nothing (the +-- subsequent build starts from unregistered outputs and 'runPlannedBuild' +-- replaces the leftover unpacked trees). -- --- Each substituted output arrives with its path lock STILL HELD (see +-- Each substituted path arrives with its path lock STILL HELD (see -- 'Nix.Substituter.SubstSuccess'), and the exclusion must survive until -- the registration transaction commits - released earlier, another -- process could meet the unpacked-but-unregistered window and delete @@ -1446,45 +1683,55 @@ -- -- A registration the database REFUSES - its unregistered-referent guard, -- reachable only through cache-declared references this store has never --- seen - is a substitution failure like any other: the transaction --- recorded nothing, so report it and fall back to building locally. -trySubstituteOutputs :: BuildConfig -> Store -> Derivation -> IO Bool -trySubstituteOutputs config store drv - | null (bcCaches config) = pure False +-- seen - is a failed substitution like any other: the transaction +-- recorded nothing, so report it ('FetchFailed'). Upstream's copy of the +-- path fails the same way when a reference is not valid. +substitutePaths :: BuildConfig -> Store -> [StorePath] -> IO FetchOutcome +substitutePaths config store paths + | null (bcCaches config) = pure FetchMissed | otherwise = do heldLocks <- newIORef [] registerSubstituted heldLocks `finally` (readIORef heldLocks >>= mapM_ releasePathLock) where - registerSubstituted :: IORef [PathLock] -> IO Bool + registerSubstituted :: IORef [PathLock] -> IO FetchOutcome registerSubstituted heldLocks = do - results <- mapM (substituteOne heldLocks . doPath) (drvOutputs drv) - case traverse substOutcome results of - Nothing -> pure False - Just outcomes -> do - registered <- try (registerPaths (stDB store) (catMaybes outcomes)) + results <- mapM (substituteOne heldLocks) (lockOrder paths) + case batchRegistrations results of + Left outcome -> pure outcome + Right rows -> do + registered <- try (registerPaths (stDB store) rows) case registered of - Right () -> pure True + Right () -> pure Fetched Left (e :: IOException) -> do - TIO.hPutStrLn - System.IO.stderr - (" [subst] registration refused, building instead: " <> T.pack (displayException e)) - pure False + TIO.hPutStrLn System.IO.stderr (" [subst] registration refused: " <> T.pack (displayException e)) + pure FetchFailed -- Record a returned lock the moment it exists, so the enclosing - -- finally owns it even when a later output's attempt fails or - -- throws. + -- finally owns it even when a later path's attempt fails or throws. substituteOne heldLocks sp = do result <- trySubstituteWith (bcFetchRetry config) ioRetryEffects store (bcCaches config) sp case result of SubstSuccess _ lock -> atomicModifyIORef' heldLocks (\locks -> (lock : locks, ())) + SubstError err -> TIO.hPutStrLn System.IO.stderr (" [subst] " <> spName sp <> ": " <> err) _ -> pure () pure result - -- An already-valid output counts as substituted but contributes no + +-- | What one batch's results come to: the rows to register when every path +-- arrived, or why not. One failed path fails the batch whatever the others +-- did, as one failed output fails upstream's derivation goal. +batchRegistrations :: [SubstResult] -> Either FetchOutcome [PathRegistration] +batchRegistrations results + | any failed results = Left FetchFailed + | otherwise = maybe (Left FetchMissed) (Right . catMaybes) (traverse arrived results) + where + failed (SubstError _) = True + failed _ = False + -- An already-valid path counts as arrived but contributes no -- registration row (and holds no lock). - substOutcome (SubstSuccess reg _) = Just (Just reg) - substOutcome SubstAlreadyValid = Just Nothing - substOutcome SubstNotFound = Nothing - substOutcome (SubstError _) = Nothing + arrived (SubstSuccess reg _) = Just (Just reg) + arrived SubstAlreadyValid = Just Nothing + arrived SubstNotFound = Nothing + arrived (SubstError _) = Nothing -- | Format a derivation name for status output (display-only, so the -- byte-string env value decodes lossily). diff --git a/src/Nix/Builder/Log.hs b/src/Nix/Builder/Log.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Builder/Log.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE CPP #-} + +-- | A builder's output, on its way to the build log. +-- +-- Upstream gives the builder one channel for its standard output and +-- standard error, so what it wrote arrives in the order it wrote it, +-- and its default logger prints each line to standard error as the line +-- completes, filtered for the terminal. The line discipline and the +-- filter are pure ('feedBuildLog', 'endBuildLog', 'filterLogLine'); the +-- pipe and the copy loop are the IO around them. +module Nix.Builder.Log + ( -- * Line discipline + PendingLine, + emptyPendingLine, + feedBuildLog, + endBuildLog, + + -- * Terminal filter + EscapeFilter (..), + filterLogLine, + + -- * Streaming + openLogPipe, + streamBuildLog, + ) +where + +import Data.Bits ((.&.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import Data.Foldable (for_) +import Data.Word (Word8) +import Nix.Environment (EnvLookup (..), lookupEnvBytes) +import qualified System.Process as Proc + +#if defined(mingw32_HOST_OS) + +import Control.Exception (IOException, catch) +import System.IO (Handle, hIsTerminalDevice) + +#else + +import Control.Exception (IOException, catch, onException) +import GHC.IO.FD (fdFD) +import GHC.IO.Handle.FD (handleToFd) +import System.IO (Handle, hClose, hIsTerminalDevice) +import System.Posix.IO (FdOption (CloseOnExec), setFdOption) +import System.Posix.Types (Fd (..)) + +#endif + +-- --------------------------------------------------------------------------- +-- Line discipline +-- --------------------------------------------------------------------------- + +-- | The line a builder is writing, held as a terminal holds it: the +-- bytes left of the cursor, and the bytes from the cursor on, which the +-- next bytes written overwrite. Upstream's @currentLogLine@ and +-- @currentLogLinePos@ (derivation-goal.hh at 2.24.9). +data PendingLine + = PendingLine + -- | The bytes left of the cursor in chunks, latest first, each + -- shorter than the one after it ('pushChunk'). + ![BS.ByteString] + -- | The bytes from the cursor to the end of the line. + !BS.ByteString + +-- | No line started yet. +emptyPendingLine :: PendingLine +emptyPendingLine = PendingLine [] BS.empty + +-- | Split builder output into the lines it completes, in order, and the +-- line it leaves pending, by upstream's rule +-- (@DerivationGoal::handleChildOutput@, derivation-goal.cc at 2.24.9): +-- a line feed ends the line, a carriage return moves the cursor back to +-- the start of the line so what follows overwrites it, and any other +-- byte is written at the cursor. A CRLF therefore ends a line without +-- leaving the CR in it, and a progress counter redrawn after CRs leaves +-- its last state. The lines do not depend on where the output was +-- split into reads. +feedBuildLog :: PendingLine -> BS.ByteString -> ([BS.ByteString], PendingLine) +feedBuildLog = go [] + where + go done !pending bytes = + let (run, rest) = BS8.break isControl bytes + !written = writeAtCursor run pending + in case BS8.uncons rest of + Nothing -> (reverse done, written) + Just ('\r', after) -> go done (toLineStart written) after + -- The line feed, the only other byte the break stops at. + Just (_, after) -> + let !line = lineBytes written + in go (line : done) emptyPendingLine after + isControl c = c == '\n' || c == '\r' + +-- | The line pending when the builder's output ends, which upstream's +-- @handleEOF@ flushes when it holds any bytes. +endBuildLog :: PendingLine -> Maybe BS.ByteString +endBuildLog pending + | BS.null line = Nothing + | otherwise = Just line + where + line = lineBytes pending + +-- | Write bytes at the cursor, overwriting as many as they replace. +writeAtCursor :: BS.ByteString -> PendingLine -> PendingLine +writeAtCursor !run pending@(PendingLine before fromCursor) + | BS.null run = pending + | otherwise = PendingLine (pushChunk run before) (BS.drop (BS.length run) fromCursor) + +-- | Add the latest chunk left of the cursor, merging it into the chunks +-- before it while it is at least as long as they are. A line that +-- arrives a few bytes per read is then held in a number of chunks +-- logarithmic in its length, rather than one per read. +pushChunk :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString] +pushChunk !newer chunks = case chunks of + older : rest + | BS.length newer >= BS.length older -> pushChunk (older <> newer) rest + _ -> newer : chunks + +-- | Move the cursor to the start of the line, keeping the line. +toLineStart :: PendingLine -> PendingLine +toLineStart pending = PendingLine [] (lineBytes pending) + +-- | The whole line, cursor or not. +lineBytes :: PendingLine -> BS.ByteString +lineBytes (PendingLine before fromCursor) = BS.concat (reverse (fromCursor : before)) + +-- --------------------------------------------------------------------------- +-- Terminal filter +-- --------------------------------------------------------------------------- + +-- | Which escape sequences a build-log line keeps on its way to the user. +data EscapeFilter + = -- | Keep colour (an SGR sequence, CSI ending in @m@) and drop the rest, + -- for a terminal that renders it. + KeepColour + | -- | Drop every escape sequence. + DropEscapes + deriving (Eq, Show) + +-- | A build-log line as upstream's logger writes it to standard error +-- (@filterANSIEscapes@, terminal.cc at 2.24.9, at the unlimited width +-- @SimpleLogger::log@ passes): an escape sequence is dropped unless the +-- filter keeps it, a tab becomes spaces up to the next multiple of +-- eight columns, a bell or carriage return is dropped, and every other +-- byte is kept. A column is one character as upstream groups one: a +-- UTF-8 lead byte with as many continuation bytes as it announces and +-- as follow it, or any other byte alone. +filterLogLine :: EscapeFilter -> BS.ByteString -> BS.ByteString +filterLogLine escapes = BL.toStrict . BB.toLazyByteString . go 0 + where + go :: Int -> BS.ByteString -> BB.Builder + go !column bytes = + let (plain, rest) = BS.span isPlainAscii bytes + in BB.byteString plain <> special (column + BS.length plain) rest + special column bytes = case BS.uncons bytes of + Nothing -> mempty + Just (byte, rest) + | byte == escapeByte -> + let (escape, after) = escapeSequence rest + escapeBytes = BS.cons byte (BS.take (BS.length rest - BS.length after) rest) + in kept escape escapeBytes <> go column after + | byte == tabByte -> + let width = tabStop - column `mod` tabStop + in BB.byteString (BS.replicate width spaceByte) <> go (column + width) rest + | byte == bellByte || byte == carriageReturnByte -> go column rest + | otherwise -> + let continued = BS.takeWhile isContinuation (BS.take (continuationCount byte) rest) + in BB.word8 byte <> BB.byteString continued <> go (column + 1) (BS.drop (BS.length continued) rest) + kept escape escapeBytes + | escapes == KeepColour && escape == ColourEscape = BB.byteString escapeBytes + | otherwise = mempty + isPlainAscii byte = + byte < asciiLimit + && byte /= escapeByte + && byte /= tabByte + && byte /= bellByte + && byte /= carriageReturnByte + +-- | What an escape sequence does, as far as the filter cares. +data EscapeKind = ColourEscape | OtherEscape + deriving (Eq) + +-- | The kind of escape the bytes after an ESC begin, and the bytes after +-- its sequence, which upstream's filter reads as a CSI's parameter, +-- intermediate and final bytes, or the one byte a two-byte escape takes, +-- or nothing. +escapeSequence :: BS.ByteString -> (EscapeKind, BS.ByteString) +escapeSequence bytes = case BS.uncons bytes of + Just (byte, afterBracket) + | byte == csiByte -> + let afterParameters = BS.dropWhile (within csiParameterBytes) afterBracket + afterIntermediates = BS.dropWhile (within csiIntermediateBytes) afterParameters + in case BS.uncons afterIntermediates of + Just (final, after) + | within csiFinalBytes final -> (if final == sgrFinalByte then ColourEscape else OtherEscape, after) + _ -> (OtherEscape, afterIntermediates) + | within escapeFinalBytes byte -> (OtherEscape, afterBracket) + _ -> (OtherEscape, bytes) + +-- | How many continuation bytes a UTF-8 lead byte announces. +continuationCount :: Word8 -> Int +continuationCount lead + | lead .&. 0xE0 == 0xC0 = 1 + | lead .&. 0xF0 == 0xE0 = 2 + | lead .&. 0xF8 == 0xF0 = 3 + | otherwise = 0 + +-- | Whether a byte continues a UTF-8 character. +isContinuation :: Word8 -> Bool +isContinuation byte = byte .&. 0xC0 == 0x80 + +-- | Whether a byte lies in an inclusive range. +within :: (Word8, Word8) -> Word8 -> Bool +within (low, high) byte = low <= byte && byte <= high + +-- | The control bytes the filter treats specially, and the space a tab +-- expands to. +escapeByte, tabByte, bellByte, carriageReturnByte, spaceByte :: Word8 +escapeByte = 0x1B +tabByte = 0x09 +bellByte = 0x07 +carriageReturnByte = 0x0D +spaceByte = 0x20 + +-- | The byte opening a control sequence after an ESC (@[@), and the +-- final byte of a colour one (@m@). +csiByte, sgrFinalByte :: Word8 +csiByte = 0x5B +sgrFinalByte = 0x6D + +-- | The ECMA-48 byte ranges upstream's filter reads a sequence by. +csiParameterBytes, csiIntermediateBytes, csiFinalBytes, escapeFinalBytes :: (Word8, Word8) +csiParameterBytes = (0x30, 0x3F) +csiIntermediateBytes = (0x20, 0x2F) +csiFinalBytes = (0x40, 0x7E) +escapeFinalBytes = (0x40, 0x5F) + +-- | The first byte that is not ASCII. +asciiLimit :: Word8 +asciiLimit = 0x80 + +-- | The columns between tab stops. +tabStop :: Int +tabStop = 8 + +-- | The filter upstream's logger applies (@isTTY@, terminal.cc at +-- 2.24.9): colour survives only on a terminal, with @TERM@ set to +-- something other than @dumb@, and neither @NO_COLOR@ nor @NOCOLOR@ +-- set. Upstream asks about its standard error; this asks about the +-- handle the log goes to, which is standard error by default. +escapeFilterFor :: Handle -> IO EscapeFilter +escapeFilterFor buildLog = do + terminal <- hIsTerminalDevice buildLog + term <- lookupEnvBytes termVar + noColour <- traverse lookupEnvBytes noColourVars + pure $ + if terminal && rendersColour term && all (== EnvUnset) noColour + then KeepColour + else DropEscapes + where + rendersColour term = case term of + EnvUnset -> False + EnvValue value -> value /= dumbTerm + EnvUnpairedSurrogate -> True + +-- | The variable naming the terminal type, and the type upstream reads +-- as rendering no colour. +termVar, dumbTerm :: BS.ByteString +termVar = "TERM" +dumbTerm = "dumb" + +-- | The variables whose presence, whatever their value, turns colour off. +noColourVars :: [BS.ByteString] +noColourVars = ["NO_COLOR", "NOCOLOR"] + +-- --------------------------------------------------------------------------- +-- Streaming +-- --------------------------------------------------------------------------- + +-- | A pipe to hand a builder as both its standard output and its +-- standard error, as @(read end, write end)@. +-- +-- One channel keeps the order the builder wrote in. Upstream's channel +-- is a pseudoterminal: the builder's standard error is its slave side, +-- and standard output is a copy of it (@openSlave@ in +-- local-derivation-goal.cc and @commonChildInit@ in child.cc at +-- 2.24.9). A pipe is the channel "System.Process" offers on both +-- platforms, and what a builder can tell apart is @isatty@, which +-- upstream's terminal answers yes: a program that line-buffers or +-- colours its output only on a terminal block-buffers and stays plain +-- here. +-- +-- On POSIX both ends are close-on-exec, so the builder holds the pipe +-- only as its standard output and standard error, as upstream's child +-- does after @closeMostFDs@: a daemon that closes those lets the build +-- finish. A process another thread spawned between the pipe's creation +-- and the flags being set would still inherit it; nova-nix runs one +-- build at a time. On Windows the ends stay inheritable, so a process +-- spawned while the pipe is open inherits them. With one build at a +-- time that is the builder's own tree, which the job object the build +-- runs in already holds it open for until the tree exits. +openLogPipe :: IO (Handle, Handle) + +#if defined(mingw32_HOST_OS) + +openLogPipe = Proc.createPipe + +#else + +openLogPipe = do + ends@(readEnd, writeEnd) <- Proc.createPipe + (closeOnExec readEnd *> closeOnExec writeEnd) + `onException` (hClose readEnd *> hClose writeEnd) + pure ends + where + closeOnExec end = do + fd <- handleToFd end + setFdOption (Fd (fdFD fd)) CloseOnExec True + +#endif + +-- | Copy a builder's output to the build log a line at a time as each +-- line completes, until every holder of the pipe's write end has +-- closed it. +-- +-- A line goes out filtered ('filterLogLine', under 'escapeFilterFor' +-- the log) in one write ending in a line feed, as upstream's default +-- logger writes a build-log line to standard error (@SimpleLogger@, +-- logging.cc at 2.24.9). Upstream first reads a line beginning +-- @\@nix @ as a JSON log message from the builder and does not print +-- one that parses (@handleJSONLogMessage@); here every line is printed. +-- Upstream points @NIX_LOG_FD@ at standard error so stdenv writes such +-- lines, and nova-nix sets no @NIX_LOG_FD@. +-- +-- A line the log fails to take is dropped and the build goes on, as +-- upstream's @writeToStderr@ ignores a failing write (logging.cc), so a +-- reader of standard error that went away does not fail the build. The +-- output is read to its end either way, so the builder never blocks on +-- a full pipe. +streamBuildLog :: Handle -> Handle -> IO () +streamBuildLog fromBuilder buildLog = do + escapes <- escapeFilterFor buildLog + let writeLine line = BS.hPut buildLog (BS8.snoc (filterLogLine escapes line) '\n') `catch` dropLine + go pending = do + chunk <- BS.hGetSome fromBuilder readSize + if BS.null chunk + then for_ (endBuildLog pending) writeLine + else do + let (complete, rest) = feedBuildLog pending chunk + for_ complete writeLine + go rest + go emptyPendingLine + where + dropLine :: IOException -> IO () + dropLine _ = pure () + +-- | How much builder output one read takes at most. The lines written +-- do not depend on it. +readSize :: Int +readSize = 65536 diff --git a/src/Nix/Builder/Unpack.hs b/src/Nix/Builder/Unpack.hs --- a/src/Nix/Builder/Unpack.hs +++ b/src/Nix/Builder/Unpack.hs @@ -4,12 +4,14 @@ -- -- == Why this is a builtin -- --- The Windows stdenv bootstrap fetches pre-built toolchain tarballs (MSYS2 --- @.pkg.tar.zst@ packages) into the store before any toolchain exists there. --- Nothing in the store can unpack them - the unpacker is the thing being --- bootstrapped - and ambient @tar.exe@ is unpinned and may lack zstd support. --- So, like 'Nix.Builder.runBuiltinFetchurl', extraction runs in-process: --- a derivation whose @builder@ is @builtin:unpack@ is handled by this module +-- The Windows bootstrap fetches archives into the store before any tool +-- exists there: pre-built toolchain tarballs (MSYS2 @.pkg.tar.zst@ +-- packages) for the stdenv, and GitHub's @.tar.gz@ archives of the sources +-- the full-source chain assembles. Nothing in the store can unpack them - +-- the unpacker is the thing being bootstrapped - and ambient @tar.exe@ is +-- unpinned and may lack zstd support. So, like +-- 'Nix.Builder.runBuiltinFetchurl', extraction runs in-process: a +-- derivation whose @builder@ is @builtin:unpack@ is handled by this module -- instead of being spawned as a subprocess. -- -- == Derivation interface @@ -54,6 +56,7 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as TarEntry +import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.Zstd.Lazy as Zstd import Control.Exception (ErrorCall, Handler (..), IOException, catches) import Control.Monad (when) @@ -137,7 +140,7 @@ ownerExecuteMode :: TarEntry.Permissions ownerExecuteMode = 0o100 --- | Pax per-file extended header ('x') and global header ('g') type codes. +-- | Pax per-file extended header (@x@) and global header (@g@) type codes. -- 'Tar.decodeLongNames' already applies pax path\/linkpath overrides; any -- header entries still present carry only metadata we do not record (mtime, -- xattrs), so they are skipped rather than rejected. @@ -215,16 +218,18 @@ -- archives after it. The decompressor is chosen by file extension; the -- tar stream is decoded (GNU + pax long names) and extracted entry by -- entry. The archive is read lazily and decoded as the entries are --- forced, so a failure surfaces mid-extraction as one of two exceptions, --- and the whole extraction is wrapped to turn either into a clean --- failure: an 'IOException' reading the archive or writing the tree, or --- the 'ErrorCall' the zstd decoder raises for a corrupt frame (its lazy --- API reports every decoding error with 'error'). +-- forced, so a failure surfaces mid-extraction as an exception, and the +-- whole extraction is wrapped to turn each kind into a clean failure: an +-- 'IOException' reading the archive or writing the tree, the 'ErrorCall' +-- the zstd decoder raises for a corrupt frame (its lazy API reports every +-- decoding error with 'error'), or the 'GZip.DecompressError' the gzip +-- decoder throws for a corrupt or truncated stream. unpackArchive :: FilePath -> UnpackLimits -> FilePath -> IO (Either Text UnpackLimits) unpackArchive outDir budget archivePath = run `catches` [ Handler (\(e :: IOException) -> failed e), - Handler (\(e :: ErrorCall) -> failed e) + Handler (\(e :: ErrorCall) -> failed e), + Handler (\(e :: GZip.DecompressError) -> failed e) ] where failed e = pure (Left (T.pack archivePath <> ": " <> T.pack (show e))) @@ -235,12 +240,14 @@ extractEntries outDir budget (Tar.decodeLongNames (Tar.read (decoder raw))) -- | Choose a decompressor from the archive file name. @.tar.zst@ (MSYS2 --- packages) and plain @.tar@ are supported. MSYS2's zstd frames do not --- pledge a content size, so the lazy (streaming) zstd decoder is required - --- the strict single-shot API rejects them. +-- packages), @.tar.gz@ (GitHub's archive of a commit) and plain @.tar@ are +-- supported. MSYS2's zstd frames do not pledge a content size, so the lazy +-- (streaming) zstd decoder is required - the strict single-shot API rejects +-- them. decoderFor :: FilePath -> Maybe (BL.ByteString -> BL.ByteString) decoderFor path | ".tar.zst" `isSuffixOf` lowered = Just Zstd.decompress + | ".tar.gz" `isSuffixOf` lowered = Just GZip.decompress | ".tar" `isSuffixOf` lowered = Just id | otherwise = Nothing where diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -1,11 +1,11 @@ -- | Built-in function environment for the Nix evaluator. -- -- Every Nix expression has access to a @builtins@ attribute set containing --- ~100 functions. This module assembles the initial 'Env' from the +-- ~100 functions. This module assembles the initial t'Env' from the -- central registry in "Nix.Eval" and adds standard constants -- (@true@, @false@, @null@, @storeDir@, @currentTime@, --- @currentSystem@, etc.), among them @derivation@: upstream's wrapper --- lambda around the @derivationStrict@ primop, evaluated from its source. +-- @currentSystem@, etc.), among them @derivation@: a Nix lambda over the +-- @derivationStrict@ primop, evaluated from its source. -- The impure constants follow the evaluation policy: under @pure-eval@ -- upstream installs neither @currentTime@ nor @currentSystem@ -- (@addConstant@ skips an @impureOnly@ constant), so neither exists here @@ -46,7 +46,7 @@ import Nix.Eval (Env (..), NixValue (..), Thunk (..), attrSetFromMap, attrSetLookup, builtinNames, currentSystemStr, deferApply, evaluated, readThunkValue) import Nix.Eval.Types (AttrSet, EvalPolicy (..), cheapThunk, clistFromThunks, mkStr, mkStrBytes, newCEnv, thunkToCPtr) import Nix.Expr.Resolve (impureOnlyGlobalNames, staticGlobalNames) -import Nix.Parser (parseNixWithScope) +import Nix.Parser (SourceOrigin (..), parseNixWithScope) import Nix.Store.Path (defaultStoreDirText) -- | The initial environment: every name upstream's base environment binds @@ -122,7 +122,7 @@ -- /nix/store spelling on every platform, and storeDir must agree -- with them (upstream returns the store dir its paths are under). ("storeDir", evaluated (mkStr defaultStoreDirText)), - ("nixVersion", evaluated (mkStr "2.24.0")), + ("nixVersion", evaluated (mkStr targetNixVersion)), ("langVersion", evaluated (VInt 6)), ("nixPath", evaluated (VList (clistFromThunks (map thunkToCPtr searchPaths)))), ("derivation", derivationWrapper) @@ -130,52 +130,79 @@ ++ [("currentTime", evaluated (VInt timestamp)) | not (epPureEval policy)] ++ [("currentSystem", evaluated (mkStr currentSystemStr)) | not (epPureEval policy)] +-- | The Nix release whose behaviour the evaluator matches, reported as +-- @builtins.nixVersion@. Upstream reports its own build's version +-- (@nixVersion@, globals.cc at 2.24.9), so an expression that branches on +-- the value takes the branch it takes on that release. +targetNixVersion :: Text +targetNixVersion = "2.24.9" + -- --------------------------------------------------------------------------- -- The derivation constant -- --------------------------------------------------------------------------- --- | Upstream's @src\/libexpr\/primops\/derivation.nix@ at 2.24.9, without its --- documentation comment. @derivation@ is this lambda, not a primop, so the --- result set has upstream's shape by construction: every output attribute --- is the complete derivation set for that output, @all@ lists them, --- @drvAttrs@ is the argument set, and @derivationStrict@ is reached only --- through @outPath@ and @drvPath@, which is what keeps forcing a derivation --- to WHNF from forcing any of its inputs. -derivationWrapperSource :: Text +-- | The source of @derivation@, a lambda over the @derivationStrict@ primop. +-- Its value is the set for the first output: the arguments, then one +-- attribute per output holding that output's set, then @all@ (the output +-- sets in the order @outputs@ lists them) and @drvAttrs@ (the arguments), +-- then the output's own @type@, @outputName@, @drvPath@ and @outPath@, a +-- later layer's attribute replacing an earlier one's of the same name. +-- @derivationStrict@ runs only when a @drvPath@ or @outPath@ is forced, so +-- forcing a derivation to WHNF forces the argument set and @outputs@ with +-- each name in it, and none of the other attributes. +-- +-- The rest is fixed by what a program can observe of upstream's wrapper, +-- which the parity job compares this one with: the formals, which +-- @functionArgs@ shows, and the name the @\@@ binds, which @toXML@ shows +-- too; @outputs@ forced by @map@, then @head@, then @listToAttrs@ over every +-- name, which decides the error a malformed list raises; and the arguments' +-- own values in the result, which @==@ shows for a function: upstream's +-- forces both sides, then takes one value as equal to itself (@eqValues@, +-- eval.cc at 2.24.9). nova-nix's @==@ takes a shared thunk as equal +-- without forcing it, which shows more of the sharing, so the wrapper also +-- shares what upstream's does: an output's set is one value in @all@, +-- under its name and as the result, and each output has a @drvPath@ of +-- its own. The attributes it defines are at this text's lines, which +-- differ from upstream's. Its identifiers differ too, and compiling it +-- interns them before any file a program imports, as upstream's startup +-- interns its wrapper's: an error that names attributes in interning order +-- (an unexpected argument, the keys of a set missing an attribute) can +-- name another first than upstream's identifiers would make it. +derivationWrapperSource :: ByteString derivationWrapperSource = - T.unlines - [ "drvAttrs @ { outputs ? [ \"out\" ], ... }:", - "", + BC.unlines + [ "{ outputs ? [ \"out\" ], ... }@drvAttrs:", "let", - "", - " strict = derivationStrict drvAttrs;", - "", - " commonAttrs = drvAttrs // (builtins.listToAttrs outputsList) //", - " { all = map (x: x.value) outputsList;", - " inherit drvAttrs;", + " paths = derivationStrict drvAttrs;", + " entries = map (outputName: {", + " name = outputName;", + " value = shared // {", + " type = \"derivation\";", + " inherit outputName;", + " drvPath = paths.drvPath;", + " outPath = builtins.getAttr outputName paths;", " };", - "", - " outputToAttrListElement = outputName:", - " { name = outputName;", - " value = commonAttrs // {", - " outPath = builtins.getAttr outputName strict;", - " drvPath = strict.drvPath;", - " type = \"derivation\";", - " inherit outputName;", - " };", + " }) outputs;", + " shared =", + " drvAttrs", + " // builtins.listToAttrs entries", + " // {", + " inherit drvAttrs;", + " all = map (entry: entry.value) entries;", " };", - "", - " outputsList = map outputToAttrListElement outputs;", - "", - "in (builtins.head outputsList).value" + "in", + "(builtins.head entries).value" ] --- | The name upstream gives the wrapper's source in error positions. -derivationWrapperName :: Text -derivationWrapperName = "derivation-internal.nix" +-- | Where the wrapper's source is: upstream evaluates its wrapper as the +-- file @derivation-internal.nix@ of an in-memory accessor +-- (@derivationInternal@, eval.cc at 2.24.9), and a position in this one +-- reports the same file, as its path there. +derivationWrapperOrigin :: SourceOrigin +derivationWrapperOrigin = SourceFile "/derivation-internal.nix" -- | The bindings the wrapper's free variables resolve to. Upstream evaluates --- the file in its base environment; this is the slice of that environment +-- its wrapper in its base environment; this is the slice of that environment -- the wrapper reads, so the constant needs no knot through 'builtinEnv'. -- The wrapper is bound against these names too, so it cannot read one the -- slice lacks. @@ -205,7 +232,7 @@ -- @derivation@ rather than as a crash while the environment is assembled. derivationWrapper :: Thunk derivationWrapper = - case parseNixWithScope (Map.keysSet derivationWrapperScope) "/" derivationWrapperName derivationWrapperSource of + case parseNixWithScope (Map.keysSet derivationWrapperScope) "/" derivationWrapperOrigin derivationWrapperSource of Right expr -> cheapThunk derivationWrapperEnv expr Left err -> abortingThunk ("the derivation wrapper does not parse: " <> T.pack (show err)) {-# NOINLINE derivationWrapper #-} diff --git a/src/Nix/Config.hs b/src/Nix/Config.hs --- a/src/Nix/Config.hs +++ b/src/Nix/Config.hs @@ -1,7 +1,9 @@ -- | Nix configuration: the @nix.conf@ / @NIX_CONFIG@ settings that decide -- which binary caches a machine substitutes from, which public keys it --- trusts, how deep function calls may nest, and how far an evaluation --- may reach (@restrict-eval@, @pure-eval@, @allowed-uris@). +-- trusts, whether a failed substitute builds from source (@fallback@), how +-- deep function calls may nest, how far an evaluation may reach +-- (@restrict-eval@, @pure-eval@, @allowed-uris@), and whether +-- @builtins.traceVerbose@ traces (@trace-verbose@). -- -- == The format -- @@ -144,6 +146,8 @@ data NixConfig = NixConfig { ncSubstituters :: ![Text], ncTrustedPublicKeys :: ![Text], + -- | Upstream @fallback@: build from source when a substitute fails. + ncFallback :: !Bool, -- | Upstream's @max-call-depth@: how many function calls may be -- active around a new one before evaluation refuses it. ncMaxCallDepth :: !Word32, @@ -152,26 +156,31 @@ -- | Upstream @restrict-eval@. ncRestrictEval :: !Bool, -- | Upstream @pure-eval@. - ncPureEval :: !Bool + ncPureEval :: !Bool, + -- | Upstream @trace-verbose@. + ncTraceVerbose :: !Bool } deriving (Eq, Show) -- | The baseline the fold starts from: no substituters, no trusted keys, --- upstream's call-depth ceiling, no allowed URIs, and both evaluation --- modes off. The empty substituter list is nova-nix's existing default --- (nothing is substituted unless configured), a deliberate divergence --- from upstream's cache.nixos.org default: turning a cache on for every --- machine is the operator's decision to make in a config file, not a --- built-in. The other defaults are upstream's own. +-- no fallback, upstream's call-depth ceiling, no allowed URIs, both +-- evaluation modes off, and @trace-verbose@ off. The empty substituter +-- list is nova-nix's existing default (nothing is substituted unless +-- configured), a deliberate divergence from upstream's cache.nixos.org +-- default: turning a cache on for every machine is the operator's +-- decision to make in a config file, not a built-in. The other defaults +-- are upstream's own. defaultNixConfig :: NixConfig defaultNixConfig = NixConfig { ncSubstituters = [], ncTrustedPublicKeys = [], + ncFallback = False, ncMaxCallDepth = defaultMaxCallDepth, ncAllowedUris = [], ncRestrictEval = False, - ncPureEval = False + ncPureEval = False, + ncTraceVerbose = False } -- --------------------------------------------------------------------------- @@ -533,7 +542,8 @@ -- | Apply one assignment to the accumulated config. The name is resolved -- through the aliases (@binary-caches@ -> @substituters@, --- @binary-cache-public-keys@ -> @trusted-public-keys@) and the @extra-@ +-- @binary-cache-public-keys@ -> @trusted-public-keys@, +-- @build-fallback@ -> @fallback@) and the @extra-@ -- prefix (append rather than replace, list settings only). A name -- outside the known set is ignored, not an error: upstream warns and -- continues, and refusing every unknown key would reject a config that @@ -583,8 +593,10 @@ | n == substitutersKey || n == substitutersAlias = Just (ListSetting SubstitutersField) | n == trustedKeysKey || n == trustedKeysAlias = Just (ListSetting TrustedKeysField) | n == allowedUrisKey = Just (ListSetting AllowedUrisField) + | n == fallbackKey || n == fallbackAlias = Just (BoolSetting FallbackField) | n == restrictEvalKey = Just (BoolSetting RestrictEvalField) | n == pureEvalKey = Just (BoolSetting PureEvalField) + | n == traceVerboseKey = Just (BoolSetting TraceVerboseField) | n == maxCallDepthKey = Just (ScalarSetting MaxCallDepthField) | otherwise = Nothing @@ -597,7 +609,7 @@ deriving (Eq, Show) -- | The Boolean settings. -data BoolField = RestrictEvalField | PureEvalField +data BoolField = FallbackField | RestrictEvalField | PureEvalField | TraceVerboseField deriving (Eq, Show) -- | The scalar settings, which only ever replace. @@ -624,8 +636,10 @@ listFieldKey AllowedUrisField = allowedUrisKey setBool :: BoolField -> Bool -> NixConfig -> NixConfig +setBool FallbackField v config = config {ncFallback = v} setBool RestrictEvalField v config = config {ncRestrictEval = v} setBool PureEvalField v config = config {ncPureEval = v} +setBool TraceVerboseField v config = config {ncTraceVerbose = v} -- | Upstream's Boolean spellings (@BaseSetting\::parse@): anything -- else is an error with upstream's wording, which names the setting alone, @@ -675,11 +689,16 @@ trustedKeysKey = "trusted-public-keys" trustedKeysAlias = "binary-cache-public-keys" -allowedUrisKey, maxCallDepthKey, pureEvalKey, restrictEvalKey :: ByteString +fallbackKey, fallbackAlias :: ByteString +fallbackKey = "fallback" +fallbackAlias = "build-fallback" + +allowedUrisKey, maxCallDepthKey, pureEvalKey, restrictEvalKey, traceVerboseKey :: ByteString allowedUrisKey = "allowed-uris" maxCallDepthKey = "max-call-depth" pureEvalKey = "pure-eval" restrictEvalKey = "restrict-eval" +traceVerboseKey = "trace-verbose" extraPrefix :: ByteString extraPrefix = "extra-" diff --git a/src/Nix/DependencyGraph.hs b/src/Nix/DependencyGraph.hs --- a/src/Nix/DependencyGraph.hs +++ b/src/Nix/DependencyGraph.hs @@ -1,9 +1,8 @@ -- | Dependency graph construction and topological sorting. -- -- Given a root derivation, builds a graph of all transitive --- dependencies by reading .drv files from the store. The graph --- is then topologically sorted so dependencies are built before --- their dependents. +-- dependencies by reading .drv files from the store. 'topoSort' orders it +-- leaves first and refuses a cycle. module Nix.DependencyGraph ( -- * Types DepNode (..), diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -9,7 +9,7 @@ -- Function arguments are likewise thunked - @(x: 1) (throw "boom")@ -- returns @1@ because @x@ is never referenced. -- --- The evaluator maintains an environment ('Env') that maps variable +-- The evaluator maintains an environment, a t'Env', that maps variable -- names to thunks. @let@, @with@, function application, and -- recursive attribute sets all extend the environment. -- @@ -22,6 +22,7 @@ module Nix.Eval ( -- * Values (re-exported from Types) NixValue (..), + BuiltinArg (..), CompiledRegex (..), Thunk (..), @@ -75,6 +76,10 @@ checkGitRev, gitInputUrl, + -- * What a fetch hands its tool (exported for tests) + localFileUrl, + gitRemote, + -- * Remembered fetches (pure, exported for tests) FetchCache (..), fetchCacheKey, @@ -83,6 +88,7 @@ -- * Builtin registry BuiltinDef (..), + ArgMode (..), builtinRegistry, builtinNames, @@ -104,6 +110,7 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Int (Int64) import Data.List (partition, sort, sortOn) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) @@ -130,12 +137,15 @@ import Nix.Eval.Compile (BcAttrKey (..), BcBinding (..), BcInheritedName (..), compileExpr, decodeBcBindings, decodeBcCaptureInfo, decodeBcFormals, reassembleDouble, reassembleInt64) import Nix.Eval.Context (contextIsEmpty, extractAllOutputRefs, extractInputDrvs, extractInputSrcs, firstContextEncoded, plainContext) import Nix.Eval.Operator (addToFloat, addToInteger, evalBinary, evalUnary, evalUpdate, expectInt, nixCompare, nixEqual, primAdd, primDiv, primMul, primSub) -import Nix.Eval.Policy (isAbsolutePath) +import Nix.Eval.Policy (fileUrlPrefix, isAbsolutePath) import Nix.Eval.Print (PrintOptions (..), formatXmlFloat, printValue) +import Nix.Eval.SourcePos (RecordedPos (..), lookupPos) import Nix.Eval.StringInterp (StringChunk (..), coerceToString, concatChunks, formatNixFloat, stripIndentedChunks) import Nix.Eval.Symbol (Symbol (..), symbolBytes, symbolText) import Nix.Eval.Types - ( AttrSet (..), + ( AttrEntry (..), + AttrSet (..), + BuiltinArg (..), CAttrSet, CompiledRegex (..), Env (..), @@ -151,9 +161,11 @@ Thunk (..), allocCSlots, attrSetElems, + attrSetFromEntries, attrSetFromMap, attrSetKeys, attrSetLookup, + attrSetLookupEntry, attrSetMapWithKey, attrSetMember, attrSetNull, @@ -554,7 +566,7 @@ -- | Evaluate string parts from the bytecode data buffer. Each part is two -- words: (tag, value), a symbol under 'strpartLit' or 'strpartEsc' and a --- bytecode index under 'strpartInterp'. The kind survives into the chunk +-- bytecode index under 'Nix.Eval.CBytecode.strpartInterp'. The kind survives into the chunk -- because an indented string strips an escape and an interpolation -- differently. evalBcStringParts :: (MonadEval m) => Env -> Int -> Word32 -> m [StringChunk] @@ -604,19 +616,17 @@ -- | Apply an evaluated function to the argument at a bytecode index, -- inside the caller's frame. The argument stays a thunk for a lambda --- (the normal laziness) and is forced for a builtin, which forces anyway. +-- (the normal laziness). A builtin takes it evaluated, without a thunk, +-- or as a thunk, by its mode for the position. callBc :: (MonadEval m) => Env -> Word32 -> NixValue -> m NixValue callBc env argIdx funcVal = case funcVal of VLambda closureEnv formals bodyBcIdx -> do let argThunk = cheapThunkBc env argIdx extEnv <- matchFormals closureEnv formals argThunk evalBytecode extEnv bodyBcIdx - VBuiltin "tryEval" [] -> tryEvalAction (evalBytecode env argIdx) - VBuiltin name [first] - | Just finishFirst <- beforeSecondArgument name first -> finishFirst >> evalBytecode env argIdx - VBuiltin name accArgs -> do - argVal <- evalBytecode env argIdx - applyBuiltin name accArgs argVal + VBuiltin name taken -> applyBuiltin name taken $ \case + ForceOnApply -> ArgForced <$> evalBytecode env argIdx + ForceOnUse -> pure (ArgDeferred (cheapThunkBc env argIdx)) VAttrs attrs | Just functorThunk <- attrSetLookup "__functor" attrs -> do functor <- force functorThunk @@ -628,17 +638,15 @@ withCallFrame (callBc env argIdx partiallyApplied) _ -> throwEvalError ("attempt to call " <> typeName funcVal <> ", which is not a function") --- | @builtins.tryEval@ over an argument's evaluation: @{ success, value }@ --- with catchable errors (throw, failed assert - the only kinds --- 'catchEvalError' recovers) mapped to @success = false@. The catch must --- wrap the ARGUMENT'S EVALUATION: an application path that forces the --- argument before dispatching here has already let the throw escape. --- Callers holding an already-forced value pass @pure val@ - nothing left --- to catch, so it success-wraps, exactly as upstream treats a value in --- WHNF. -tryEvalAction :: (MonadEval m) => m NixValue -> m NixValue -tryEvalAction act = do - result <- catchEvalError act +-- | @builtins.tryEval e@: @{ success, value }@ with catchable errors +-- (throw, failed assert - the only kinds 'catchEvalError' recovers) +-- mapped to @success = false@. The catch must wrap the argument's +-- forcing, so the argument is taken unforced. One that arrives already +-- forced has nothing left to catch and is success-wrapped, as upstream +-- treats a value in WHNF. +builtinTryEval :: (MonadEval m) => BuiltinArg -> m NixValue +builtinTryEval arg = do + result <- catchEvalError (argValue arg) pure $ case result of Right val -> VAttrs @@ -784,8 +792,8 @@ -- frame and cannot make the same shortcut. evalBcNonRecAttrs :: (MonadEval m) => Env -> [BcBinding] -> m NixValue evalBcNonRecAttrs env bindings = do - thunkMap <- buildBcThunkMap cheapThunkBc env env bindings - pure (VAttrs (attrSetFromMap thunkMap)) + entries <- buildBcEntryMap cheapThunkBc env env bindings + pure (VAttrs (attrSetFromEntries entries)) -- | Build a let\/rec frame env, sharing the parent-chain and with-scope -- plumbing otherwise repeated across the positional and dynamic paths. The @@ -811,8 +819,8 @@ recEnv = newFrameEnv env captureInfo slotsPtr slotCount Nothing thunkList = buildBcSlotThunks recEnv env bindings filled = fillCSlots slotsPtr thunkList - attrMap = buildBcAttrMapFromSlots bindings thunkList - in filled `seq` pure (VAttrs (attrSetFromMap attrMap)) + entries = buildBcEntryMapFromSlots bindings thunkList + in filled `seq` pure (VAttrs (attrSetFromEntries entries)) | otherwise = do -- Dynamic-key path: the set has a ${dynamic} key, so names are not all -- known at compile time. Not a corner-cutting fallback: @@ -824,18 +832,14 @@ let scopeCset = buildCAttrSetKeys (bcBindingStaticKeys bindings) recEnv = newFrameEnv env captureInfo nullPtr 0 (Just (AttrSet scopeCset)) (staticBs, dynBs) = partition bcBindingIsStatic bindings - staticThunks <- buildBcThunkMap mkThunkBc recEnv env staticBs - let scopeFilled = fillCAttrSetValues scopeCset staticThunks - dynThunks <- scopeFilled `seq` buildBcThunkMap mkThunkBc recEnv env dynBs + staticEntries <- buildBcEntryMap mkThunkBc recEnv env staticBs + let scopeFilled = fillCAttrSetValues scopeCset (Map.map entryThunk staticEntries) + dynEntries <- scopeFilled `seq` buildBcEntryMap mkThunkBc recEnv env dynBs -- A dynamic key colliding with a static sibling is an eval error -- upstream ("dynamic attribute already defined"), never a merge. - case Map.keys (Map.intersection dynThunks staticThunks) of + case Map.keys (Map.intersection dynEntries staticEntries) of (dupKey : _) -> throwEvalError ("dynamic attribute '" <> dupKey <> "' already defined") - [] -> - let allThunks = Map.union dynThunks staticThunks - resultCset = buildCAttrSetKeys (Map.keys allThunks) - filled = fillCAttrSetValues resultCset allThunks - in filled `seq` pure (VAttrs (AttrSet resultCset)) + [] -> pure (VAttrs (attrSetFromEntries (Map.union dynEntries staticEntries))) -- | Evaluate a let expression from bytecode. evalBcLet :: (MonadEval m) => Env -> Word32 -> m NixValue @@ -861,27 +865,27 @@ -- the body also sees. let cset = buildCAttrSetKeys (bcBindingStaticKeys bindings) letEnv = newFrameEnv env captureInfo nullPtr 0 (Just (AttrSet cset)) - thunkMap <- buildBcThunkMap mkThunkBc letEnv env bindings - let filled = fillCAttrSetValues cset thunkMap + entries <- buildBcEntryMap mkThunkBc letEnv env bindings + let filled = fillCAttrSetValues cset (Map.map entryThunk entries) in filled `seq` evalBytecode letEnv bodyIdx -- | Check if all bytecode bindings are static keys (eligible for positional). --- Must stay in sync with 'allStaticSingleKey' in 'Nix.Expr.Resolve'. +-- Must stay in sync with @allStaticSingleKey@ in "Nix.Expr.Resolve". allBcPositional :: [BcBinding] -> Bool allBcPositional = all isEligible where - isEligible (BcNamed (BcStaticKey _) _) = True - isEligible (BcInherit _ _) = True + isEligible (BcNamed _ (BcStaticKey _) _) = True + isEligible (BcInherit {}) = True isEligible (BcInheritFrom _ _) = True isEligible _ = False -- | Count positional slots for bytecode bindings. --- Must stay in sync with 'lexicalScopeFromBindings' in 'Nix.Expr.Resolve'. +-- Must stay in sync with @lexicalScopeFromBindings@ in "Nix.Expr.Resolve". bcBindingSlotCount :: [BcBinding] -> Int bcBindingSlotCount = foldl' countOne 0 where - countOne !acc (BcNamed (BcStaticKey _) _) = acc + 1 - countOne !acc (BcInherit _ _) = acc + 1 + countOne !acc (BcNamed _ (BcStaticKey _) _) = acc + 1 + countOne !acc (BcInherit {}) = acc + 1 countOne !acc (BcInheritFrom _ names) = acc + length names countOne !acc _ = acc @@ -893,15 +897,15 @@ buildBcSlotThunks :: Env -> Env -> [BcBinding] -> [Thunk] buildBcSlotThunks recEnv outerEnv = concatMap slotThunk where - slotThunk (BcNamed (BcStaticKey _) valBcIdx) = + slotThunk (BcNamed _ (BcStaticKey _) valBcIdx) = [mkThunkBc recEnv valBcIdx] - slotThunk (BcInherit _ valBcIdx) = + slotThunk (BcInherit _ _ valBcIdx) = [cheapThunkBc outerEnv valBcIdx] slotThunk (BcInheritFrom fromBcIdx names) = -- inherit (from) x y z; becomes one thunk per name that selects from the from-expr. -- Each thunk gets a minimal env with the from-value at slot 0. let fromThunk = mkThunkBc recEnv fromBcIdx - mkInheritThunk (BcInheritedName _ selectBcIdx) = + mkInheritThunk (BcInheritedName _ _ selectBcIdx) = let (sp, sc) = buildCSlots [fromThunk] fromEnv = newMinimalEnv sp sc in mkSyntheticThunk fromEnv selectBcIdx @@ -909,24 +913,25 @@ -- Unreachable: allBcPositional guards this path. slotThunk _ = [] --- | Build attr map from slots for positional bytecode bindings. -buildBcAttrMapFromSlots :: [BcBinding] -> [Thunk] -> Map Text Thunk -buildBcAttrMapFromSlots bindings thunks = go bindings thunks Map.empty +-- | Build the attribute map from slots for positional bytecode bindings, +-- each at its binding's position. +buildBcEntryMapFromSlots :: [BcBinding] -> [Thunk] -> Map Text AttrEntry +buildBcEntryMapFromSlots bindings thunks = go bindings thunks Map.empty where go [] _ !acc = acc - go (BcNamed (BcStaticKey sym) _ : bs) (t : ts) !acc = - go bs ts (Map.insert (symbolText (Symbol sym)) t acc) - go (BcInherit sym _ : bs) (t : ts) !acc = - go bs ts (Map.insert (symbolText (Symbol sym)) t acc) + go (BcNamed pos (BcStaticKey sym) _ : bs) (t : ts) !acc = + go bs ts (Map.insert (symbolText (Symbol sym)) (AttrEntry pos t) acc) + go (BcInherit pos sym _ : bs) (t : ts) !acc = + go bs ts (Map.insert (symbolText (Symbol sym)) (AttrEntry pos t) acc) go (BcInheritFrom _ names : bs) ts !acc = let (used, rest) = splitAt (length names) ts - accMerged = foldl' (\a (name, t0) -> Map.insert (inheritedNameText name) t0 a) acc (zip names used) - in go bs rest accMerged + insertName a (inherited@(BcInheritedName pos _ _), t0) = Map.insert (inheritedNameText inherited) (AttrEntry pos t0) a + in go bs rest (foldl' insertName acc (zip names used)) -- Unreachable: allBcPositional guards this path. go (_ : bs) ts !acc = go bs ts acc --- | Build thunk map for bytecode attrs (non-rec or fallback rec path). --- | Build the name-to-thunk map for a set of bindings. +-- | Build the name-to-attribute map for a set of bindings, each at its +-- binding's position. -- -- How a value becomes a thunk is the caller's decision: a non-recursive -- attr set can resolve constants and in-scope variables immediately, while a @@ -934,32 +939,32 @@ -- the variables point at are not filled yet. An inherited variable is read -- from @outerEnv@, the env around the binding set, which is always built -- (for a non-recursive set it is @thunkEnv@ itself). -buildBcThunkMap :: (MonadEval m) => (Env -> Word32 -> Thunk) -> Env -> Env -> [BcBinding] -> m (Map Text Thunk) -buildBcThunkMap mkValueThunk thunkEnv outerEnv = foldM addBinding Map.empty +buildBcEntryMap :: (MonadEval m) => (Env -> Word32 -> Thunk) -> Env -> Env -> [BcBinding] -> m (Map Text AttrEntry) +buildBcEntryMap mkValueThunk thunkEnv outerEnv = foldM addBinding Map.empty where - addBinding acc (BcNamed bcKey valBcIdx) = do + addBinding acc (BcNamed pos bcKey valBcIdx) = do resolved <- resolveBcKey thunkEnv bcKey case resolved of Nothing -> pure acc -- null key -> skip - Just key -> insertChecked acc key (mkValueThunk thunkEnv valBcIdx) - addBinding acc (BcInherit sym valBcIdx) = - insertChecked acc (symbolText (Symbol sym)) (cheapThunkBc outerEnv valBcIdx) + Just key -> insertChecked acc key (AttrEntry pos (mkValueThunk thunkEnv valBcIdx)) + addBinding acc (BcInherit pos sym valBcIdx) = + insertChecked acc (symbolText (Symbol sym)) (AttrEntry pos (cheapThunkBc outerEnv valBcIdx)) addBinding acc (BcInheritFrom fromBcIdx names) = -- inherit (from) name selects name from the from-expr. -- Create a small env with the from value at slot 0, then run the -- select the compiler made for name against it. - let addInheritFrom a inherited@(BcInheritedName _ selectBcIdx) = + let addInheritFrom a inherited@(BcInheritedName pos _ selectBcIdx) = let (sp, sc) = buildCSlots [mkThunkBc thunkEnv fromBcIdx] fromEnv = newMinimalEnv sp sc - in insertChecked a (inheritedNameText inherited) (mkSyntheticThunk fromEnv selectBcIdx) + in insertChecked a (inheritedNameText inherited) (AttrEntry pos (mkSyntheticThunk fromEnv selectBcIdx)) in foldM addInheritFrom acc names -- The parser normalizes static keys to appear exactly once, so a -- collision here means an evaluated DYNAMIC key hit an existing -- attr - an eval error upstream, never a silent merge. - insertChecked acc key thunk = + insertChecked acc key entry = case Map.lookup key acc of - Nothing -> pure (Map.insert key thunk acc) + Nothing -> pure (Map.insert key entry acc) Just _ -> throwEvalError ("dynamic attribute '" <> key <> "' already defined") -- | Resolve a bytecode attr key to text. @@ -980,22 +985,22 @@ bcBindingStaticKeys :: [BcBinding] -> [Text] bcBindingStaticKeys = concatMap oneBinding where - oneBinding (BcNamed (BcStaticKey sym) _) = [symbolText (Symbol sym)] - oneBinding (BcNamed _ _) = [] - oneBinding (BcInherit sym _) = [symbolText (Symbol sym)] + oneBinding (BcNamed _ (BcStaticKey sym) _) = [symbolText (Symbol sym)] + oneBinding (BcNamed {}) = [] + oneBinding (BcInherit _ sym _) = [symbolText (Symbol sym)] oneBinding (BcInheritFrom _ names) = map inheritedNameText names -- | The attribute name an @inherit (from)@ binds. inheritedNameText :: BcInheritedName -> Text -inheritedNameText (BcInheritedName sym _) = symbolText (Symbol sym) +inheritedNameText (BcInheritedName _ sym _) = symbolText (Symbol sym) -- | True when a binding's top-level key is known statically (a static key or an -- inherit). These bindings populate the rec env's name table (C++ Nix's env2); -- a binding with a dynamic top-level key does not - it is added to the value. bcBindingIsStatic :: BcBinding -> Bool -bcBindingIsStatic (BcNamed (BcStaticKey _) _) = True -bcBindingIsStatic (BcNamed _ _) = False -bcBindingIsStatic (BcInherit _ _) = True +bcBindingIsStatic (BcNamed _ (BcStaticKey _) _) = True +bcBindingIsStatic (BcNamed {}) = False +bcBindingIsStatic (BcInherit {}) = True bcBindingIsStatic (BcInheritFrom _ _) = True -- --------------------------------------------------------------------------- @@ -1043,8 +1048,9 @@ -- | Evaluate a with-scoped variable: check with-scopes first (innermost -- to outermost), then fall back to the standard name-based lookup -- (parent chain to builtins). For trimmed envs ('CapturesWithScopes'), --- the root scope is already appended to 'envWithScopes' so the --- with-scope lookup finds builtins without needing a parent chain. +-- the root scope is already appended to the env's with-scopes +-- ('envWithScopesRaw'), so the with-scope lookup finds builtins without +-- needing a parent chain. -- Supports both resolved (CAttrSet*) and lazy (CThunk*, tagged with bit 0) -- with-scope entries. Lazy entries are forced on first lookup and the -- pointer is updated in place so subsequent lookups hit the resolved @@ -1192,20 +1198,107 @@ -- Builtin registry (single-definition-site for all builtins) -- --------------------------------------------------------------------------- --- | A builtin function definition: its arity and implementation. +-- | How a builtin takes the argument at one position. +data ArgMode + = -- | Forced as it is applied, for a primop that forces it before + -- anything it does can be observed. That matches upstream once the + -- primop has every argument; a partial application forces it sooner + -- than upstream, which forces nothing before the last argument. + ForceOnApply + | -- | Held as a thunk, for a primop that forces it later than that: + -- after a later argument, around a catch, or only on some paths. + -- The builtin forces it where upstream does. + ForceOnUse + deriving (Eq, Show) + +-- | A builtin's shape: how it takes each argument, first to last (the +-- arity is the length), and its implementation over the arguments taken. +-- Each shape below defines both together, and its implementation type +-- marks a 'ForceOnUse' position with a 'BuiltinArg' parameter, so an +-- implementation's type picks the same shape in the registry and in +-- 'executeBuiltin'. data BuiltinDef m = BuiltinDef - { bdArity :: !Int, - bdApply :: [NixValue] -> m NixValue + { bdArgs :: !(NonEmpty ArgMode), + bdApply :: [BuiltinArg] -> m NixValue } +-- | The value of an argument a builtin has taken, forcing it if it was +-- held unforced. +argValue :: (MonadEval m) => BuiltinArg -> m NixValue +argValue (ArgForced val) = pure val +argValue (ArgDeferred thunk) = force thunk + +-- | An argument a builtin has taken, as a thunk to share, such as the +-- function every element of @map@'s result applies. +argAsThunk :: BuiltinArg -> Thunk +argAsThunk (ArgForced val) = evaluated val +argAsThunk (ArgDeferred thunk) = thunk + +-- | The failure of a builtin run with arguments that do not fit its +-- shape, which 'applyBuiltin' never builds: it runs a builtin at its last +-- position, and every caller supplies a 'ForceOnApply' position as +-- 'ArgForced'. +arityError :: (MonadEval m) => Text -> m a +arityError name = throwEvalError ("builtins." <> name <> ": internal arity error") + +-- | One argument, forced as it is applied. +forced1 :: (MonadEval m) => (NixValue -> m NixValue) -> Text -> BuiltinDef m +forced1 f name = BuiltinDef (ForceOnApply :| []) $ \case + [ArgForced a] -> f a + _ -> arityError name + +-- | Two arguments, each forced as it is applied. +forced2 :: (MonadEval m) => (NixValue -> NixValue -> m NixValue) -> Text -> BuiltinDef m +forced2 f name = BuiltinDef (ForceOnApply :| [ForceOnApply]) $ \case + [ArgForced a, ArgForced b] -> f a b + _ -> arityError name + +-- | Three arguments, each forced as it is applied. +forced3 :: (MonadEval m) => (NixValue -> NixValue -> NixValue -> m NixValue) -> Text -> BuiltinDef m +forced3 f name = BuiltinDef (ForceOnApply :| [ForceOnApply, ForceOnApply]) $ \case + [ArgForced a, ArgForced b, ArgForced c] -> f a b c + _ -> arityError name + +-- | One argument, held unforced. +onUse1 :: (MonadEval m) => (BuiltinArg -> m NixValue) -> Text -> BuiltinDef m +onUse1 f name = BuiltinDef (ForceOnUse :| []) $ \case + [a] -> f a + _ -> arityError name + +-- | Two arguments, both held unforced. +onUse2 :: (MonadEval m) => (BuiltinArg -> BuiltinArg -> m NixValue) -> Text -> BuiltinDef m +onUse2 f name = BuiltinDef (ForceOnUse :| [ForceOnUse]) $ \case + [a, b] -> f a b + _ -> arityError name + +-- | Two arguments, the first held unforced and the second forced as it +-- is applied. +onUseFirst :: (MonadEval m) => (BuiltinArg -> NixValue -> m NixValue) -> Text -> BuiltinDef m +onUseFirst f name = BuiltinDef (ForceOnUse :| [ForceOnApply]) $ \case + [a, ArgForced b] -> f a b + _ -> arityError name + +-- | Two arguments, the first forced as it is applied and the second held +-- unforced. +onUseSecond :: (MonadEval m) => (NixValue -> BuiltinArg -> m NixValue) -> Text -> BuiltinDef m +onUseSecond f name = BuiltinDef (ForceOnApply :| [ForceOnUse]) $ \case + [ArgForced a, b] -> f a b + _ -> arityError name + +-- | Three arguments, the middle one held unforced and the others forced +-- as they are applied. +onUseMiddle :: (MonadEval m) => (NixValue -> BuiltinArg -> NixValue -> m NixValue) -> Text -> BuiltinDef m +onUseMiddle f name = BuiltinDef (ForceOnApply :| [ForceOnUse, ForceOnApply]) $ \case + [ArgForced a, b, ArgForced c] -> f a b c + _ -> arityError name + +-- | A registry entry of the given shape. +builtinShaped :: Text -> (Text -> BuiltinDef m) -> (Text, BuiltinDef m) +builtinShaped name shape = (name, shape name) + -- | Define an arity-1 builtin. builtin1 :: (MonadEval m) => Text -> (NixValue -> m NixValue) -> (Text, BuiltinDef m) -builtin1 name f = - ( name, - BuiltinDef 1 $ \case - [a] -> f a - _ -> throwEvalError ("builtins." <> name <> ": internal arity error") - ) +builtin1 name = builtinShaped name . forced1 -- | Define an arity-2 builtin. builtin2 :: @@ -1213,12 +1306,7 @@ Text -> (NixValue -> NixValue -> m NixValue) -> (Text, BuiltinDef m) -builtin2 name f = - ( name, - BuiltinDef 2 $ \case - [a, b] -> f a b - _ -> throwEvalError ("builtins." <> name <> ": internal arity error") - ) +builtin2 name = builtinShaped name . forced2 -- | Define an arity-3 builtin. builtin3 :: @@ -1226,15 +1314,11 @@ Text -> (NixValue -> NixValue -> NixValue -> m NixValue) -> (Text, BuiltinDef m) -builtin3 name f = - ( name, - BuiltinDef 3 $ \case - [a, b, c] -> f a b c - _ -> throwEvalError ("builtins." <> name <> ": internal arity error") - ) +builtin3 name = builtinShaped name . forced3 --- | Central registry of all builtins. Adding a new builtin is a single --- entry here plus its implementation function - no other files need changes. +-- | Central registry of all builtins: the source of 'builtinNames' and of +-- each builtin's argument modes. A new builtin is an entry here and a +-- case in 'executeBuiltin' that uses the same shape. builtinRegistry :: (MonadEval m) => Map Text (BuiltinDef m) builtinRegistry = Map.fromList @@ -1269,29 +1353,29 @@ builtin2 "intersectAttrs" builtinIntersectAttrs, builtin2 "catAttrs" builtinCatAttrs, -- List higher-order (arity 2) - builtin2 "map" builtinMap, - builtin2 "filter" builtinFilter, - builtin2 "genList" builtinGenList, - builtin2 "sort" builtinSort, + builtinShaped "map" (onUseFirst builtinMap), + builtinShaped "filter" (onUseFirst builtinFilter), + builtinShaped "genList" (onUseFirst builtinGenList), + builtinShaped "sort" (onUseFirst builtinSort), builtin2 "concatMap" builtinConcatMap, builtin2 "any" builtinAny, builtin2 "all" builtinAll, - builtin2 "elem" builtinElem, - builtin2 "elemAt" builtinElemAt, + builtinShaped "elem" (onUseFirst builtinElem), + builtinShaped "elemAt" (onUseFirst builtinElemAt), builtin2 "partition" builtinPartition, builtin2 "groupBy" builtinGroupBy, -- String operations (arity 2) builtin2 "concatStringsSep" builtinConcatStringsSep, -- Arity 3 - builtin3 "foldl'" builtinFoldl, + builtinShaped "foldl'" (onUseMiddle builtinFoldl), builtin3 "substring" builtinSubstring, -- Numeric builtin1 "isPath" (pure . VBool . isPathVal), builtin1 "ceil" builtinCeil, builtin1 "floor" builtinFloor, builtin2 "seq" builtinSeq, - builtin2 "trace" builtinTrace, - builtin2 "warn" builtinWarn, + builtinShaped "trace" (onUseSecond builtinTrace), + builtinShaped "warn" (onUseSecond builtinWarn), builtin1 "unsafeDiscardStringContext" builtinDiscardContext, builtin1 "unsafeDiscardOutputDependency" builtinDiscardOutputDep, builtin1 "addDrvOutputDependencies" builtinAddDrvOutputDeps, @@ -1312,7 +1396,7 @@ builtin2 "bitOr" (bitwise (.|.)), builtin2 "bitXor" (bitwise xor), -- Attr set higher-order - builtin2 "mapAttrs" builtinMapAttrs, + builtinShaped "mapAttrs" (onUseFirst builtinMapAttrs), builtin1 "functionArgs" builtinFunctionArgs, builtin2 "zipAttrsWith" builtinZipAttrsWith, -- String manipulation @@ -1327,11 +1411,8 @@ builtin1 "fromJSON" builtinFromJSON, builtin2 "hashString" builtinHashString, -- Error handling + sequencing - -- An argument reaching here is already forced (any throw happened - -- before tryEval saw it), so it success-wraps; the catching paths - -- are evalBcApp and applyValueLazy. - builtin1 "tryEval" (tryEvalAction . pure), - builtin2 "deepSeq" builtinDeepSeq, + builtinShaped "tryEval" (onUse1 builtinTryEval), + builtinShaped "deepSeq" (onUseSecond builtinDeepSeq), -- Graph traversal builtin1 "genericClosure" builtinGenericClosure, -- IO builtins (delegate to MonadEval methods) @@ -1346,21 +1427,21 @@ builtin1 "storePath" builtinStorePath, builtin2 "findFile" builtinFindFile, builtin2 "toFile" builtinToFile, - builtin2 "scopedImport" builtinScopedImport, + builtinShaped "scopedImport" (onUseFirst builtinScopedImport), -- Network fetchers builtin1 "fetchurl" builtinFetchurl, builtin1 "fetchTarball" builtinFetchTarball, builtin1 "fetchGit" builtinFetchGit, -- Derivation construction. The lazy 'derivation' wrapper is not a - -- primop: it is upstream's derivation.nix, bound as a constant by + -- primop: it is a Nix lambda over this one, bound as a constant by -- "Nix.Builtins". builtin1 "derivationStrict" builtinDerivationStrict, -- Error context (pass-through - context only matters on error) builtin2 "addErrorContext" (\_ val -> pure val), - -- Attr position (return null - nixpkgs handles this gracefully) - builtin2 "unsafeGetAttrPos" (\_ _ -> pure VNull), - -- Debugging (traceVerbose: same as trace for now, --trace-verbose not yet gated) - builtin2 "traceVerbose" builtinTrace, + -- Attr position + builtinShaped "unsafeGetAttrPos" (onUseSecond builtinUnsafeGetAttrPos), + -- Debugging + builtinShaped "traceVerbose" (onUse2 builtinTraceVerbose), builtin1 "break" pure, -- IO: file hashing + type detection builtin2 "hashFile" builtinHashFile, @@ -1373,7 +1454,7 @@ builtin1 "toXML" builtinToXML, -- Source filtering + path import builtin1 "path" builtinPath, - builtin2 "filterSource" builtinFilterSource, + builtinShaped "filterSource" (onUseFirst builtinFilterSource), -- Experimental feature stubs builtin2 "outputOf" builtinOutputOf, builtin1 "fetchTree" builtinFetchTree, @@ -1388,19 +1469,30 @@ -- Builtin dispatch (partial application via accumulated args) -- --------------------------------------------------------------------------- --- | Arity of a builtin (how many arguments before execution). -builtinArity :: Text -> Int -builtinArity name = maybe 1 bdArity (Map.lookup name (builtinRegistry :: Map Text (BuiltinDef PureEval))) +-- | How a builtin takes each argument, first to last. A name the +-- registry does not hold takes one argument, so applying it runs it and +-- 'executeBuiltin' reports it unknown. +builtinArgModes :: Text -> NonEmpty ArgMode +builtinArgModes name = maybe (ForceOnApply :| []) bdArgs (Map.lookup name (builtinRegistry :: Map Text (BuiltinDef PureEval))) --- | Apply a builtin with accumulated args. If we have enough args, --- execute; otherwise return a partially applied builtin. -applyBuiltin :: (MonadEval m) => Text -> [NixValue] -> NixValue -> m NixValue -applyBuiltin name accArgs arg = - let allArgs = accArgs ++ [arg] - arity = builtinArity name - in if length allArgs < arity - then pure (VBuiltin name (precompileArgs name allArgs)) - else executeBuiltin name allArgs +-- | Apply a builtin, holding the arguments it has taken, to one more. +-- The caller supplies the argument as the builtin's mode for its +-- position asks: forced, or as a thunk. The last position runs the +-- builtin; an earlier one makes the partial application. Inlined into +-- each application site, which measurably cuts allocation on this path. +applyBuiltin :: (MonadEval m) => Text -> [BuiltinArg] -> (ArgMode -> m BuiltinArg) -> m NixValue +applyBuiltin name taken takeArg = case builtinArgModes name of + first :| later -> nextPosition taken first later + where + nextPosition [] mode later = do + arg <- takeArg mode + let held = taken ++ [arg] + if null later + then executeBuiltin name held + else pure (VBuiltin name (precompileArgs name held)) + nextPosition (_ : before) _ (mode : later) = nextPosition before mode later + nextPosition (_ : _) _ [] = arityError name +{-# INLINE applyBuiltin #-} -- | Pre-compile regex patterns at partial application time. -- When builtins.match or builtins.split receives its first argument @@ -1411,17 +1503,17 @@ -- the RAW pattern: match's whole-string requirement is a span check at -- match time, not textual @^...$@ anchoring, which would misparse a -- top-level alternation (@^a|b$@ is @(^a)|(b$)@). -precompileArgs :: Text -> [NixValue] -> [NixValue] -precompileArgs "match" [VStr pat _] = compiledRegexArg pat -precompileArgs "split" [VStr pat _] = compiledRegexArg pat +precompileArgs :: Text -> [BuiltinArg] -> [BuiltinArg] +precompileArgs "match" [ArgForced (VStr pat _)] = compiledRegexArg pat +precompileArgs "split" [ArgForced (VStr pat _)] = compiledRegexArg pat precompileArgs _ args = args -- | The single-element arg list for a regex builtin: the compiled pattern -- if valid, the raw string otherwise (the error surfaces at execute time). -compiledRegexArg :: BS.ByteString -> [NixValue] +compiledRegexArg :: BS.ByteString -> [BuiltinArg] compiledRegexArg pat = case cachedCompileRegex pat of - Just compiled -> [VCompiledRegex (CompiledRegex pat compiled)] - Nothing -> [VStr pat emptyContext] + Just compiled -> [ArgForced (VCompiledRegex (CompiledRegex pat compiled))] + Nothing -> [ArgForced (VStr pat emptyContext)] -- | Apply a function value (lambda or builtin) to one argument, in a call -- frame of its own. Used by higher-order builtins to invoke @@ -1434,8 +1526,8 @@ applyForced (VLambda closureEnv formals bodyBcIdx) arg = do extEnv <- matchFormals closureEnv formals (evaluated arg) evalBytecode extEnv bodyBcIdx -applyForced (VBuiltin name accArgs) arg = - applyBuiltin name accArgs arg +applyForced (VBuiltin name taken) arg = + applyBuiltin name taken (const (pure (ArgForced arg))) applyForced other _ = throwEvalError ("attempt to call " <> typeName other <> ", which is not a function") @@ -1443,9 +1535,8 @@ -- higher-order list builtins (filter, any, all, partition, groupBy, -- foldl') pass elements as unforced values, so an element the function -- never inspects may contain a throw without failing the call. A --- builtin callee still receives a forced value (builtins force their --- arguments regardless), and set-pattern formals force on destructuring --- exactly as upstream does. +-- builtin callee takes it by its mode for the position, and set-pattern +-- formals force on destructuring exactly as upstream does. applyValueLazy :: (MonadEval m) => NixValue -> Thunk -> m NixValue applyValueLazy fun argThunk = withCallFrame (applyUnforced fun argThunk) @@ -1454,23 +1545,27 @@ applyUnforced (VLambda closureEnv formals bodyBcIdx) argThunk = do extEnv <- matchFormals closureEnv formals argThunk evalBytecode extEnv bodyBcIdx --- tryEval's catch must wrap the argument's forcing (see 'tryEvalAction'): --- map/filter passing a throwing element to tryEval yields success = false, --- not an escaped error. -applyUnforced (VBuiltin "tryEval" []) argThunk = tryEvalAction (force argThunk) -applyUnforced (VBuiltin name [first]) argThunk - | Just finishFirst <- beforeSecondArgument name first = finishFirst >> force argThunk +applyUnforced (VBuiltin name taken) argThunk = applyBuiltin name taken $ \case + ForceOnApply -> ArgForced <$> force argThunk + ForceOnUse -> pure (ArgDeferred argThunk) applyUnforced other argThunk = do val <- force argThunk applyForced other val +-- | Apply a function value to an argument a builtin has taken: forced, +-- or as the thunk it was held as. +applyArg :: (MonadEval m) => NixValue -> BuiltinArg -> m NixValue +applyArg fun (ArgForced val) = applyValue fun val +applyArg fun (ArgDeferred thunk) = applyValueLazy fun thunk + -- | Execute a builtin once all arguments are collected. -- -- Direct case dispatch avoids rebuilding the polymorphic 'builtinRegistry' -- Map on every call. 'builtinRegistry' is polymorphic in @m@ so GHC -- cannot cache it as a CAF - it gets reconstructed on every use. --- Pattern matching on the name is zero-allocation. -executeBuiltin :: (MonadEval m) => Text -> [NixValue] -> m NixValue +-- Pattern matching on the name is zero-allocation. Each case runs the +-- shape its registry entry uses, which the implementation's type fixes. +executeBuiltin :: (MonadEval m) => Text -> [BuiltinArg] -> m NixValue executeBuiltin name args = case name of -- Type checking (arity 1) "typeOf" -> apply1 (pure . mkStr . typeOfValue) @@ -1503,29 +1598,29 @@ "intersectAttrs" -> apply2 builtinIntersectAttrs "catAttrs" -> apply2 builtinCatAttrs -- List higher-order (arity 2) - "map" -> apply2 builtinMap - "filter" -> apply2 builtinFilter - "genList" -> apply2 builtinGenList - "sort" -> apply2 builtinSort + "map" -> run (onUseFirst builtinMap) + "filter" -> run (onUseFirst builtinFilter) + "genList" -> run (onUseFirst builtinGenList) + "sort" -> run (onUseFirst builtinSort) "concatMap" -> apply2 builtinConcatMap "any" -> apply2 builtinAny "all" -> apply2 builtinAll - "elem" -> apply2 builtinElem - "elemAt" -> apply2 builtinElemAt + "elem" -> run (onUseFirst builtinElem) + "elemAt" -> run (onUseFirst builtinElemAt) "partition" -> apply2 builtinPartition "groupBy" -> apply2 builtinGroupBy -- String operations (arity 2) "concatStringsSep" -> apply2 builtinConcatStringsSep -- Arity 3 - "foldl'" -> apply3 builtinFoldl + "foldl'" -> run (onUseMiddle builtinFoldl) "substring" -> apply3 builtinSubstring -- Numeric "isPath" -> apply1 (pure . VBool . isPathVal) "ceil" -> apply1 builtinCeil "floor" -> apply1 builtinFloor "seq" -> apply2 builtinSeq - "trace" -> apply2 builtinTrace - "warn" -> apply2 builtinWarn + "trace" -> run (onUseSecond builtinTrace) + "warn" -> run (onUseSecond builtinWarn) "unsafeDiscardStringContext" -> apply1 builtinDiscardContext "unsafeDiscardOutputDependency" -> apply1 builtinDiscardOutputDep "addDrvOutputDependencies" -> apply1 builtinAddDrvOutputDeps @@ -1546,7 +1641,7 @@ "bitOr" -> apply2 (bitwise (.|.)) "bitXor" -> apply2 (bitwise xor) -- Attr set higher-order - "mapAttrs" -> apply2 builtinMapAttrs + "mapAttrs" -> run (onUseFirst builtinMapAttrs) "functionArgs" -> apply1 builtinFunctionArgs "zipAttrsWith" -> apply2 builtinZipAttrsWith -- String manipulation @@ -1561,9 +1656,8 @@ "fromJSON" -> apply1 builtinFromJSON "hashString" -> apply2 builtinHashString -- Error handling + sequencing - -- Already-forced argument: success-wrap (see the registry entry). - "tryEval" -> apply1 (tryEvalAction . pure) - "deepSeq" -> apply2 builtinDeepSeq + "tryEval" -> run (onUse1 builtinTryEval) + "deepSeq" -> run (onUseSecond builtinDeepSeq) -- Graph traversal "genericClosure" -> apply1 builtinGenericClosure -- IO builtins (delegate to MonadEval methods) @@ -1578,7 +1672,7 @@ "storePath" -> apply1 builtinStorePath "findFile" -> apply2 builtinFindFile "toFile" -> apply2 builtinToFile - "scopedImport" -> apply2 builtinScopedImport + "scopedImport" -> run (onUseFirst builtinScopedImport) -- Network fetchers "fetchurl" -> apply1 builtinFetchurl "fetchTarball" -> apply1 builtinFetchTarball @@ -1587,10 +1681,10 @@ "derivationStrict" -> apply1 builtinDerivationStrict -- Error context (pass-through - context only matters on error) "addErrorContext" -> apply2 (\_ val -> pure val) - -- Attr position (return null - nixpkgs handles this gracefully) - "unsafeGetAttrPos" -> apply2 (\_ _ -> pure VNull) - -- Debugging (traceVerbose: same as trace for now) - "traceVerbose" -> apply2 builtinTrace + -- Attr position + "unsafeGetAttrPos" -> run (onUseSecond builtinUnsafeGetAttrPos) + -- Debugging + "traceVerbose" -> run (onUse2 builtinTraceVerbose) "break" -> apply1 pure -- IO: file hashing + type detection "hashFile" -> apply2 builtinHashFile @@ -1603,22 +1697,17 @@ "toXML" -> apply1 builtinToXML -- Source filtering + path import "path" -> apply1 builtinPath - "filterSource" -> apply2 builtinFilterSource + "filterSource" -> run (onUseFirst builtinFilterSource) -- Experimental feature stubs "outputOf" -> apply2 builtinOutputOf "fetchTree" -> apply1 builtinFetchTree "fetchClosure" -> apply1 builtinFetchClosure _ -> throwEvalError ("unknown builtin '" <> name <> "'") where - apply1 f = case args of - [a] -> f a - _ -> throwEvalError ("builtins." <> name <> ": internal arity error") - apply2 f = case args of - [a, b] -> f a b - _ -> throwEvalError ("builtins." <> name <> ": internal arity error") - apply3 f = case args of - [a, b, c] -> f a b c - _ -> throwEvalError ("builtins." <> name <> ": internal arity error") + run shape = bdApply (shape name) args + apply1 = run . forced1 + apply2 = run . forced2 + apply3 = run . forced3 -- --------------------------------------------------------------------------- -- Builtin implementations - type checking @@ -1747,12 +1836,14 @@ pairs <- mapM listToAttrsPair thunks -- Nix listToAttrs uses first-wins: if duplicate name, first element wins. let firstWins = Map.fromListWith (\_ kept -> kept) pairs - pure (VAttrs (attrSetFromMap firstWins)) + pure (VAttrs (attrSetFromEntries firstWins)) builtinListToAttrs other = throwEvalError ("builtins.listToAttrs: expected a list, got " <> typeName other) --- | Extract { name, value } from a thunk for listToAttrs. -listToAttrsPair :: (MonadEval m) => Thunk -> m (Text, Thunk) +-- | Extract { name, value } from a thunk for listToAttrs. The attribute +-- is at the position of the element's @value@, as upstream's +-- @prim_listToAttrs@ inserts it (primops.cc at 2.24.9). +listToAttrsPair :: (MonadEval m) => Thunk -> m (Text, AttrEntry) listToAttrsPair thunk = do val <- force thunk case val of @@ -1763,10 +1854,10 @@ nameVal <- force nameThunk case nameVal of VStr keyName _ -> - case attrSetLookup "value" attrs of - Just valueThunk -> do + case attrSetLookupEntry "value" attrs of + Just valueEntry -> do key <- decodedText "builtins.listToAttrs: attribute name" keyName - pure (key, valueThunk) + pure (key, valueEntry) Nothing -> throwEvalError "builtins.listToAttrs: element missing 'value'" _ -> throwEvalError "builtins.listToAttrs: 'name' must be a string" _ -> throwEvalError "builtins.listToAttrs: element must be a set" @@ -1795,6 +1886,32 @@ builtinGetAttr other _ = throwEvalError ("builtins.getAttr: expected a string, got " <> typeName other) +-- | Where an attribute was defined, as upstream's @prim_unsafeGetAttrPos@ +-- and @EvalState::mkPos@ give it (primops.cc and eval.cc at 2.24.9): +-- @{ column; file; line; }@ for one defined in a file, and null for a +-- missing attribute, one no source defines (a builtin's, or one a builtin +-- made), and one defined in text with no file behind it. The name is read +-- as upstream's @forceStringNoCtx@ reads it, and checked before the set is +-- forced. +builtinUnsafeGetAttrPos :: (MonadEval m) => NixValue -> BuiltinArg -> m NixValue +builtinUnsafeGetAttrPos nameVal setArg = do + nameBytes <- structuredStringValue RefuseContext nameVal + setVal <- argValue setArg + attrs <- case setVal of + VAttrs attrs -> pure attrs + other -> throwEvalError ("expected a set but found " <> typeName other <> ": " <> printValue PrintForError other) + name <- decodedText "builtins.unsafeGetAttrPos" nameBytes + pure (maybe VNull positionValue (lookupPos . entryPos =<< attrSetLookupEntry name attrs)) + where + positionValue (PosInFile file line column) = + VAttrs . attrSetFromMap $ + Map.fromList + [ ("column", evaluated (VInt (fromIntegral column))), + ("file", evaluated (mkStr file)), + ("line", evaluated (VInt (fromIntegral line))) + ] + positionValue (PosInText _ _) = VNull + builtinRemoveAttrs :: (MonadEval m) => NixValue -> NixValue -> m NixValue builtinRemoveAttrs (VAttrs attrs) (VList cl) = do let thunks = map Thunk (clistThunks cl) @@ -1815,10 +1932,11 @@ builtinIntersectAttrs (VAttrs a) (VAttrs b) = -- Iterate keys of 'a' (typically the smaller set, e.g. functionArgs) -- and point-lookup each in 'b' (typically the large set, e.g. nixpkgs). - -- This avoids materializing all thunks in 'b'. + -- This avoids materializing all thunks in 'b'. Each attribute is b's, + -- position included, as upstream copies it. let keysA = attrSetKeys a - result = Map.fromList [(k, thunk) | k <- keysA, Just thunk <- [attrSetLookup k b]] - in pure (VAttrs (attrSetFromMap result)) + result = Map.fromList [(k, entry) | k <- keysA, Just entry <- [attrSetLookupEntry k b]] + in pure (VAttrs (attrSetFromEntries result)) builtinIntersectAttrs (VAttrs _) other = throwEvalError ("builtins.intersectAttrs: expected a set, got " <> typeName other) builtinIntersectAttrs other _ = @@ -1854,19 +1972,41 @@ -- Builtin implementations - list higher-order (arity 2) -- --------------------------------------------------------------------------- -builtinMap :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinMap func (VList cl) = - -- Lazy: each element is a deferred application, forced only on demand. - let thunks = map Thunk (clistThunks cl) - in pure (VList (clistFromThunks (map (thunkToCPtr . deferApply func) thunks))) +-- | Force a builtin's function argument, failing unless it is a lambda, a +-- builtin, or a set with @__functor@, as upstream's @forceFunction@ does +-- (eval.cc at 2.24.9). +forceFunctionArg :: (MonadEval m) => BuiltinArg -> m NixValue +forceFunctionArg arg = do + val <- argValue arg + case val of + VLambda {} -> pure val + VBuiltin _ _ -> pure val + VAttrs attrs | attrSetMember "__functor" attrs -> pure val + other -> throwEvalError ("expected a function but found " <> typeName other <> ": " <> printValue PrintForError other) + +-- | @prim_map@ forces the list, returns an empty one as it is, and only +-- then forces the function (primops.cc at 2.24.9), so +-- @map (throw "a") [ ]@ is @[ ]@. Each element is a deferred +-- application, forced only on demand. +builtinMap :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinMap funcArg (VList cl) + | clistLen cl == 0 = pure (VList cl) + | otherwise = do + _ <- forceFunctionArg funcArg + let fnThunk = argAsThunk funcArg + pure (VList (clistFromThunks (map (thunkToCPtr . deferApplyThunk fnThunk . Thunk) (clistThunks cl)))) builtinMap _ other = throwEvalError ("builtins.map: expected a list, got " <> typeName other) -builtinFilter :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinFilter predFn (VList cl) = do - let thunks = map Thunk (clistThunks cl) - filtered <- filterThunks predFn thunks - pure (VList (clistFromThunks (map thunkToCPtr filtered))) +-- | @prim_filter@, like @prim_map@, forces its function only once the +-- list is known not to be empty (primops.cc at 2.24.9). +builtinFilter :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinFilter predArg (VList cl) + | clistLen cl == 0 = pure (VList cl) + | otherwise = do + predFn <- forceFunctionArg predArg + filtered <- filterThunks predFn (map Thunk (clistThunks cl)) + pure (VList (clistFromThunks (map thunkToCPtr filtered))) builtinFilter _ other = throwEvalError ("builtins.filter: expected a list, got " <> typeName other) @@ -1879,26 +2019,33 @@ VBool False -> filterThunks predFn rest _ -> throwEvalError "builtins.filter: predicate must return a bool" -builtinGenList :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinGenList func (VInt n) +-- | @prim_genList@ forces the length, then the function, even for a +-- length of zero (primops.cc at 2.24.9). +builtinGenList :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinGenList funcArg (VInt n) | n < 0 = throwEvalError "builtins.genList: length must be non-negative" - | otherwise = + | otherwise = do + _ <- forceFunctionArg funcArg -- Lazy: each element is a deferred @f i@, forced only on demand. -- The index is an argument value, as upstream's @prim_genList@ -- allocates an int and an app per element, so every element runs -- the same code. - let fnThunk = evaluated func + let fnThunk = argAsThunk funcArg mkIndexThunk = thunkToCPtr . deferApplyThunk fnThunk . evaluated . VInt - in pure (VList (clistFromThunks (map mkIndexThunk [0 .. n - 1]))) + pure (VList (clistFromThunks (map mkIndexThunk [0 .. n - 1]))) builtinGenList _ other = throwEvalError ("builtins.genList: expected an integer, got " <> typeName other) -builtinSort :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinSort comparator (VList cl) = do - let thunks = map Thunk (clistThunks cl) - vals <- mapM force thunks - sorted <- mergeSort (sortComparison comparator) vals - pure (VList (clistFromThunks (map (thunkToCPtr . evaluated) sorted))) +-- | @prim_sort@ forces the list, returns an empty one as it is, and forces +-- the comparator before the elements (primops.cc at 2.24.9). +builtinSort :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinSort cmpArg (VList cl) + | clistLen cl == 0 = pure (VList cl) + | otherwise = do + comparator <- forceFunctionArg cmpArg + vals <- mapM (force . Thunk) (clistThunks cl) + sorted <- mergeSort (sortComparison comparator) vals + pure (VList (clistFromThunks (map (thunkToCPtr . evaluated) sorted))) builtinSort _ other = throwEvalError ("builtins.sort: expected a list, got " <> typeName other) @@ -1989,11 +2136,16 @@ VBool False -> pure False _ -> throwEvalError "builtins.all: predicate must return a bool" -builtinElem :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinElem needle (VList cl) = do - let thunks = map Thunk (clistThunks cl) - found <- elemCheck needle thunks - pure (VBool found) +-- | @prim_elem@ forces the list, then compares the needle with each +-- element through @eqValues@, which forces the needle before the element +-- (primops.cc and eval.cc at 2.24.9), so an empty list never forces it. +builtinElem :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinElem needleArg (VList cl) = + VBool <$> case map Thunk (clistThunks cl) of + [] -> pure False + thunks -> do + needle <- argValue needleArg + elemCheck needle thunks builtinElem _ other = throwEvalError ("builtins.elem: expected a list, got " <> typeName other) @@ -2004,11 +2156,15 @@ eq <- nixEqual force needle val if eq then pure True else elemCheck needle rest --- | The index is checked before the list: @prim_elemAt@ forces it with --- @forceInt@ (eval.cc) before its @elemAt@ forces the list. -builtinElemAt :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinElemAt (VList cl) (VInt idx) = listElemAt cl idx -builtinElemAt other (VInt _) = throwEvalError (expectedList other) +-- | The index is forced and checked before the list: @prim_elemAt@ forces +-- it with @forceInt@ before its @elemAt@ forces the list (primops.cc at +-- 2.24.9). +builtinElemAt :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinElemAt listArg (VInt idx) = do + list <- argValue listArg + case list of + VList cl -> listElemAt cl idx + other -> throwEvalError (expectedList other) builtinElemAt _ other = throwEvalError ("expected an integer but found " <> typeName other <> ": " <> printValue PrintForError other) @@ -2091,21 +2247,25 @@ -- Builtin implementations - arity 3 -- --------------------------------------------------------------------------- -builtinFoldl :: (MonadEval m) => NixValue -> NixValue -> NixValue -> m NixValue +-- | @prim_foldlStrict@ passes the initial accumulator to the first call +-- of the operator unforced, and forces it itself only when the list is +-- empty (primops.cc at 2.24.9), so it is taken unforced. +builtinFoldl :: (MonadEval m) => NixValue -> BuiltinArg -> NixValue -> m NixValue builtinFoldl op initial (VList cl) = foldlStrict op initial (map Thunk (clistThunks cl)) builtinFoldl _ _ other = throwEvalError ("builtins.foldl': expected a list, got " <> typeName other) --- | Strict left fold: apply @op acc elem@ for each element. The --- accumulator is forced each step (upstream foldl' strictness); the --- element is passed as an unforced thunk, as upstream does. -foldlStrict :: (MonadEval m) => NixValue -> NixValue -> [Thunk] -> m NixValue -foldlStrict _ acc [] = pure acc +-- | Strict left fold: apply @op acc elem@ for each element. Each step's +-- result is forced (upstream foldl' strictness), the initial accumulator +-- reaches the first step as it was taken, and the element is passed as an +-- unforced thunk, as upstream does. +foldlStrict :: (MonadEval m) => NixValue -> BuiltinArg -> [Thunk] -> m NixValue +foldlStrict _ acc [] = argValue acc foldlStrict op acc (thunk : rest) = do - partial <- applyValue op acc + partial <- applyArg op acc stepped <- applyValueLazy partial thunk - foldlStrict op stepped rest + foldlStrict op (ArgForced stepped) rest -- | Byte-indexed slicing, as upstream: offsets and lengths count bytes, -- and a slice may fall mid-codepoint (the resulting bytes are the value). @@ -2488,16 +2648,18 @@ -- Builtin implementations - attr set higher-order -- --------------------------------------------------------------------------- -builtinMapAttrs :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinMapAttrs func (VAttrs attrs) = +-- | @prim_mapAttrs@ forces only the set: the function is applied in each +-- attribute's deferred application and never forced by the primop itself +-- (primops.cc at 2.24.9), so @mapAttrs (throw "a") { }@ is @{ }@. +builtinMapAttrs :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinMapAttrs funcArg (VAttrs attrs) = -- Each attr value is a deferred @f key val@, forced only on demand. -- Eagerly builds all thunks via attrSetMapWithKey - with C arena thunks - -- (~16 bytes each), this is cheaper than the former MappedAttrs overhead - -- and keeps all data off the GHC heap. + -- (~16 bytes each), this keeps all data off the GHC heap. -- Slot 0 = function, slot 1 = key, slot 2 = value. pure (VAttrs (attrSetMapWithKey deferAttr attrs)) where - fnThunk = evaluated func + fnThunk = argAsThunk funcArg deferAttr key valThunk = let (sp, sc) = buildCSlots [fnThunk, evaluated (mkStr key), valThunk] env = newMinimalEnv sp sc @@ -2995,21 +3157,13 @@ -- Builtin implementations - deep evaluation -- --------------------------------------------------------------------------- -builtinDeepSeq :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinDeepSeq first second = deepForce first >> pure second - --- | What a builtin returning its second argument does with its first --- before it forces that second: @prim_deepSeq@ forces the first deeply, --- @prim_trace@ prints it and @prim_warn@ warns with it, and only then does --- each force the second (primops.cc at 2.24.9). A builtin's arguments --- are forced before it runs, so an application that has the second still --- unforced does this first. -beforeSecondArgument :: (MonadEval m) => Text -> NixValue -> Maybe (m ()) -beforeSecondArgument name first = case name of - "deepSeq" -> Just (deepForce first) - "trace" -> Just (emitTrace first) - "warn" -> Just (emitWarning first) - _ -> Nothing +-- | @builtins.deepSeq a b@. @prim_deepSeq@ forces the first argument +-- deeply before it forces the second (primops.cc at 2.24.9), so the +-- second is taken unforced. 'builtinTrace' and 'builtinWarn' take theirs +-- unforced for the same reason: @prim_trace@ prints and @prim_warn@ warns +-- before forcing the second. +builtinDeepSeq :: (MonadEval m) => NixValue -> BuiltinArg -> m NixValue +builtinDeepSeq first second = deepForce first >> argValue second deepForce :: (MonadEval m) => NixValue -> m () deepForce (VList cl) = mapM_ ((force >=> deepForce) . Thunk) (clistThunks cl) @@ -3020,22 +3174,35 @@ builtinSeq :: (MonadEval m) => NixValue -> NixValue -> m NixValue builtinSeq !_first = pure --- | @builtins.trace msg val@ - print @msg@ to stderr, return @val@. -builtinTrace :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinTrace msgVal result = emitTrace msgVal >> pure result +-- | @builtins.trace msg val@ - print @msg@ to stderr, then force and +-- return @val@. +builtinTrace :: (MonadEval m) => NixValue -> BuiltinArg -> m NixValue +builtinTrace msgVal result = emitTrace msgVal >> argValue result +-- | @builtins.traceVerbose msg val@: @builtins.trace@ under +-- @trace-verbose@, and otherwise @val@ alone. Upstream binds the name to +-- @prim_trace@ or to @prim_second@ by the setting (primops.cc at 2.24.9), +-- and @prim_second@ never forces its first argument, so both are taken +-- unforced and @traceVerbose (throw "a") 1@ is @1@ without the setting. +builtinTraceVerbose :: (MonadEval m) => BuiltinArg -> BuiltinArg -> m NixValue +builtinTraceVerbose msgArg result = do + policy <- evalPolicy + when (epTraceVerbose policy) (argValue msgArg >>= emitTrace) + argValue result + emitTrace :: (MonadEval m) => NixValue -> m () emitTrace msgVal = traceMessage . ("trace: " <>) $ case msgVal of VStr s _ -> bytesToTextLossy s other -> printValue PrintInFull other --- | @builtins.warn msg val@ - print warning to stderr, return @val@. +-- | @builtins.warn msg val@ - print warning to stderr, then force and +-- return @val@. -- -- The message must be a string: upstream's @prim_warn@ forces it with -- @forceString@ (primops.cc at 2.24.9), leaving room to extend the -- argument later, where @builtins.trace@ prints any value. -builtinWarn :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinWarn msgVal result = emitWarning msgVal >> pure result +builtinWarn :: (MonadEval m) => NixValue -> BuiltinArg -> m NixValue +builtinWarn msgVal result = emitWarning msgVal >> argValue result -- | Upstream logs the message as a warning from an expression, which its -- logger prefixes @evaluation warning:@. @@ -3367,13 +3534,16 @@ -- Builtin implementations - scoped import -- --------------------------------------------------------------------------- -builtinScopedImport :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinScopedImport (VAttrs attrs) pathVal = do +-- | Upstream's @import@ helper behind @scopedImport@ realises the path +-- before it forces the scope (primops.cc at 2.24.9), so the scope is +-- taken unforced. +builtinScopedImport :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinScopedImport scopeArg pathVal = do p <- coerceToPath "builtins.scopedImport" pathVal - let scope = Map.toList (attrSetToMap attrs) - scopedImportFile scope p -builtinScopedImport other _ = - throwEvalError ("builtins.scopedImport: expected a set, got " <> typeName other) + scopeVal <- argValue scopeArg + case scopeVal of + VAttrs attrs -> scopedImportFile (Map.toList (attrSetToMap attrs)) p + other -> throwEvalError ("builtins.scopedImport: expected a set, got " <> typeName other) -- --------------------------------------------------------------------------- -- Builtin implementations - network fetchers @@ -3416,6 +3586,7 @@ fetchAndExtractTarball url mSha256 name = do checkUri url requireFetchPin "fetchTarball" mSha256 + toolUrl <- localFileUrl url extractDir <- createScratchDir "nova-nix-tarball-" -- The -- separator prevents argument injection from the URL. (code, _, errOut) <- @@ -3424,7 +3595,7 @@ [ "-c", "curl -sSfL -- \"$1\" | tar -xz -C \"$2\" --strip-components=1", "--", - url, + toolUrl, extractDir ] "" @@ -3568,7 +3739,7 @@ -- | The attributes @builtins.fetchGit@ accepts. Anything outside the -- set is an error rather than a silent drop - an ignored attribute is -- exactly how an unhonored pin stays invisible. Upstream refuses the --- same way ("input attribute '...' not supported by scheme 'git'", +-- same way ("input attribute \'...\' not supported by scheme \'git\'", -- observed from nix-instantiate 2.33.2). fetchGitSupportedAttrs :: [Text] fetchGitSupportedAttrs = ["url", "name", "ref", "rev", "submodules", "shallow", "allRefs", "narHash"] @@ -3807,7 +3978,7 @@ `onEvalError` removeScratchDir cloneDir -- | Every step of an uncached fetch that can throw, run under --- 'fetchGitUncached''s scratch-dir cleanup. +-- 'fetchGitUncached'\'s scratch-dir cleanup. fetchGitInClone :: (MonadEval m) => FetchGitArgs -> Maybe Text -> Maybe Text -> Text -> m FetchCache fetchGitInClone args checkedRef checkedRev cloneDir = do let ctx = "builtins.fetchGit" @@ -3844,8 +4015,9 @@ (Just pinned, _, _) -> pinned (Nothing, True, Just ref) -> ref _ -> fetchHeadRef + remote <- gitRemote url _ <- git ["init", "--quiet", "."] - _ <- git ["remote", "add", "origin", "--", url] + _ <- git ["remote", "add", "origin", "--", remote] -- @--@ before the remote: git keeps parsing options after it, so -- without a separator a refspec is indistinguishable from a flag. _ <- git (["fetch", "--quiet"] ++ depthArgs ++ updateHeadArgs ++ ["--", "origin", fetchTarget]) @@ -3979,6 +4151,9 @@ fcNarHash fields ] +-- | Read back what 'encodeFetchCache' wrote: 'Nothing' unless there are +-- exactly five lines, both counts are decimal and the NAR hash is a whole +-- base64 SHA-256. decodeFetchCache :: Text -> Maybe FetchCache decodeFetchCache raw = case T.splitOn "\n" raw of [storePath, rev, revCount, lastModified, narHash] -> do @@ -4019,6 +4194,16 @@ then pure (T.strip out) else throwEvalError (ctx <> ": git " <> T.unwords args <> " failed: " <> err) +-- | The remote git is handed for a fetch's url: a local path, bare or as +-- a file URL, named on the drive the evaluator reads it on, where git, +-- run in the scratch clone, would read it on that directory's drive. A +-- url with any other scheme, or an scp-like remote, is handed over as +-- given. +gitRemote :: (MonadEval m) => Text -> m Text +gitRemote url + | T.isInfixOf "://" url = localFileUrl url + | otherwise = qualifyPath url + -- | Strip every @.git@ entry (clone's own, and each submodule's) before the -- tree is copied to the store. Walked directly, not shelled out to -- @find@\/@rm@: no @sh@ on a bare Windows install. @@ -4069,7 +4254,8 @@ downloadInto :: (MonadEval m) => Text -> Text -> m BS.ByteString downloadInto scratch url = do let tmpFile = scratch <> "/" <> downloadFileName - (code, _, stderr) <- runProcess "curl" ["-sSfL", "-o", tmpFile, "--", url] "" + toolUrl <- localFileUrl url + (code, _, stderr) <- runProcess "curl" ["-sSfL", "-o", tmpFile, "--", toolUrl] "" if code /= 0 then throwEvalError ("builtins.fetchurl: fetch failed: " <> stderr) else readFileBytes tmpFile @@ -4078,6 +4264,16 @@ downloadFileName :: Text downloadFileName = "download" +-- | The URL a fetch hands its tool: a @file://@ URL's path named on the +-- drive the evaluator reads it on ('qualifyPath'), so the tool reads the +-- file 'checkUri' checked rather than one on its own current drive. A +-- drive it gains is spelled @file://C:/...@, the form 'checkUri' reads as +-- that drive's path. Any other URL is handed over as given. +localFileUrl :: (MonadEval m) => Text -> m Text +localFileUrl url = case T.stripPrefix fileUrlPrefix url of + Just path -> (fileUrlPrefix <>) <$> qualifyPath path + Nothing -> pure url + -- | Upstream's pure-mode rule for @fetchurl@ and @fetchTarball@ -- (fetchTree.cc): without a @sha256@ the fetch is refused, since its -- result would be whatever the network answers today. @@ -4470,11 +4666,11 @@ -- Path construction returns Left on a name the store rules reject; the -- early field checks above make that unreachable here except through -- composition (drvName <> ".drv", drvName-output past the length cap), - -- which only the constructors see. - let drvContext = "derivation \"" <> drvName <> "\"" + -- which only the constructors see, and which they refuse in upstream's + -- words, naming the path. (outPaths, completeDrv, moduloHash) <- case mFixed of Just (foAlgo, foMode, foDigest) -> do - foPath <- storePathOrThrow drvContext (makeFixedOutputPath drvName foAlgo foMode foDigest) + foPath <- storePathOrThrow (makeFixedOutputPath drvName foAlgo foMode foDigest) let foPathText = storePathToText defaultStoreDir foPath algoField = (if foMode == "recursive" then "r:" else "") <> foAlgo foHashHex = bytesToHexText foDigest @@ -4492,10 +4688,12 @@ maskedDrv = mkDrv (map maskedOutput outputNames) maskedEnv -- Masked modulo hash yields this derivation's own output paths. moduloMasked = sha256Digest (toATermForHash True (Just inputSubst) maskedDrv) + -- In name order, as upstream walks its output set, so a refusal + -- names the output upstream's names. outStorePaths <- mapM - (\n -> (,) n <$> storePathOrThrow drvContext (makeOutputPath n moduloMasked drvName)) - outputNames + (\n -> (,) n <$> storePathOrThrow (makeOutputPath n moduloMasked drvName)) + (sort outputNames) let outPathTexts = [(n, storePathToText defaultStoreDir sp) | (n, sp) <- outStorePaths] realEnv = foldr (\(n, t) e -> Map.insert n (TE.encodeUtf8 t) e) baseEnv outPathTexts contents = mkDrv [DerivationOutput n sp "" "" | (n, sp) <- outStorePaths] realEnv @@ -4510,7 +4708,7 @@ -- eval guarantees every transitive input is recorded by the time a -- dependent is. let aterm = toATerm completeDrv - drvSP <- storePathOrThrow drvContext (makeTextPath drvFileName (sha256Digest aterm) drvRefs) + drvSP <- storePathOrThrow (makeTextPath drvFileName (sha256Digest aterm) drvRefs) let drvPathText = storePathToText defaultStoreDir drvSP cacheDrvHash drvPathText (bytesToHexText moduloHash) recordDrvAterm drvPathText aterm @@ -4755,7 +4953,7 @@ builtinHashFile other _ = throwEvalError ("builtins.hashFile: expected a string, got " <> typeName other) --- | Shared hash dispatch for raw 'ByteString' input. +-- | Shared hash dispatch for raw t'Data.ByteString.ByteString' input. hashBytesWithAlgo :: (MonadEval m) => Text -> Text -> BS.ByteString -> m NixValue hashBytesWithAlgo ctx algo bytes = case algo of "sha256" -> pure (mkStr (digestToHex (CH.hash bytes :: CH.Digest CH.SHA256))) @@ -5004,7 +5202,7 @@ -- | Scan one physical line, returning the state at end of line and the -- line's visible text: a comment outside strings is cut here, where the --- string context is still known ('#' inside any string form is content). +-- string context is still known (@#@ inside any string form is content). scanTomlLine :: TomlScan -> Text -> (TomlScan, Text) scanTomlLine st0 line = go st0 line 0 where @@ -5599,8 +5797,8 @@ -- | @builtins.path { path; name?; filter?; sha256?; recursive?; }@ -- -- Copy a path to the store and return the store path as a string with --- context. @name@ defaults to the basename of @path@. @filter@ is --- accepted but not yet applied (copies everything). +-- context. @name@ defaults to the basename of @path@. @filter@, when +-- given, decides which entries are copied ('filteredSourceNar'). builtinPath :: (MonadEval m) => NixValue -> m NixValue builtinPath (VAttrs attrs) = do -- prim_path coerces the attribute with coerceToPath and checks for it @@ -5618,13 +5816,19 @@ pinText <- decodedText "builtins.path" pin Just <$> decodeSha256Pin "builtins.path" pinText other -> throwEvalError ("builtins.path: 'sha256' must be a string, got " <> typeName other) + filterFn <- traverse force (attrSetLookup "filter" attrs) let name = fromMaybe (canonBaseName pathStr) nameOverride pinSubject = "builtins.path: " <> pathStr - storePathText <- case attrSetLookup "filter" attrs of + -- A pinned copy's path follows from the pin. Upstream's addPath builds + -- it once prim_path has forced every argument and before it reads the + -- tree (primops.cc at 2.24.9), so a name it refuses is refused under the + -- pinned hash, before the filter is applied. + forM_ expectedDigest $ \expected -> + storePathOrThrow (makeFixedOutputPath name "sha256" "recursive" expected) + storePathText <- case filterFn of Nothing -> copyPathToStore pathStr name (fmap (pinSubject,) expectedDigest) - Just filterThunk -> do - filterFn <- force filterThunk - narBytes <- filteredSourceNar filterFn pathStr + Just keep -> do + narBytes <- filteredSourceNar keep pathStr -- The sha256 pin applies to the FILTERED tree, as upstream. let filteredDigest = sha256Digest narBytes case expectedDigest of @@ -5701,9 +5905,14 @@ -- filtering entries via a predicate. The filter function receives -- @(path, type)@ where type is @"regular"@, @"directory"@, @"symlink"@, -- or @"unknown"@. Equivalent to @builtins.path@ with a filter and the --- source's basename as the store name. -builtinFilterSource :: (MonadEval m) => NixValue -> NixValue -> m NixValue -builtinFilterSource filterFn pathVal = filterSourceInto filterFn =<< coerceToPath "builtins.filterSource" pathVal +-- source's basename as the store name. @prim_filterSource@ coerces the +-- path before it forces the filter (primops.cc at 2.24.9), so the filter +-- is taken unforced. +builtinFilterSource :: (MonadEval m) => BuiltinArg -> NixValue -> m NixValue +builtinFilterSource filterArg pathVal = do + path <- coerceToPath "builtins.filterSource" pathVal + filterFn <- forceFunctionArg filterArg + filterSourceInto filterFn path filterSourceInto :: (MonadEval m) => NixValue -> Text -> m NixValue filterSourceInto filterFn path = do diff --git a/src/Nix/Eval/CAttrSet.hs b/src/Nix/Eval/CAttrSet.hs --- a/src/Nix/Eval/CAttrSet.hs +++ b/src/Nix/Eval/CAttrSet.hs @@ -1,9 +1,10 @@ -- | C-backed sorted attribute set via FFI. -- -- Wraps @cbits/nn_attrset.c@ - a contiguous sorted array of --- @(nn_symbol_t, void*)@ pairs. Replaces Haskell's @Data.Map.Strict@ --- for attribute sets, cutting per-entry overhead from ~48 bytes --- (Map.Bin node) to ~12 bytes (4-byte symbol + 8-byte pointer). +-- @(nn_symbol_t, position, void*)@ entries. Replaces Haskell's +-- @Data.Map.Strict@ for attribute sets, cutting per-entry overhead from +-- ~48 bytes (Map.Bin node) to ~16 bytes (4-byte symbol + 4-byte position +-- + 8-byte pointer). -- -- Construction is two-phase: insert entries, then freeze (sort + dedup). -- After freeze, lookup is O(log n) binary search over contiguous memory. @@ -34,6 +35,7 @@ cattrsetGetValue, cattrsetSetValue, cattrsetGetKey, + cattrsetGetPos, -- * Bulk access cattrsetSize, @@ -52,6 +54,7 @@ import Foreign.Ptr (Ptr, castPtr, nullPtr) import Nix.Eval.CStatus (cStatusFailure, checkedCPtr) import Nix.Eval.CThunk (CThunkPtr) +import Nix.Eval.SourcePos (PosIdx (..)) import Nix.Eval.Symbol (Symbol (..)) -- | Opaque handle to a C-allocated attribute set. @@ -69,7 +72,7 @@ c_nn_attrset_new :: Word32 -> IO CAttrSet foreign import ccall unsafe "nn_attrset_insert" - c_nn_attrset_insert :: CAttrSet -> Word32 -> Ptr () -> IO CInt + c_nn_attrset_insert :: CAttrSet -> Word32 -> Ptr () -> Word32 -> IO CInt foreign import ccall unsafe "nn_attrset_freeze" c_nn_attrset_freeze :: CAttrSet -> IO () @@ -89,6 +92,9 @@ foreign import ccall unsafe "nn_attrset_get_key" c_nn_attrset_get_key :: CAttrSet -> Word32 -> IO Word32 +foreign import ccall unsafe "nn_attrset_get_pos" + c_nn_attrset_get_pos :: CAttrSet -> Word32 -> IO Word32 + foreign import ccall unsafe "nn_attrset_size" c_nn_attrset_size :: CAttrSet -> IO Word32 @@ -123,11 +129,11 @@ -- Construction -- --------------------------------------------------------------------------- --- | Insert a key-value pair. Call before freeze. +-- | Insert a key-value pair defined at a position. Call before freeze. -- The value is a CThunkPtr cast to Ptr () - C never dereferences it. -cattrsetInsert :: CAttrSet -> Symbol -> CThunkPtr -> IO () -cattrsetInsert set (Symbol sym) ptr = do - status <- c_nn_attrset_insert set sym (castPtr ptr) +cattrsetInsert :: CAttrSet -> Symbol -> PosIdx -> CThunkPtr -> IO () +cattrsetInsert set (Symbol sym) (PosIdx pos) ptr = do + status <- c_nn_attrset_insert set sym (castPtr ptr) pos unless (status == 0) $ cStatusFailure "nn_attrset_insert" "the attribute set cannot grow (allocation failure or its 4294967295-entry ceiling)" @@ -163,6 +169,10 @@ -- | Get the key symbol at a known index. cattrsetGetKey :: CAttrSet -> Word32 -> IO Symbol cattrsetGetKey set idx = Symbol <$> c_nn_attrset_get_key set idx + +-- | Get the position of the entry at a known index. +cattrsetGetPos :: CAttrSet -> Word32 -> IO PosIdx +cattrsetGetPos set idx = PosIdx <$> c_nn_attrset_get_pos set idx -- --------------------------------------------------------------------------- -- Bulk access diff --git a/src/Nix/Eval/CBytecode.hs b/src/Nix/Eval/CBytecode.hs --- a/src/Nix/Eval/CBytecode.hs +++ b/src/Nix/Eval/CBytecode.hs @@ -324,7 +324,7 @@ pattern OpLitUri = 4 pattern OpLitPath = 5 --- | String opcodes: an ordinary @"..."@ string and an indented @''...''@ string. +-- | String opcodes: an ordinary @"..."@ string and an indented @\'\'...''@ string. pattern OpStr, OpIndStr :: Word8 pattern OpStr = 6 pattern OpIndStr = 7 @@ -369,6 +369,8 @@ pattern OpSearchPath :: Word8 pattern OpSearchPath = 23 +-- | Interpolated-path opcode: a path holding an antiquotation, such as +-- @.\/a\/${x}@, whose string parts begin with the path's literal head. pattern OpPathStr :: Word8 pattern OpPathStr = 24 diff --git a/src/Nix/Eval/CCtxStr.hs b/src/Nix/Eval/CCtxStr.hs --- a/src/Nix/Eval/CCtxStr.hs +++ b/src/Nix/Eval/CCtxStr.hs @@ -6,7 +6,7 @@ -- strings with non-empty context. -- -- This module provides raw FFI bindings only. The higher-level --- marshalling between 'StringContext' and C is in 'Nix.Eval.Types' +-- marshalling between t'Nix.Eval.Types.StringContext' and C is in "Nix.Eval.Types" -- (to avoid circular imports). module Nix.Eval.CCtxStr ( -- * Opaque handle diff --git a/src/Nix/Eval/CEnv.hs b/src/Nix/Eval/CEnv.hs --- a/src/Nix/Eval/CEnv.hs +++ b/src/Nix/Eval/CEnv.hs @@ -136,7 +136,7 @@ -- --------------------------------------------------------------------------- -- | Allocate a C array of @count@ 'CThunkPtr' slots. O(1) amortized. --- Returns 'nullPtr' if count is 0. All slots are zero-initialized. +-- Returns 'Foreign.Ptr.nullPtr' if count is 0. All slots are zero-initialized. cenvAllocSlots :: Word32 -> IO (Ptr CThunkPtr) cenvAllocSlots = c_nn_env_alloc_slots diff --git a/src/Nix/Eval/CList.hs b/src/Nix/Eval/CList.hs --- a/src/Nix/Eval/CList.hs +++ b/src/Nix/Eval/CList.hs @@ -157,7 +157,7 @@ -- --------------------------------------------------------------------------- -- | Opaque wrapper around a C-backed list. Used as the payload of --- @VList@ in the 'NixValue' ADT. The underlying @nn_list_t*@ is +-- @VList@ in the t'Nix.Eval.Types.NixValue' ADT. The underlying @nn_list_t*@ is -- arena-allocated and valid until evaluation end. newtype CList = CList {unCList :: CListPtr} @@ -177,14 +177,14 @@ emptyCList :: CList emptyCList = CList nullPtr --- | Convert a Haskell list of 'CThunkPtr' to a 'CList'. +-- | Convert a Haskell list of 'CThunkPtr' to a t'CList'. -- Uses 'unsafePerformIO' - safe because allocation is idempotent -- per call (no shared mutable state beyond the tracking array). {-# NOINLINE clistFromThunks #-} clistFromThunks :: [CThunkPtr] -> CList clistFromThunks ptrs = CList (unsafePerformIO (thunkListToCList ptrs)) --- | Convert a 'CList' back to a Haskell list of 'CThunkPtr'. +-- | Convert a t'CList' back to a Haskell list of 'CThunkPtr'. clistThunks :: CList -> [CThunkPtr] clistThunks (CList p) = unsafePerformIO (clistToThunkList p) diff --git a/src/Nix/Eval/CanonPath.hs b/src/Nix/Eval/CanonPath.hs --- a/src/Nix/Eval/CanonPath.hs +++ b/src/Nix/Eval/CanonPath.hs @@ -45,7 +45,7 @@ -- conditional: on POSIX a backslash is an ordinary file-name character -- and passes through untouched - upstream's semantics - while on -- Windows it is a separator and folds to @/@. Every site that --- produces a 'VPath' from platform-tainted text (literal resolution, +-- produces a 'Nix.Eval.Types.VPath' from platform-tainted text (literal resolution, -- base-dir joins, fetcher scratch dirs, search-path entries) goes -- through this gate; store-path text is canonical by construction. canonPathValue :: Text -> Text diff --git a/src/Nix/Eval/Compile.hs b/src/Nix/Eval/Compile.hs --- a/src/Nix/Eval/Compile.hs +++ b/src/Nix/Eval/Compile.hs @@ -6,9 +6,10 @@ -- bytecode indices are always less than parent indices. Variable-length -- data (string parts, bindings, formals, capture info, attr paths) goes -- into a separate @uint32_t[]@ data buffer, referenced by offset from --- instructions. +-- instructions; a binding refers to its position there by the index +-- "Nix.Eval.SourcePos" records it at. -- --- Must be called after 'cbcInit' and 'symbolInit'. +-- Must be called after 'Nix.Eval.CBytecode.cbcInit' and 'Nix.Eval.Symbol.symbolInit'. module Nix.Eval.Compile ( compileExpr, compileFormalsToEval, @@ -26,6 +27,7 @@ import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Data.Int (Int64) import Data.Text (Text) +import qualified Data.Text.Encoding as TE import Data.Word (Word16, Word32, Word64, Word8) import GHC.Float (castDoubleToWord64, castWord64ToDouble) import Nix.Eval.CBytecode @@ -92,7 +94,8 @@ pattern OpWithVar, ) import Nix.Eval.EvalFormals (EvalFormal (..), EvalFormals (..)) -import Nix.Eval.Symbol (Symbol (..), symbolIntern, symbolText) +import Nix.Eval.SourcePos (PosIdx (..), PosRecorder, newPosRecorder, recordPos) +import Nix.Eval.Symbol (Symbol (..), symbolIntern, symbolInternBytes, symbolText) import Nix.Expr.Types ( AttrKey (..), BinaryOp (..), @@ -101,7 +104,9 @@ Expr (..), Formal (..), Formals (..), + InheritedName (..), NixAtom (..), + SrcPos, StringPart (..), UnaryOp (..), ) @@ -109,13 +114,19 @@ -- | Compile an 'Expr' tree to bytecode, returning the root instruction index. -- The bytecode is stored in the global @nn_bytecode@ arena. compileExpr :: Expr -> IO Word32 -compileExpr = go +compileExpr expr = do + recorder <- newPosRecorder + compileWith recorder expr + +-- | 'compileExpr' recording positions with one recorder for the whole tree. +compileWith :: PosRecorder -> Expr -> IO Word32 +compileWith recorder = go where go :: Expr -> IO Word32 go (ELit atom) = compileLit atom go (EStr parts) = compileStringParts OpStr parts go (EIndStr parts) = compileStringParts OpIndStr parts - go (EPathStr parts) = compileStringParts OpPathStr parts + go (EPathStr headPiece parts) = compileStringParts OpPathStr (StrLit (TE.encodeUtf8 headPiece) : parts) go (EVar name) = compileSymbolOp OpVar name go (EWithVar name) = compileSymbolOp OpWithVar name go (EResolvedVar level idx) = @@ -198,11 +209,11 @@ cbcEmit op 0 partCount dataOff 0 0 compileOnePart :: StringPart -> IO (Word32, Word32) - compileOnePart (StrLit t) = do - Symbol sym <- symbolIntern t + compileOnePart (StrLit bytes) = do + Symbol sym <- symbolInternBytes bytes pure (strpartLit, sym) - compileOnePart (StrEsc t) = do - Symbol sym <- symbolIntern t + compileOnePart (StrEsc bytes) = do + Symbol sym <- symbolInternBytes bytes pure (strpartEsc, sym) compileOnePart (StrInterp expr) = do idx <- go expr @@ -325,14 +336,16 @@ compileBindingWords bindings = concat <$> mapM compileOneBinding bindings compileOneBinding :: Binding -> IO [Word32] - compileOneBinding (NamedBinding key expr) = do + compileOneBinding (NamedBinding pos key expr) = do (keyKind, keyWord) <- compileAttrKey key valIdx <- go expr - pure [bindNamed, keyKind, keyWord, valIdx] - compileOneBinding (Inherit name var) = do + posWord <- positionWord pos + pure [bindNamed, keyKind, keyWord, valIdx, posWord] + compileOneBinding (Inherit pos name var) = do sym <- internName name valIdx <- go var - pure [bindInherit, sym, valIdx] + posWord <- positionWord pos + pure [bindInherit, sym, valIdx, posWord] compileOneBinding (InheritFrom fromExpr names) = do fromIdx <- go fromExpr inherited <- mapM compileInheritedName names @@ -342,20 +355,25 @@ -- \| One name of @inherit (from) names@: its symbol, then the select -- that reads it from slot 0 of the env the evaluator puts the - -- from-value in. Compiled here with the binding, as upstream's parser - -- makes an @ExprSelect@ per name, rather than each time the binding - -- is evaluated, which would add a copy to a store that only grows. - compileInheritedName :: Text -> IO [Word32] - compileInheritedName name = do + -- from-value in, then its position. Compiled here with the binding, + -- as upstream's parser makes an @ExprSelect@ per name, rather than + -- each time the binding is evaluated, which would add a copy to a + -- store that only grows. + compileInheritedName :: InheritedName -> IO [Word32] + compileInheritedName (InheritedName pos name) = do sym <- internName name selectIdx <- go (ESelect (EResolvedVar 0 0) [StaticKey name] Nothing) - pure [sym, selectIdx] + posWord <- positionWord pos + pure [sym, selectIdx, posWord] internName :: Text -> IO Word32 internName name = do Symbol sym <- symbolIntern name pure sym + positionWord :: SrcPos -> IO Word32 + positionWord pos = unPosIdx <$> recordPos recorder pos + -- ----------------------------------------------------------------- -- CaptureInfo (shared by EAttrs, ELet, ELambda) -- ----------------------------------------------------------------- @@ -552,20 +570,22 @@ -- Binding decoding (for evalBcAttrs / evalBcLet) -- --------------------------------------------------------------------------- --- | A decoded binding from the bytecode data buffer. +-- | A decoded binding from the bytecode data buffer, each name at the +-- position it was defined at. data BcBinding - = -- | @key = expr@: the key and the value's bc_idx - BcNamed !BcAttrKey !Word32 - | -- | One name of @inherit x@: its symbol and the bc_idx of the variable - -- it copies, which is evaluated in the env around the binding set - BcInherit !Word32 !Word32 + = -- | @key = expr@: its position, the key and the value's bc_idx + BcNamed !PosIdx !BcAttrKey !Word32 + | -- | One name of @inherit x@: its position, its symbol and the bc_idx + -- of the variable it copies, which is evaluated in the env around the + -- binding set + BcInherit !PosIdx !Word32 !Word32 | -- | @inherit (from) names@ with from-expr bc_idx and the names BcInheritFrom !Word32 ![BcInheritedName] --- | One name of an @inherit (from) names@ binding: its symbol and the --- bc_idx of the select that reads it from slot 0 of an env holding the --- from-value. -data BcInheritedName = BcInheritedName !Word32 !Word32 +-- | One name of an @inherit (from) names@ binding: its position, its +-- symbol and the bc_idx of the select that reads it from slot 0 of an env +-- holding the from-value. +data BcInheritedName = BcInheritedName !PosIdx !Word32 !Word32 -- | A binding's attribute key. data BcAttrKey @@ -592,16 +612,18 @@ 0 {- NamedBinding -} -> do key <- decodeAttrKey (off + 1) valBcIdx <- cbcData (off + 3) - pure (BcNamed key valBcIdx, off + 4) + pos <- cbcData (off + 4) + pure (BcNamed (PosIdx pos) key valBcIdx, off + 5) 1 {- Inherit -} -> do sym <- cbcData (off + 1) valBcIdx <- cbcData (off + 2) - pure (BcInherit sym valBcIdx, off + 3) + pos <- cbcData (off + 3) + pure (BcInherit (PosIdx pos) sym valBcIdx, off + 4) 2 {- InheritFrom -} -> do fromBcIdx <- cbcData (off + 1) nameCount <- cbcData (off + 2) names <- decodeInheritedNames (fromIntegral nameCount) (off + 3) - pure (BcInheritFrom fromBcIdx names, off + 3 + 2 * nameCount) + pure (BcInheritFrom fromBcIdx names, off + 3 + 3 * nameCount) -- Unreachable: the tag is written only by this module's binding compiler, -- which emits 0, 1 or 2 - all matched above. _ -> error "decodeOneBinding: invalid binding type tag" @@ -613,14 +635,15 @@ val <- cbcData (off + 1) pure (if isExpr /= 0 then BcDynamicKey val else BcStaticKey val) --- | Decode inherited names: pairs of (name_sym, select_bc_idx). +-- | Decode inherited names: triples of (name_sym, select_bc_idx, pos). decodeInheritedNames :: Int -> Word32 -> IO [BcInheritedName] decodeInheritedNames 0 _ = pure [] decodeInheritedNames n off = do sym <- cbcData off selectBcIdx <- cbcData (off + 1) - rest <- decodeInheritedNames (n - 1) (off + 2) - pure (BcInheritedName sym selectBcIdx : rest) + pos <- cbcData (off + 2) + rest <- decodeInheritedNames (n - 1) (off + 3) + pure (BcInheritedName (PosIdx pos) sym selectBcIdx : rest) -- --------------------------------------------------------------------------- -- Numeric reassembly (from two uint32 halves) diff --git a/src/Nix/Eval/EvalFormals.hs b/src/Nix/Eval/EvalFormals.hs --- a/src/Nix/Eval/EvalFormals.hs +++ b/src/Nix/Eval/EvalFormals.hs @@ -2,8 +2,8 @@ -- -- Separates the evaluation representation (defaults are bytecode indices) -- from the parser representation ('Nix.Expr.Types.Formal', defaults are --- 'Expr'). This avoids circular dependencies: both 'Nix.Eval.Types' --- (for 'VLambda') and 'Nix.Eval.Compile' (for encoding\/decoding) +-- t'Nix.Expr.Types.Expr'). This avoids circular dependencies: both "Nix.Eval.Types" +-- (for 'Nix.Eval.Types.VLambda') and "Nix.Eval.Compile" (for encoding\/decoding) -- import this leaf module. module Nix.Eval.EvalFormals ( EvalFormals (..), diff --git a/src/Nix/Eval/IO.hs b/src/Nix/Eval/IO.hs --- a/src/Nix/Eval/IO.hs +++ b/src/Nix/Eval/IO.hs @@ -5,7 +5,7 @@ -- | IO-based Nix evaluator. -- --- Provides 'EvalIO', a concrete 'MonadEval' instance that performs +-- Provides t'EvalIO', a concrete 'MonadEval' instance that performs -- real file-system access. The @import@ builtin reads, parses, and -- evaluates @.nix@ files with a per-process import cache. -- @@ -67,7 +67,7 @@ import Nix.Eval.Types (AttrSet (..), Env (..), MonadEval (..), NixValue (..), PathExistence (..), Thunk (..), attrSetSize, bytesToTextLossy, emptyContext, marshalLambda, marshalStringContext, storePathOrThrow, unmarshalLambdaValue, unmarshalStringContext, pattern ThunkBlackhole, pattern ThunkComputed, pattern ThunkPending, pattern ValueAttrs, pattern ValueBool, pattern ValueCtxStr, pattern ValueFloat, pattern ValueInt, pattern ValueLambda, pattern ValueList, pattern ValueNull, pattern ValuePath, pattern ValueStr) import Nix.Expr.Resolve (undefinedVariableMessage) import Nix.Hash (bytesToHexText, makeFixedOutputPath, makeTextPath, sha256Digest) -import Nix.Parser (SourceError (..), parseNixWithScope, readFileAutoEncoding) +import Nix.Parser (SourceError (..), SourceOrigin (..), parseNixWithScope) import Nix.Store (unpackNarEntry) import Nix.Store.CaseSensitive (probeCaseSensitivity, processCaseHack, volumeCaseHack) import qualified Nix.Store.ExecBit as ExecBit @@ -154,11 +154,11 @@ data EvalState = EvalState { esImportCache :: !(IORef (Map FilePath NixValue)), -- | Cache of derivation modulo-hashes (drv store path to hex), populated - -- bottom-up by 'builtinDerivationStrict' so input derivations can be + -- bottom-up by @builtinDerivationStrict@ so input derivations can be -- substituted by their content hashes when computing output paths. esDrvModuloCache :: !(IORef (Map Text Text)), -- | Accumulated @.drv@ closure (drv store path text to its ATerm bytes), - -- recorded bottom-up by 'builtinDerivationStrict'. The build driver reads + -- recorded bottom-up by @builtinDerivationStrict@. The build driver reads -- this after evaluation to write every input @.drv@ to the store before -- building. esDrvClosure :: !(IORef (Map Text BS.ByteString)), @@ -184,8 +184,9 @@ -- with nothing to restore. esCallDepth :: !CallDepth, -- | What this evaluation may reach: upstream's @restrict-eval@ and - -- @pure-eval@ settings and the @allowed-uris@ list. Unrestricted - -- unless the caller says otherwise, as upstream's defaults are. + -- @pure-eval@ settings and the @allowed-uris@ list, and its + -- @trace-verbose@ setting. Unrestricted unless the caller says + -- otherwise, as upstream's defaults are. esPolicy :: !EvalPolicy, -- | The allowed path prefixes under a restricting policy: the search -- path roots the caller seeded with 'allowEvalPath', plus every store @@ -244,12 +245,19 @@ -- caller seeds the search path roots before evaluation, and the instance -- adds every store object the evaluation produces. Like upstream's, this -- is a no-op when nothing restricts access, so an unrestricted evaluation --- does not accumulate a set it never consults. +-- does not accumulate a set it never consults. The prefix is allowed on +-- the drive its reads open ('locatedPath'), the form every check uses. allowEvalPath :: EvalState -> Text -> IO () allowEvalPath st path = when (pathsRestricted (esPolicy st)) $ - modifyIORef' (esAllowedPaths st) (allowPathIn path) + modifyIORef' (esAllowedPaths st) (allowPathIn (locatedPath st path)) +-- | Path-value text as the policy checks it: canonical, and on the drive +-- this evaluation's store directory puts it on ('SP.qualifyPathText'), +-- so a check and the read it guards ('evalStoreTextPath') name one file. +locatedPath :: EvalState -> Text -> Text +locatedPath st = SP.qualifyPathText (esStoreDir st) . canonPathValue + -- --------------------------------------------------------------------------- -- EvalIO newtype -- --------------------------------------------------------------------------- @@ -317,7 +325,7 @@ listDirectory path = do accessPath path dir <- evalStoreTextPath path - sourceIOWith ReadDirectory (resolvedForMessage path) $ do + sourceIOWith ReadDirectory (resolvedForMessage path dir) $ do entries <- Dir.listDirectory dir mapM (classifyEntry dir) entries @@ -336,9 +344,9 @@ case Map.lookup target cache of Just cached -> pure cached Nothing -> do - source <- sourceIO ReadFile (T.pack target) (readFileAutoEncoding ioTarget) + source <- sourceIO ReadFile (T.pack target) (BS.readFile ioTarget) let fileDir = takeDirectory target - case parseNixWithScope (rootScopeNames policy) fileDir (T.pack target) source of + case parseNixWithScope (rootScopeNames policy) fileDir (SourceFile (T.pack target)) source of Left err -> rejectSource "import" target err Right expr -> do -- local sets new base dir for nested imports - pure, exception-safe @@ -421,15 +429,13 @@ Nothing -> do -- Upstream names the copy baseNameOf(canonicalized path); path -- values arrive canonicalized, so the last segment is the name. - -- The name is checked before the tree read: it derives from the - -- path alone, and the tree behind it can be arbitrarily large. + -- A root, which has none, is refused before its tree is read. + -- A name the store-path rules refuse is refused only once the tree + -- is hashed, as upstream's is: the refusal names the path the copy + -- would have had. let name = canonBaseName rawPath - copyContext = "cannot copy '" <> rawPath <> "' to the store" when (T.null name) $ - throwEvalError (copyContext <> ": the path has no base name") - case SP.checkStorePathName name of - Left err -> throwEvalError (copyContext <> ": " <> SP.storePathNameErrorText err) - Right () -> pure () + throwEvalError ("cannot copy '" <> rawPath <> "' to the store: the path has no base name") accessPath rawPath -- The tree behind the path's symlinks, under the path's own name: -- upstream's copyPathToStore stores path.resolveSymlinks() under @@ -442,7 +448,7 @@ -- restore reads it again. entry <- serialiseSource resolvedText processCaseHack resolvedSource let narDigest = sha256Digest (NAR.serialise entry) - sp <- storePathOrThrow copyContext (makeFixedOutputPath name "sha256" "recursive" narDigest) + sp <- storePathOrThrow (makeFixedOutputPath name "sha256" "recursive" narDigest) let spText = canonicalStorePathText sp EvalIO (liftIO (modifyIORef' ref (Map.insert rawPath spText))) -- The copy is readable afterwards, as upstream's copyPathToStore @@ -461,7 +467,7 @@ -- hashed and written as-is: no encoding step, and no text-mode IO -- (which would CRLF-translate on Windows and store bytes that no -- longer match the hash that named the path). - sp <- storePathOrThrow "builtins.toFile" (makeTextPath name (sha256Digest contents) refs) + sp <- storePathOrThrow (makeTextPath name (sha256Digest contents) refs) filePath <- evalFilePath sp let storePath = canonicalStorePathText sp wrapIO $ do @@ -486,9 +492,9 @@ searchPaths <- EvalIO (asks esSearchPaths) policy <- EvalIO (asks esPolicy) (target, ioTarget) <- resolveImportTarget baseDir rawPath - source <- sourceIO ReadFile (T.pack target) (readFileAutoEncoding ioTarget) + source <- sourceIO ReadFile (T.pack target) (BS.readFile ioTarget) let fileDir = takeDirectory target - case parseNixWithScope (Set.union (Set.fromList (map fst scope)) (rootScopeNames policy)) fileDir (T.pack target) source of + case parseNixWithScope (Set.union (Set.fromList (map fst scope)) (rootScopeNames policy)) fileDir (SourceFile (T.pack target)) source of Left err -> rejectSource "scopedImport" target err Right expr -> do -- No import cache for scoped imports (different scopes = different results) @@ -501,7 +507,7 @@ readFileBytes path = do accessPath path - evalStoreTextPath path >>= \resolved -> sourceIOWith ReadFile (resolvedForMessage path) (BS.readFile resolved) + evalStoreTextPath path >>= \resolved -> sourceIOWith ReadFile (resolvedForMessage path resolved) (BS.readFile resolved) -- An lstat of the path itself, no symlink walk: upstream's readFileType -- realises its argument without resolution, the allow list checks the @@ -553,17 +559,10 @@ removeScratchDir dir = wrapIO (Dir.removePathForcibly (T.unpack dir)) copyPathToStore srcPath name expectedSha256 = do - -- The name is checked before the tree read: it arrives independently - -- of the source, and the tree can be arbitrarily large. - let copyContext = "cannot copy '" <> srcPath <> "' to the store" - case SP.checkStorePathName name of - Left err -> throwEvalError (copyContext <> ": " <> SP.storePathNameErrorText err) - Right () -> pure () -- Content-addressed like upstream addToStore: recursive NAR sha256 -- under the caller's name. Same content means same path, so the - -- existence check in copyToStoreIfMissing is sound - changed source - -- content can never serve stale bytes from an earlier copy (the old - -- scheme hashed the path STRING, so it did exactly that). + -- existence check in 'unpackToStoreVerified' is sound: changed source + -- content can never serve stale bytes from an earlier copy. -- The tree behind the root's symlinks, under the root's own name, as -- upstream's copyPathToStore and addPath store path.resolveSymlinks() -- under path.baseName(); the walk checks the policy on the way. @@ -583,7 +582,9 @@ <> bytesToHexText narDigest ) _ -> pure () - sp <- storePathOrThrow copyContext (makeFixedOutputPath name "sha256" "recursive" narDigest) + -- The name is refused only once the tree is hashed, as upstream's is: + -- the refusal names the path the copy would have had. + sp <- storePathOrThrow (makeFixedOutputPath name "sha256" "recursive" narDigest) destFilePath <- evalFilePath sp let destPath = canonicalStorePathText sp -- Restored from the entry just hashed, not copied from the source: @@ -666,7 +667,7 @@ -- boundary rather than trusting the round trip. Left err -> throwEvalError ("builtins.path: internal NAR round-trip error: " <> T.pack err) Right entry -> do - sp <- storePathOrThrow "builtins.path" (makeFixedOutputPath name "sha256" "recursive" (sha256Digest narBytes)) + sp <- storePathOrThrow (makeFixedOutputPath name "sha256" "recursive" (sha256Digest narBytes)) destFilePath <- evalFilePath sp let destPath = canonicalStorePathText sp -- Raised here rather than inside 'wrapIO', which would render @@ -679,7 +680,7 @@ addFixedOutputFile name bytes = do -- Canonical fixed-output path: a sha256-pinned fetch must land at the same -- store path C++ Nix computes, so it stays reproducible and cache-compatible. - sp <- storePathOrThrow "builtins.fetchurl" (makeFixedOutputPath name "sha256" "flat" (sha256Digest bytes)) + sp <- storePathOrThrow (makeFixedOutputPath name "sha256" "flat" (sha256Digest bytes)) filePath <- evalFilePath sp let storePath = canonicalStorePathText sp wrapIO $ do @@ -702,17 +703,19 @@ checkUri uri = do st <- EvalIO ask allowed <- EvalIO (liftIO (readIORef (esAllowedPaths st))) - either throwEvalError pure (uriAccess (esPolicy st) allowed uri) + either throwEvalError pure (uriAccess (esStoreDir st) (esPolicy st) allowed uri) + qualifyPath path = EvalIO (asks ((`SP.qualifyPathText` path) . esStoreDir)) + -- Store text stays canonical in the value domain, as it does for an -- import target ('resolveImportTarget' says why); every other path - -- resolves as a platform path, the policy walk having followed the - -- same links first. + -- resolves as the platform path it opens, the policy walk having + -- followed the same links first. resolveSymlinks path = do accessPath path if SP.isCanonicalStoreText path then pure (canonPath path) - else wrapIO (canonPathValue . T.pack <$> Dir.canonicalizePath (T.unpack path)) + else evalStoreTextPath path >>= \native -> wrapIO (canonPathValue . T.pack <$> Dir.canonicalizePath native) resolvePathLiteral path = do baseDir <- EvalIO (asks esBaseDir) @@ -916,7 +919,7 @@ st <- EvalIO ask when (pathsRestricted (esPolicy st)) $ do allowed <- EvalIO (liftIO (readIORef (esAllowedPaths st))) - let canonical = canonPathValue path + let canonical = locatedPath st path unless (isAbsolutePath canonical) $ throwEvalError (relativePathMessage path) unless (isAllowedPath allowed canonical) $ throwEvalError (forbiddenPathMessage (esPolicy st) canonical) @@ -995,13 +998,15 @@ -- restarts at the root). 'Left' carries the refusal for the first -- prefix outside the allow list. Under 'ResolveAncestors' the last -- component's own symlink is left alone, as upstream consults --- @maybeLstat@ only while something remains to resolve. +-- @maybeLstat@ only while something remains to resolve. The path is +-- walked on the drive its read opens ('locatedPath'), the form the allow +-- list holds. walkAllowed :: SymlinkResolution -> EvalState -> AllowedPaths -> Text -> EvalIO (Either Text ()) walkAllowed mode st allowed path | not (isAbsolutePath canonical) = pure (Left (relativePathMessage path)) | otherwise = go symlinkFollowLimit [] (pathComponents canonical) where - canonical = canonPathValue path + canonical = locatedPath st path policy = esPolicy st go _ _ [] = pure (Right ()) go linksLeft done (component : rest) @@ -1069,7 +1074,7 @@ -- registers it before a derivation naming it is built. Every eval-time -- writer goes through this: a write that skips it lands in -- @drvInputSrcs@ with no registration row and fails the build with --- \"references unregistered path\". The mode names the scheme that +-- \"path \'...\' is not valid\". The mode names the scheme that -- constructed the path, so materialization can verify the on-disk -- content reproduces it before registering. recordStoreWrite :: Text -> [SP.StorePath] -> SP.StoreWriteMode -> EvalIO () @@ -1150,8 +1155,8 @@ -- would attach the working drive to the rooted @/nix@ prefix on Windows, -- so store text gets lexical canonicalization ('canonPath') only, and -- its reads resolve through 'evalStoreTextPath'. Every other path --- resolves and canonicalizes as a platform path, where the two returned --- forms coincide. +-- resolves and canonicalizes as the platform path 'evalStoreTextPath' +-- gives it, where the two returned forms coincide. resolveImportTarget :: FilePath -> Text -> EvalIO (FilePath, FilePath) resolveImportTarget baseDir rawPath = do accessPath rawPath @@ -1169,8 +1174,8 @@ resolvedTarget <- evalStoreTextPath (T.pack valueTarget) pure (valueTarget, resolvedTarget) | otherwise = do - let raw = T.unpack rawPath - resolved = if isRelative raw then baseDir raw else raw + raw <- evalStoreTextPath rawPath + let resolved = if isRelative raw then baseDir raw else raw canonical <- wrapIO (Dir.canonicalizePath resolved) -- Directory import: append /default.nix if target is a -- directory, which upstream's resolveExprPath learns from an @@ -1206,7 +1211,7 @@ -- | Convert IO exceptions to eval errors. -- Guards against double-wrapping: if the exception is already a --- 'NixEvalError', it is re-thrown as-is. +-- t'NixEvalError', it is re-thrown as-is. wrapIO :: IO a -> EvalIO a wrapIO action = EvalIO $ liftIO $ do result <- try action @@ -1234,13 +1239,14 @@ throwIO (NixEvalError ErrorUncatchable (untracedFailure (sourceErrorMessage access shown err))) -- | A path with its symlinks resolved, as upstream names one it reached --- through realisePath (readFile, hashFile and readDir resolve fully). --- A path the resolution itself cannot walk keeps the spelling given. -resolvedForMessage :: Text -> IO Text -resolvedForMessage path +-- through realisePath (readFile, hashFile and readDir resolve fully), +-- given the value and the native path it opens. A path the resolution +-- itself cannot walk keeps the spelling given. +resolvedForMessage :: Text -> FilePath -> IO Text +resolvedForMessage path native | SP.isCanonicalStoreText path = pure (canonPath path) | otherwise = - (canonPathValue . T.pack <$> Dir.canonicalizePath (T.unpack path)) + (canonPathValue . T.pack <$> Dir.canonicalizePath native) `catch` \(_ :: IOException) -> pure path -- | An lstat that raises for an absent path: 'Dir.pathIsSymbolicLink' is @@ -1269,7 +1275,7 @@ -- error, its lines of context included, for a caller that reports it -- ('renderEvalFailure'). -- --- Catches 'NixEvalError' (throw) and 'NixAbortError' (abort). +-- Catches t'NixEvalError' (throw) and t'NixAbortError' (abort). -- Async exceptions (@StackOverflow@, @ThreadKilled@, etc.) propagate uncaught. runEvalIOTraced :: EvalState -> EvalIO a -> IO (Either EvalFailure a) runEvalIOTraced st (EvalIO action) = do diff --git a/src/Nix/Eval/Operator.hs b/src/Nix/Eval/Operator.hs --- a/src/Nix/Eval/Operator.hs +++ b/src/Nix/Eval/Operator.hs @@ -171,6 +171,8 @@ | isFloat left || isFloat right = VFloat <$> (floatOp <$> expectFloat left <*> expectFloat right) | otherwise = either throwEvalError (pure . VInt) =<< (checkedOp <$> expectInt left <*> expectInt right) +-- | 'primArith' with 64-bit integer overflow an evaluation error: +-- @builtins.add@; @-@ and @builtins.sub@; @*@ and @builtins.mul@. primAdd, primSub, primMul :: (MonadEval m) => NixValue -> NixValue -> m NixValue primAdd = primArith checkedAdd (+) primSub = primArith checkedSub (-) @@ -363,7 +365,7 @@ expectSet other = throwEvalError ("expected a set but found " <> typeName other <> ": " <> printValue PrintForError other) --- | Merge two 'AttrSet's, right-biased (@//@). +-- | Merge two t'AttrSet's, right-biased (@//@). -- Delegates to C-side @nn_attrset_union@ which performs a linear merge -- of two sorted arrays - O(n+m) on contiguous, cache-friendly memory. -- diff --git a/src/Nix/Eval/Policy.hs b/src/Nix/Eval/Policy.hs --- a/src/Nix/Eval/Policy.hs +++ b/src/Nix/Eval/Policy.hs @@ -1,5 +1,7 @@ -- | The evaluation policy: upstream's @restrict-eval@ and @pure-eval@ --- settings, the @allowed-uris@ list, and the pure decisions they drive. +-- settings, the @allowed-uris@ list, and the pure decisions they drive, +-- plus the @trace-verbose@ setting, which decides what +-- @builtins.traceVerbose@ does. -- -- Upstream gates evaluation in two layers (@src/libexpr/eval.cc@ at -- 2.24.9). Under either setting the root filesystem is wrapped in an @@ -11,7 +13,7 @@ -- @allowed-uris@ (@checkURI@). @pure-eval@ additionally empties the -- search path, hides the impure constants, and makes the fetchers demand -- a hash or revision; those decisions live with the builtins and consult --- 'EvalPolicy' through 'Nix.Eval.Types.MonadEval'. +-- t'EvalPolicy' through 'Nix.Eval.Types.MonadEval'. -- -- Everything here is pure so each rule can be tested on its own. The -- filesystem side (walking a path through its symlinks, prefix by @@ -37,6 +39,7 @@ -- * Allowed URIs isAllowedUri, uriAccess, + fileUrlPrefix, forbiddenUriMessage, ) where @@ -48,15 +51,17 @@ import Data.Text (Text) import qualified Data.Text as T import Nix.Eval.CanonPath (canonPathValue) +import Nix.Store.Path (StoreDir, qualifyPathText) -- --------------------------------------------------------------------------- -- Policy -- --------------------------------------------------------------------------- --- | What an evaluation may reach. The two flags are independent, as --- upstream's settings are: @pure-eval@ does not imply the URI check --- (@checkURI@ consults @restrictEval@ alone), and @restrict-eval@ does --- not hide the impure constants or empty the search path. +-- | What an evaluation may reach, and whether @builtins.traceVerbose@ +-- traces. The two modes are independent, as upstream's settings are: +-- @pure-eval@ does not imply the URI check (@checkURI@ consults +-- @restrictEval@ alone), and @restrict-eval@ does not hide the impure +-- constants or empty the search path. data EvalPolicy = EvalPolicy { -- | Upstream @restrict-eval@: filesystem reads are confined to the -- allowed prefixes, @getEnv@ answers empty, and a fetch must match @@ -68,13 +73,17 @@ epPureEval :: !Bool, -- | Upstream @allowed-uris@: prefixes a fetch may reach under -- @restrict-eval@. - epAllowedUris :: ![Text] + epAllowedUris :: ![Text], + -- | Upstream @trace-verbose@: @builtins.traceVerbose@ traces as + -- @builtins.trace@ does, where otherwise it returns its second + -- argument without forcing its first. + epTraceVerbose :: !Bool } deriving (Eq, Show) --- | Upstream's default: both settings off, nothing listed. +-- | Upstream's default: every setting off, nothing listed. unrestrictedPolicy :: EvalPolicy -unrestrictedPolicy = EvalPolicy {epRestrictEval = False, epPureEval = False, epAllowedUris = []} +unrestrictedPolicy = EvalPolicy {epRestrictEval = False, epPureEval = False, epAllowedUris = [], epTraceVerbose = False} -- | Whether filesystem access goes through the allow list: upstream wraps -- the root filesystem when either setting is on. @@ -145,7 +154,10 @@ -- | Whether a path's text is rooted: a leading @/@, or a drive designator -- (a canonical Windows path value spells @C:/...@). The gates refuse -- anything else, since a relative path would be checked against one --- location and opened at another. +-- location and opened at another. A leading @/@ with no drive is fixed +-- in place too: on Windows it names the store directory's drive +-- ('Nix.Store.Path.qualifyPathText'), which the gates check and the +-- reads open. isAbsolutePath :: Text -> Bool isAbsolutePath path = T.isPrefixOf "/" path || hasDrive where @@ -206,9 +218,11 @@ -- a @file://@ URL, is checked against the allowed paths instead -- (upstream passes the remainder through @CanonPath@, so a rootless -- remainder is rooted, and one that spells a drive, @file://C:/...@, is --- rooted already); anything else is refused. -uriAccess :: EvalPolicy -> AllowedPaths -> Text -> Either Text () -uriAccess policy allowed uri +-- rooted already); anything else is refused. The path is checked on the +-- drive the given store directory puts it on ('qualifyPathText'), the +-- one the fetch reads it from. +uriAccess :: StoreDir -> EvalPolicy -> AllowedPaths -> Text -> Either Text () +uriAccess storeDir policy allowed uri | not (epRestrictEval policy) = Right () | isAllowedUri (epAllowedUris policy) uri = Right () | T.isPrefixOf "/" uri = pathAccess uri @@ -217,9 +231,10 @@ where rooted rest = if isAbsolutePath rest then rest else "/" <> rest pathAccess path = - let canonical = canonPathValue path + let canonical = qualifyPathText storeDir (canonPathValue path) in if isAllowedPath allowed canonical then Right () else Left (forbiddenPathMessage policy canonical) +-- | What a local file URL begins with, its path or its drive after it. fileUrlPrefix :: Text fileUrlPrefix = "file://" diff --git a/src/Nix/Eval/SourcePos.hs b/src/Nix/Eval/SourcePos.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Eval/SourcePos.hs @@ -0,0 +1,112 @@ +-- | Source positions as the evaluator keeps them: a t'PosIdx' stored beside +-- an attribute, read back as a file, line and column on demand. +-- +-- A position is recorded when the construct it belongs to is compiled, as +-- three words in the bytecode data buffer: the interned path of the file it +-- is in ('noFile' for text with no file behind it), its line and its column. +-- Its index is one past the record's offset, so 0 is free to mean no +-- position, the bias upstream's @PosIdx@ carries for the same reason +-- (@noPos@ in pos-idx.hh, @PosTable::add@ in pos-table.hh, at 2.24.9). +-- The record lives as long as the bytecode that refers to it, and is +-- never written again. +module Nix.Eval.SourcePos + ( -- * Indices + PosIdx (..), + noPos, + + -- * Recording + PosRecorder, + newPosRecorder, + recordPos, + + -- * Reading back + RecordedPos (..), + lookupPos, + ) +where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Word (Word32) +import Nix.Eval.CBytecode (cbcData, cbcEmitData) +import Nix.Eval.Symbol (Symbol (..), symbolIntern, symbolText) +import Nix.Expr.Types (SourceOrigin (..), SrcPos (..)) +import System.IO.Unsafe (unsafePerformIO) + +-- | Where something was defined: 'noPos', or the index of a recorded +-- position. +newtype PosIdx = PosIdx {unPosIdx :: Word32} + deriving (Eq, Show) + +-- | Defined nowhere in source: a builtin's attribute, or one a builtin +-- made. +noPos :: PosIdx +noPos = PosIdx 0 + +-- | The file word of a position in text with no file. No symbol is 0 +-- (@NN_SYMBOL_INVALID@), so it cannot be mistaken for a path. +noFile :: Word32 +noFile = 0 + +-- | Records the positions of one compilation. It remembers the last +-- origin it recorded and that origin's file word, because the positions +-- of one parse share their origin, and interning the path again for each +-- one would copy and hash it as many times. +newtype PosRecorder = PosRecorder (IORef (Maybe SeenOrigin)) + +-- | An origin and its file word. +data SeenOrigin = SeenOrigin !SourceOrigin !Word32 + +-- | A recorder that has seen no origin yet. +newPosRecorder :: IO PosRecorder +newPosRecorder = PosRecorder <$> newIORef Nothing + +-- | Record a position for the evaluator to read back. A line or column +-- past 32 bits records 'noPos', as upstream's position table cannot +-- address one either. +recordPos :: PosRecorder -> SrcPos -> IO PosIdx +recordPos (PosRecorder seen) (SrcPos origin line column) = case (toWord32 line, toWord32 column) of + (Just lineWord, Just columnWord) -> do + file <- fileWord + offset <- cbcEmitData file + _ <- cbcEmitData lineWord + _ <- cbcEmitData columnWord + pure (PosIdx (offset + 1)) + _ -> pure noPos + where + fileWord = do + remembered <- readIORef seen + case remembered of + Just (SeenOrigin known word) | known == origin -> pure word + _ -> do + word <- internedFile origin + writeIORef seen (Just (SeenOrigin origin word)) + pure word + internedFile (SourceFile path) = unSymbol <$> symbolIntern path + internedFile (SourceText _) = pure noFile + toWord32 n + | n >= 0 && toInteger n <= toInteger (maxBound :: Word32) = Just (fromIntegral n) + | otherwise = Nothing + +-- | A recorded position, read back. +data RecordedPos + = -- | A line and column in the file at this path. + PosInFile !Text !Int !Int + | -- | A line and column in text with no file behind it. + PosInText !Int !Int + deriving (Eq, Show) + +-- | Read a position back, or 'Nothing' for 'noPos'. 'unsafePerformIO' is +-- safe here: the record was written once, when its index was made, and +-- no later write touches it, so the read answers the same every time. +lookupPos :: PosIdx -> Maybe RecordedPos +lookupPos (PosIdx 0) = Nothing +lookupPos (PosIdx idx) = Just $ unsafePerformIO $ do + let offset = idx - 1 + file <- cbcData offset + line <- fromIntegral <$> cbcData (offset + 1) + column <- fromIntegral <$> cbcData (offset + 2) + pure $ + if file == noFile + then PosInText line column + else PosInFile (symbolText (Symbol file)) line column diff --git a/src/Nix/Eval/Symbol.hs b/src/Nix/Eval/Symbol.hs --- a/src/Nix/Eval/Symbol.hs +++ b/src/Nix/Eval/Symbol.hs @@ -86,7 +86,7 @@ symbolInit = c_nn_symbol_init -- | Destroy the global symbol table, freeing all C-side memory. --- All 'Symbol' values become invalid after this call. +-- All t'Symbol' values become invalid after this call. symbolDestroy :: IO () symbolDestroy = c_nn_symbol_destroy @@ -94,7 +94,7 @@ -- Core operations -- --------------------------------------------------------------------------- --- | Intern a 'Text' value, returning its 'Symbol'. +-- | Intern a 'Text' value, returning its t'Symbol'. -- If the string was already interned, returns the existing symbol. -- This is the canonical entry point for Text to C conversion; the table -- stores the UTF-8 bytes, so a 'Text' and its 'Data.Text.Encoding.encodeUtf8' @@ -104,7 +104,7 @@ TF.withCStringLen txt $ \(ptr, len) -> checkedSymbol =<< c_nn_symbol_intern ptr (fromIntegral len) --- | Intern raw bytes, returning their 'Symbol'. The C table is +-- | Intern raw bytes, returning their t'Symbol'. The C table is -- length-prefixed bytes with no encoding assumption, so arbitrary -- (even invalid-UTF-8) byte strings intern losslessly. The canonical -- entry point for string VALUES, whose payload is a byte string. @@ -116,7 +116,7 @@ checkedSymbol =<< c_nn_symbol_intern ptr (fromIntegral len) -- | Reject the interner's failure sentinel before it can become a --- 'Symbol': wrapped it would read back as the empty string. The table +-- t'Symbol': wrapped it would read back as the empty string. The table -- answers it outside its init .. destroy window, and inside it for a -- string it cannot hold: one that would take the string arena past its -- 4 GiB of uint32 offsets, or a growth the allocator refuses. diff --git a/src/Nix/Eval/Types.hs b/src/Nix/Eval/Types.hs --- a/src/Nix/Eval/Types.hs +++ b/src/Nix/Eval/Types.hs @@ -3,12 +3,13 @@ -- | Shared types for the Nix evaluator. -- --- Extracted into its own module so that 'Nix.Eval.Operator', --- 'Nix.Eval.StringInterp', and 'Nix.Builtins' can all reference --- 'NixValue', 'Thunk', and 'Env' without creating import cycles. +-- Extracted into its own module so that "Nix.Eval.Operator", +-- "Nix.Eval.StringInterp", and "Nix.Builtins" can all reference +-- 'NixValue', t'Thunk', and t'Env' without creating import cycles. module Nix.Eval.Types ( -- * Values NixValue (..), + BuiltinArg (..), CompiledRegex (..), Thunk (..), readThunkValue, @@ -17,10 +18,13 @@ -- * Attribute sets (C-backed sorted arrays) AttrSet (..), CAttrSet, + AttrEntry (..), attrSetLookup, + attrSetLookupEntry, attrSetKeys, attrSetToMap, attrSetFromMap, + attrSetFromEntries, attrSetMember, attrSetNull, attrSetSize, @@ -135,7 +139,7 @@ import Foreign.Storable (peekElemOff, pokeElemOff) import GHC.Float (castWord64ToDouble) import Nix.Derivation (Derivation) -import Nix.Eval.CAttrSet (CAttrSet, cattrsetFreeze, cattrsetGetKey, cattrsetGetValue, cattrsetIndex, cattrsetInsert, cattrsetKeys, cattrsetLookup, cattrsetNew, cattrsetRemoveKeys, cattrsetSetValue, cattrsetSize) +import Nix.Eval.CAttrSet (CAttrSet, cattrsetFreeze, cattrsetGetKey, cattrsetGetPos, cattrsetGetValue, cattrsetIndex, cattrsetInsert, cattrsetKeys, cattrsetLookup, cattrsetNew, cattrsetRemoveKeys, cattrsetSetValue, cattrsetSize) import Nix.Eval.CBytecode (cbcArg1, cbcArg2, cbcCountedPayload, cbcData, cbcOpcode, cbcShortArg, pattern OpList, pattern OpLitBool, pattern OpLitFloat, pattern OpLitInt, pattern OpLitNull, pattern OpLitPath, pattern OpLitUri, pattern OpResolvedVar, pattern OpStr) import Nix.Eval.CCtxStr (CCtxStrPtr, cctxstrCtxCount, cctxstrElemHash, cctxstrElemName, cctxstrElemOutput, cctxstrElemTag, cctxstrNew, cctxstrSetAllOutputs, cctxstrSetDrvOutput, cctxstrSetPlain, cctxstrText) import Nix.Eval.CEnv (NnEnv, cenvAllocSlots, cenvAllocWithScopes, cenvEmpty, cenvFromSlots, cenvLazyScope, cenvLookupResolved, cenvNew, cenvNewMinimal, cenvParent, cenvPushWith, cenvRootScope, cenvSlotCount, cenvWithCount, cenvWithScopes) @@ -148,9 +152,10 @@ import Nix.Eval.Compile (compileExpr, compileFormalsToEval) import Nix.Eval.EvalFormals (EvalFormal (..), EvalFormals (..)) import Nix.Eval.Policy (EvalPolicy (..), unrestrictedPolicy) +import Nix.Eval.SourcePos (PosIdx, noPos) import Nix.Eval.Symbol (Symbol (..), symbolBytes, symbolIntern, symbolInternBytes, symbolText) import Nix.Expr.Types (CaptureInfo (..), Expr (..), NixAtom (..)) -import Nix.Store.Path (StorePath, StorePathNameError, storePathNameErrorText) +import Nix.Store.Path (BadStorePath, StorePath, badStorePathText) import Nix.Store.Path.Internal (StorePath (StorePath)) import System.IO.Unsafe (unsafePerformIO) import qualified Text.Regex.TDFA as RE @@ -227,7 +232,7 @@ -- -- The C thunk is allocated via 'unsafePerformIO' in 'mkThunk' (same -- pattern as the former IORef-based approach) so that knot-tying works --- unchanged. Arena pointers remain valid until 'cthunkDestroy'. +-- unchanged. Arena pointers remain valid until 'Nix.Eval.CThunk.cthunkDestroy'. newtype Thunk = Thunk {unThunk :: CThunkPtr} instance Show Thunk where @@ -340,14 +345,25 @@ VAttrs !AttrSet | -- | Lambda closure: captures environment, formals, body bytecode index. VLambda !Env !EvalFormals !Word32 - | -- | Built-in function, dispatched by name. - -- Accumulated args support curried partial application. - VBuiltin !Text ![NixValue] + | -- | Built-in function, dispatched by name, with the arguments a + -- partial application has taken so far, first to last. + VBuiltin !Text ![BuiltinArg] | -- | Pre-compiled regex carried in a partially-applied builtin. -- Internal only - never exposed to Nix code directly. VCompiledRegex !CompiledRegex deriving (Eq, Show) +-- | An argument a builtin has taken. A primop that forces an argument +-- before anything it does can be observed has it forced as it is +-- applied. One that forces it later, after another argument or only on +-- some paths, has it held as the thunk it arrived as, and forces it where +-- upstream does. An argument that arrives already forced is held forced +-- either way. +data BuiltinArg + = ArgForced !NixValue + | ArgDeferred !Thunk + deriving (Eq, Show) + -- --------------------------------------------------------------------------- -- Attribute sets (C-backed sorted arrays) -- --------------------------------------------------------------------------- @@ -369,6 +385,13 @@ let n = unsafePerformIO (cattrsetSize cset) in "" +-- | An attribute's value and the position it was defined at, as a set +-- holds them. +data AttrEntry = AttrEntry + { entryPos :: {-# UNPACK #-} !PosIdx, + entryThunk :: {-# UNPACK #-} !Thunk + } + -- | Look up a single key via symbol interning + C binary search. -- Uses 'unsafePerformIO' - safe because symbolIntern and cattrsetLookup -- are idempotent (same key always yields same symbol and same result). @@ -379,7 +402,18 @@ mptr <- cattrsetLookup cset sym pure (fmap Thunk mptr) --- | All keys in sorted order (symbol text from C). +-- | 'attrSetLookup' with the attribute's position. 'unsafePerformIO' is +-- safe for the reason it is in 'attrSetLookup': the same key reads the +-- same entry every time. +attrSetLookupEntry :: Text -> AttrSet -> Maybe AttrEntry +attrSetLookupEntry key (AttrSet cset) = + unsafePerformIO $ do + sym <- symbolIntern key + midx <- cattrsetIndex cset sym + traverse (\idx -> AttrEntry <$> cattrsetGetPos cset idx <*> (Thunk <$> cattrsetGetValue cset idx)) midx + +-- | All keys, as symbol text from C, in the C array's order: by interned +-- symbol, not by name. attrSetKeys :: AttrSet -> [Text] attrSetKeys (AttrSet cset) = map symbolText (unsafePerformIO (cattrsetKeys cset)) @@ -447,34 +481,49 @@ attrSetUnionWith :: (Thunk -> Thunk -> Thunk) -> AttrSet -> AttrSet -> AttrSet attrSetUnionWith f a b = attrSetFromMap (Map.unionWith f (attrSetToMap a) (attrSetToMap b)) --- | Build a CAttrSet from a Haskell 'Map'. Interns all keys as symbols, --- inserts key-value pairs, freezes (sort + dedup). The canonical entry --- point for all attribute set construction. +-- | Build a CAttrSet from a Haskell 'Map' of attributes defined nowhere in +-- source, as those of a set a builtin makes from scratch are; a builtin +-- that copies attributes keeps their positions with 'attrSetFromEntries'. +-- Interns all keys as symbols, inserts key-value pairs, freezes (sort + +-- dedup). -- -- Uses 'unsafePerformIO' with @NOINLINE@ - safe because C allocation -- is idempotent and the resulting CAttrSet is referentially transparent. {-# NOINLINE attrSetFromMap #-} attrSetFromMap :: Map Text Thunk -> AttrSet -attrSetFromMap m = m `seq` unsafePerformIO $ do - let pairs = Map.toList m - cset <- cattrsetNew (length pairs) - forM_ pairs $ \(key, Thunk ptr) -> do +attrSetFromMap m = m `seq` AttrSet (unsafePerformIO (newFrozenAttrSet (const noPos) id m)) + +-- | 'attrSetFromMap' for attributes that keep the positions they were +-- defined at, as an attribute set literal's and a copied attribute's do. +{-# NOINLINE attrSetFromEntries #-} +attrSetFromEntries :: Map Text AttrEntry -> AttrSet +attrSetFromEntries m = m `seq` AttrSet (unsafePerformIO (newFrozenAttrSet entryPos entryThunk m)) + +-- | Insert every entry of a map into a new set, at the position and with +-- the thunk the projections give it, and freeze it. +{-# INLINE newFrozenAttrSet #-} +newFrozenAttrSet :: (a -> PosIdx) -> (a -> Thunk) -> Map Text a -> IO CAttrSet +newFrozenAttrSet posOf thunkOf m = do + cset <- cattrsetNew (Map.size m) + forM_ (Map.toList m) $ \(key, entry) -> do sym <- symbolIntern key - cattrsetInsert cset sym ptr + cattrsetInsert cset sym (posOf entry) (unThunk (thunkOf entry)) cattrsetFreeze cset - pure (AttrSet cset) + pure cset --- | Allocate a CAttrSet skeleton with keys only (NULL values). +-- | Allocate a CAttrSet skeleton with keys only (NULL values), for an +-- environment's name table. -- Used for two-phase construction in @rec {}@ and @let@ (knot-tying): -- keys are known before thunks, so the CAttrSet is built first, then --- values are filled via 'fillCAttrSetValues'. +-- values are filled via 'fillCAttrSetValues'. The table is never a +-- value, so its entries carry no position. {-# NOINLINE buildCAttrSetKeys #-} buildCAttrSetKeys :: [Text] -> CAttrSet buildCAttrSetKeys keys = unsafePerformIO $ do cset <- cattrsetNew (length keys) forM_ keys $ \key -> do sym <- symbolIntern key - cattrsetInsert cset sym nullPtr + cattrsetInsert cset sym noPos nullPtr cattrsetFreeze cset pure cset @@ -523,7 +572,7 @@ ++ " withs}" -- | Empty environment (no variables in scope). --- Points to a static global C struct - valid until 'arenaDestroy'. +-- Points to a static global C struct - valid until 'Nix.Eval.Arena.arenaDestroy'. {-# NOINLINE emptyEnv #-} emptyEnv :: Env emptyEnv = Env (unsafePerformIO cenvEmpty) @@ -585,8 +634,8 @@ -- | Walk with-scopes (C array) innermost to outermost. -- Skips tagged lazy entries (bit 0 set) - those are thunk pointers --- that can only be resolved by 'evalWithVarScopes' which has monadic --- 'force'. Defensive: an 'EVar' under a with is either a lexical +-- that can only be resolved by @evalWithVarScopes@ which has monadic +-- 'Nix.Eval.force'. Defensive: an 'EVar' under a with is either a lexical -- (barrier) binding or a static global, both found on the parent chain -- before this fallback fires ('EVar' also blocks closure trimming, so -- the chain is always intact) - but keep it for safety. @@ -716,7 +765,7 @@ cheapThunk env expr = mkThunk env expr -- | Create a pending thunk from a bytecode index (no compilation needed). --- Used inside 'evalBytecode' where the bc_idx is already known. +-- Used inside 'Nix.Eval.evalBytecode' where the bc_idx is already known. -- The Env is captured LAZILY (for knot-tying in rec attrs / let / matchFormalSet). mkThunkBc :: Env -> Word32 -> Thunk mkThunkBc env bcIdx = @@ -1080,7 +1129,7 @@ $ cset `seq` cthunkNewComputedAttrs (castPtr cset) --- | Build a C-allocated slot array from a list of 'Thunk' values. +-- | Build a C-allocated slot array from a list of t'Thunk' values. -- Each thunk is converted to 'CThunkPtr' via 'thunkToCPtr'. -- Returns the C array pointer and the slot count. -- Uses 'unsafePerformIO' - safe because allocation is idempotent. @@ -1184,7 +1233,7 @@ deriving (Eq, Show) -- | Effect class for Nix evaluation. Core logic is polymorphic in @m@ --- so the same evaluator composes into 'PureEval' for tests or @IO@ for +-- so the same evaluator composes into t'PureEval' for tests or @IO@ for -- real file-system access (e.g. @import@, @readFile@). class (Monad m) => MonadEval m where -- | Raise an evaluation error (type error, missing attribute, IO @@ -1327,7 +1376,7 @@ -- still on disk, and recorded as this evaluation's own store write in -- that case. Reusing a path instead of rewriting it must still leave the -- registration behind, or the build driver never registers it and a - -- derivation naming it fails with \"references unregistered path\". + -- derivation naming it fails with \"path \'...\' is not valid\". adoptStorePath :: Text -> m Bool -- | Record a fetch under that key. Failing to record is not an error - @@ -1410,9 +1459,10 @@ -- | The policy this evaluation runs under. The builtins whose behaviour -- upstream changes by setting consult it: @storePath@ is refused and the - -- fetchers demand a hash or revision under @pure-eval@, and a search path - -- miss is worded for the mode. The filesystem and URI gates are not - -- decided here; they live in the instance, where the allowed set is. + -- fetchers demand a hash or revision under @pure-eval@, a search path + -- miss is worded for the mode, and @traceVerbose@ traces only under + -- @trace-verbose@. The filesystem and URI gates are not decided here; + -- they live in the instance, where the allowed set is. evalPolicy :: m EvalPolicy -- | Upstream @checkURI@: refuse a fetch of this URI under @restrict-eval@ @@ -1421,18 +1471,24 @@ -- Every fetcher calls it before anything is spawned or downloaded. checkUri :: Text -> m () + -- | A path named on the drive this evaluation reads it on + -- ('Nix.Store.Path.qualifyPathText' against its store directory): on + -- Windows a rooted path with no drive gains the store's. For a + -- fetcher handing a local path to another program, which would + -- otherwise read it on whatever drive that program has current. + qualifyPath :: Text -> m Text + -- | Unwrap a store-path construction result (the @makeStorePath@ family --- in "Nix.Hash"), converting a rejected name into an eval error under --- the given context prefix (e.g. @builtins.toFile@). Every eval-side --- path construction goes through this or a bespoke equivalent, so a --- name rejection always surfaces as a clean eval error rather than an --- unchecked write path. -storePathOrThrow :: (MonadEval m) => Text -> Either StorePathNameError StorePath -> m StorePath -storePathOrThrow context = - either (throwEvalError . ((context <> ": ") <>) . storePathNameErrorText) pure +-- in "Nix.Hash"), raising a refused name as upstream's @BadStorePath@ +-- text. The message names the path and not the builtin, as upstream's +-- does: upstream names the builtin in its trace. Every eval-side path +-- construction goes through this, so a refused name is an eval error +-- before anything is written. +storePathOrThrow :: (MonadEval m) => Either BadStorePath StorePath -> m StorePath +storePathOrThrow = either (throwEvalError . badStorePathText) pure -- | Error raised during pure evaluation. 'PThrow' (@builtins.throw@, a --- failed @assert@) is the only kind 'tryEval' catches; 'PError' (type +-- failed @assert@) is the only kind @tryEval@ catches; 'PError' (type -- errors, missing attributes) and 'PAbort' (@abort@, infinite recursion) -- escape it, exactly as in C++ Nix. data PureError = PThrow !Text | PError !Text | PAbort !Text @@ -1452,7 +1508,7 @@ pureFailure = PureEval . lift . Left -- | Run a pure evaluation, flattening the internal error into 'Text'. An abort --- is prefixed @\"evaluation aborted: \"@, matching 'EvalIO'. +-- is prefixed @\"evaluation aborted: \"@, matching t'Nix.Eval.IO.EvalIO'. runPureEval :: PureEval a -> Either Text a runPureEval (PureEval action) = case runReaderT action (topLevelCallDepth defaultMaxCallDepth) of @@ -1531,6 +1587,9 @@ storeSourcePath = pure evalPolicy = pure unrestrictedPolicy checkUri _ = pure () + + -- No filesystem, so no drive to read on: a path names itself. + qualifyPath = pure resolvePathLiteral = pure . canonPathValue forceThunk evalFn (Thunk ptr) = -- Read the C thunk via unsafePerformIO - safe because reads are diff --git a/src/Nix/Expr/ClosureTrim.hs b/src/Nix/Expr/ClosureTrim.hs --- a/src/Nix/Expr/ClosureTrim.hs +++ b/src/Nix/Expr/ClosureTrim.hs @@ -1,10 +1,10 @@ -- | Closure trimming pass: rewrites lambdas, let blocks, and recursive -- attr sets to capture only the free variables they actually use. -- --- Without trimming, every 'VLambda' and every let\/rec binding thunk --- retains the ENTIRE parent 'Env' chain. A scope using 3 variables +-- Without trimming, every 'Nix.Eval.Types.VLambda' and every let\/rec binding thunk +-- retains the ENTIRE parent t'Nix.Eval.Types.Env' chain. A scope using 3 variables -- retains a 30k-entry nixpkgs scope. This pass, run after --- 'resolveVars', attaches a 'Captures' list to each trimmable +-- 'Nix.Expr.Resolve.resolveVars', attaches a 'Captures' list to each trimmable -- 'ELambda', 'ELet', and recursive 'EAttrs' so the evaluator can -- build a flat env with @envParent = Nothing@, breaking the retention -- chain. @@ -40,7 +40,7 @@ ELit {} -> expr EStr parts -> EStr (map trimPart parts) EIndStr parts -> EIndStr (map trimPart parts) - EPathStr parts -> EPathStr (map trimPart parts) + EPathStr headPiece parts -> EPathStr headPiece (map trimPart parts) EVar {} -> expr EWithVar {} -> expr EResolvedVar {} -> expr @@ -121,9 +121,9 @@ trimKey (DynamicKey e) = DynamicKey (trimExpr e) trimBinding :: Binding -> Binding -trimBinding (NamedBinding key bodyExpr) = - NamedBinding (trimKey key) (trimExpr bodyExpr) -trimBinding (Inherit name var) = Inherit name (trimExpr var) +trimBinding (NamedBinding pos key bodyExpr) = + NamedBinding pos (trimKey key) (trimExpr bodyExpr) +trimBinding (Inherit pos name var) = Inherit pos name (trimExpr var) trimBinding (InheritFrom fromExpr names) = InheritFrom (trimExpr fromExpr) names @@ -173,7 +173,8 @@ -- the outer scope (not shadowed by inner let/rec/lambda scopes) -- * @hasOuterWithVar@ is 'True' if there's any 'EWithVar' that needs -- with-scope access (doesn't block trimming, but env must preserve --- 'envWithScopes' with builtins appended) +-- its with-scopes ('Nix.Eval.Types.envWithScopesRaw') with builtins +-- appended) -- -- @depth@ tracks how many scope-creating constructs we've entered -- inside the lambda body (nested lambdas, let, rec attrs). @@ -182,7 +183,7 @@ ELit {} -> (Set.empty, False, False) EStr parts -> foldParts depth parts EIndStr parts -> foldParts depth parts - EPathStr parts -> foldParts depth parts + EPathStr _ parts -> foldParts depth parts EVar _ -> -- Any EVar in the body means we need the parent chain for name lookup. -- This makes the lambda untrimable. @@ -297,11 +298,11 @@ foldBindings :: Int -> Maybe Int -> [Binding] -> (Set (Int, Int), Bool, Bool) foldBindings depth outerDepth = foldl' combine (Set.empty, False, False) where - combine (!acc, !h, !w) (NamedBinding key bodyExpr) = + combine (!acc, !h, !w) (NamedBinding _ key bodyExpr) = let (vs1, h1, w1) = foldKeys depth [key] (vs2, h2, w2) = collectFreeVars depth bodyExpr in (Set.unions [acc, vs1, vs2], h || h1 || h2, w || w1 || w2) - combine (!acc, !h, !w) (Inherit _ var) = case outerDepth of + combine (!acc, !h, !w) (Inherit _ _ var) = case outerDepth of Nothing -> (acc, h, w) Just outer -> let (vs, hv, wv) = collectFreeVars outer var @@ -328,14 +329,14 @@ -- -- An outer reference @EResolvedVar level idx@ where @level > depth@ -- maps to @EResolvedVar (depth + 1) captureIdx@. The @depth + 1@ --- accounts for the fact that 'matchFormals' creates an argEnv with +-- accounts for the fact that @matchFormals@ creates an argEnv with -- @envParent = trimmedEnv@, so level 0 = formals, level 1 = captures. rewriteBody :: Int -> Map (Int, Int) Int -> Expr -> Expr rewriteBody depth captureMap expr = case expr of ELit {} -> expr EStr parts -> EStr (map (rewritePart depth captureMap) parts) EIndStr parts -> EIndStr (map (rewritePart depth captureMap) parts) - EPathStr parts -> EPathStr (map (rewritePart depth captureMap) parts) + EPathStr headPiece parts -> EPathStr headPiece (map (rewritePart depth captureMap) parts) EVar {} -> expr EWithVar {} -> expr EResolvedVar level idx @@ -400,12 +401,13 @@ -- | Rewrite a binding's references, at the depths 'foldBindings' reads -- them at; an inherited variable outside the analysis is left as it is. rewriteBinding :: Int -> Maybe Int -> Map (Int, Int) Int -> Binding -> Binding -rewriteBinding depth _ captureMap (NamedBinding key bodyExpr) = +rewriteBinding depth _ captureMap (NamedBinding pos key bodyExpr) = NamedBinding + pos (rewriteKey depth captureMap key) (rewriteBody depth captureMap bodyExpr) -rewriteBinding _ outerDepth captureMap (Inherit name var) = - Inherit name (maybe var (\outer -> rewriteBody outer captureMap var) outerDepth) +rewriteBinding _ outerDepth captureMap (Inherit pos name var) = + Inherit pos name (maybe var (\outer -> rewriteBody outer captureMap var) outerDepth) rewriteBinding depth _ captureMap (InheritFrom fromExpr names) = InheritFrom (rewriteBody depth captureMap fromExpr) names diff --git a/src/Nix/Expr/Resolve.hs b/src/Nix/Expr/Resolve.hs --- a/src/Nix/Expr/Resolve.hs +++ b/src/Nix/Expr/Resolve.hs @@ -35,6 +35,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import Nix.Expr.Types import System.FilePath (isRelative, ()) @@ -76,7 +77,7 @@ ELit _ -> Right expr EStr parts -> EStr <$> traverse (resolvePart stack) parts EIndStr parts -> EIndStr <$> traverse (resolvePart stack) parts - EPathStr parts -> EPathStr <$> traverse (resolvePart stack) parts + EPathStr headPiece parts -> EPathStr headPiece <$> traverse (resolvePart stack) parts EVar name -> resolveVar stack name EResolvedVar _ _ -> Right expr EAttrs True bindings _captureInfo @@ -143,7 +144,7 @@ stack ( EApp (EApp (EVar "__findFile") (EVar "__nixPath")) - (EStr [StrLit name]) + (EStr [StrLit (TE.encodeUtf8 name)]) ) where recAttrs resolved = EAttrs True resolved NoCaptureInfo @@ -184,14 +185,13 @@ -- | A temporary accommodation. Upstream's parser reads @__curPos@ as a -- position expression, never a variable (parser.y at 2.24.9, expr_simple), --- so binding never sees it. Here it still parses as a variable, because --- building the position needs to know whether the source is a file --- (upstream's position set) or a string (upstream's null), and 'parseNix' --- carries only a name. Until it does, the name is exempt from the check and --- fails when forced, as before binding checked anything; nixpkgs uses it in --- files every NixOS evaluation imports. Delete the exemption when --- 'parseNix' carries the file-or-string origin and the parser builds the --- position. +-- so binding never sees it. Here it still parses as a variable: 'Nix.Parser.parseNix' +-- takes the source's origin, which decides between upstream's position set +-- (a file) and its null (a string), but no expression builds a position +-- from it. Until one does, the name is exempt from the check and fails +-- when forced, as before binding checked anything; nixpkgs uses it in files +-- every NixOS evaluation imports. Delete the exemption when the parser +-- builds the position. curPosName :: Text curPosName = "__curPos" @@ -213,7 +213,7 @@ -- @__@-prefixed upstream, so nixpkgs' @with pkgs; fetchurl@ binds -- @pkgs.fetchurl@. -- --- Layering keeps this module from importing 'Nix.Builtins', which builds +-- Layering keeps this module from importing "Nix.Builtins", which builds -- the root environment from this set; a test checks it against the list -- recorded from upstream's source. staticGlobalNames :: Set Text @@ -364,10 +364,10 @@ collectBindingNames :: [Binding] -> Set Text collectBindingNames = foldl' addNames Set.empty where - addNames acc (NamedBinding (StaticKey name) _) = Set.insert name acc - addNames acc (NamedBinding _ _) = acc - addNames acc (Inherit name _) = Set.insert name acc - addNames acc (InheritFrom _ names) = foldl' (flip Set.insert) acc names + addNames acc (NamedBinding _ (StaticKey name) _) = Set.insert name acc + addNames acc (NamedBinding {}) = acc + addNames acc (Inherit _ name _) = Set.insert name acc + addNames acc (InheritFrom _ names) = foldl' (flip Set.insert) acc [name | InheritedName _ name <- names] -- | Resolve variables inside string parts. resolvePart :: [ScopeEntry] -> StringPart -> Either Text StringPart @@ -384,9 +384,9 @@ -- no env level, so an inherited variable resolves where the set stands, -- like every other value. resolveBinding :: [ScopeEntry] -> Binding -> Either Text Binding -resolveBinding stack (NamedBinding key bodyExpr) = - NamedBinding <$> resolveKey stack key <*> resolve stack bodyExpr -resolveBinding stack (Inherit name var) = Inherit name <$> resolve stack var +resolveBinding stack (NamedBinding pos key bodyExpr) = + NamedBinding pos <$> resolveKey stack key <*> resolve stack bodyExpr +resolveBinding stack (Inherit pos name var) = Inherit pos name <$> resolve stack var resolveBinding stack (InheritFrom fromExpr names) = (`InheritFrom` names) <$> resolve stack fromExpr @@ -397,8 +397,8 @@ allStaticSingleKey :: [Binding] -> Bool allStaticSingleKey = all isEligible where - isEligible (NamedBinding (StaticKey _) _) = True - isEligible (Inherit _ _) = True + isEligible (NamedBinding _ (StaticKey _) _) = True + isEligible (Inherit {}) = True isEligible (InheritFrom _ _) = True isEligible _ = False @@ -412,9 +412,9 @@ LexicalScope (Map.fromList (zip names [0 ..])) where names = concatMap bindingNames bindings - bindingNames (NamedBinding (StaticKey name) _) = [name] - bindingNames (Inherit name _) = [name] - bindingNames (InheritFrom _ inheritNames) = inheritNames + bindingNames (NamedBinding _ (StaticKey name) _) = [name] + bindingNames (Inherit _ name _) = [name] + bindingNames (InheritFrom _ inheritNames) = [name | InheritedName _ name <- inheritNames] -- Unreachable: allStaticSingleKey guards this path. bindingNames _ = [] @@ -430,12 +430,12 @@ -- the inherited name references the enclosing scope, never the block being -- defined, whose own @x@ would make it a self-reference. resolveLetBinding :: [ScopeEntry] -> [ScopeEntry] -> Binding -> Either Text Binding -resolveLetBinding _ innerStack (NamedBinding key bodyExpr) = - NamedBinding <$> resolveKey innerStack key <*> resolve innerStack bodyExpr +resolveLetBinding _ innerStack (NamedBinding pos key bodyExpr) = + NamedBinding pos <$> resolveKey innerStack key <*> resolve innerStack bodyExpr resolveLetBinding _ innerStack (InheritFrom fromExpr names) = (`InheritFrom` names) <$> resolve innerStack fromExpr -resolveLetBinding outerStack _ (Inherit name var) = - Inherit name <$> resolve outerStack var +resolveLetBinding outerStack _ (Inherit pos name var) = + Inherit pos name <$> resolve outerStack var -- | Resolve variables inside formal default expressions. resolveFormalsDefaults :: [ScopeEntry] -> Formals -> Either Text Formals @@ -492,11 +492,11 @@ -- The head piece of an interpolated path is static text and gets -- the same absolutization as a plain literal, for the same -- closure-capture reason; the interpolated pieces only recurse. - EPathStr (StrLit headPiece : rest) + EPathStr headPiece rest | not (homeRelative headPiece), isRelative (T.unpack headPiece) -> - EPathStr (StrLit (T.pack (dir T.unpack headPiece)) : map goPart rest) - EPathStr parts -> EPathStr (map goPart parts) + EPathStr (T.pack (dir T.unpack headPiece)) (map goPart rest) + EPathStr headPiece parts -> EPathStr headPiece (map goPart parts) EVar _ -> expr EWithVar _ -> expr EResolvedVar _ _ -> expr @@ -521,8 +521,8 @@ StrInterp e -> StrInterp (goExpr e) goBinding binding = case binding of - NamedBinding key e -> NamedBinding (goKey key) (goExpr e) - Inherit name var -> Inherit name (goExpr var) + NamedBinding pos key e -> NamedBinding pos (goKey key) (goExpr e) + Inherit pos name var -> Inherit pos name (goExpr var) InheritFrom from names -> InheritFrom (goExpr from) names goKey key = case key of diff --git a/src/Nix/Expr/Types.hs b/src/Nix/Expr/Types.hs --- a/src/Nix/Expr/Types.hs +++ b/src/Nix/Expr/Types.hs @@ -2,7 +2,7 @@ -- -- Every Nix source file parses into an 'Expr'. The AST is a direct -- representation of the language grammar - no desugaring at parse time. --- The evaluator ('Nix.Eval') reduces expressions to values. +-- The evaluator ("Nix.Eval") reduces expressions to values. module Nix.Expr.Types ( -- * Expressions Expr (..), @@ -14,8 +14,14 @@ AttrPath, AttrKey (..), + -- * Source positions + SourceOrigin (..), + sourceName, + SrcPos (..), + -- * Bindings Binding (..), + InheritedName (..), -- * Formals (function parameters) Formals (..), @@ -33,6 +39,7 @@ ) where +import Data.ByteString (ByteString) import Data.Int (Int64) import Data.Text (Text) @@ -48,15 +55,16 @@ -- | A part of an interpolated string (@"hello ${name}"@). data StringPart - = -- | Literal text. - StrLit !Text - | -- | Resolved escape text inside an indented string (@'''@, @''$@, + = -- | Literal bytes, the source's with escapes resolved, which are the + -- bytes the value holds whether or not they are UTF-8. + StrLit !ByteString + | -- | Resolved escape bytes inside an indented string (@'''@, @''$@, -- @''${@, @''\x@). Kept apart from 'StrLit' because upstream's lexer -- emits an escape without the hasIndentation mark: the indentation -- scan skips it (it only ends a line's leading whitespace) while the -- strip runs over it as over any literal, so an escaped newline -- starts a line whose spaces are stripped but were never measured. - StrEsc !Text + StrEsc !ByteString | -- | Interpolated expression (@${expr}@). StrInterp !Expr deriving (Eq, Show) @@ -72,23 +80,59 @@ -- | Attribute path: @a.b.c@ is @[StaticKey "a", StaticKey "b", StaticKey "c"]@. type AttrPath = [AttrKey] --- | A binding in an attribute set or let expression. +-- | Where parsed source came from, which decides what a position in it +-- reports: upstream's positions make the same split (@Pos::Origin@, +-- position.hh at 2.24.9), and only one in a file names a file. +data SourceOrigin + = -- | A file, by the path it was read from. + SourceFile !Text + | -- | Text with no file behind it (an @--expr@ argument), by the name + -- its parse errors give it. + SourceText !Text + deriving (Eq, Show) + +-- | The name a parse error in the source gives it. +sourceName :: SourceOrigin -> Text +sourceName (SourceFile path) = path +sourceName (SourceText name) = name + +-- | A point in parsed source: where the source came from, and the 1-based +-- line and column (in characters) the lexer gives the token there. +data SrcPos + = SrcPos + -- | Where the source came from. + !SourceOrigin + -- | The line. + {-# UNPACK #-} !Int + -- | The column. + {-# UNPACK #-} !Int + deriving (Eq, Show) + +-- | A binding in an attribute set or let expression, at the position of +-- the attribute path or name that defines it. data Binding = -- | @key = expr;@. One key, as upstream's @ExprAttrs@ holds one name -- per definition (nixexpr.hh at 2.24.9): the parser hoists a dotted -- @a.b.c = v;@ into @a = { b = { c = v; }; };@ the way upstream's -- @addAttr@ does (parser-state.hh), so no binding carries a path. - NamedBinding !AttrKey !Expr + -- Every level of the hoisted path is at the path's first key, as + -- upstream gives each the position of the whole path. + NamedBinding !SrcPos !AttrKey !Expr | -- | One name of @inherit x y;@: the attribute and the variable it -- copies, which is bound and evaluated in the scope around the binding -- set rather than in the set itself, so @rec { inherit x; }@ does not -- name itself. Upstream's parser builds the same pair: an attribute of -- kind Inherited holding an ExprVar. - Inherit !Text !Expr + Inherit !SrcPos !Text !Expr | -- | @inherit (from) x y;@ - InheritFrom !Expr ![Text] + InheritFrom !Expr ![InheritedName] deriving (Eq, Show) +-- | One name of an @inherit (from) ...@ clause, at the position it is +-- written. +data InheritedName = InheritedName !SrcPos !Text + deriving (Eq, Show) + -- | A single formal parameter with optional default. data Formal = Formal { fName :: !Text, @@ -110,15 +154,16 @@ -- -- After 'Nix.Expr.ClosureTrim.trimClosures', lambdas that only reference -- a subset of their outer scope carry a 'Captures' list. At eval time --- this drives extraction of exactly those thunks into a flat 'Env', +-- this drives extraction of exactly those thunks into a flat t'Nix.Eval.Types.Env', -- breaking the retention chain to the full parent scope. data CaptureInfo = -- | No capture analysis performed (lambda untrimmed). NoCaptureInfo | -- | Sorted list of @(level, index)@ pairs to extract from the parent env. Captures ![(Int, Int)] - | -- | Like 'Captures', but the trimmed env must preserve 'envWithScopes' - -- (with builtins appended) so that 'EWithVar' references can still be resolved. + | -- | Like 'Captures', but the trimmed env must preserve its with-scopes + -- ('Nix.Eval.Types.envWithScopesRaw'), with builtins appended, so that + -- 'EWithVar' references can still be resolved. CapturesWithScopes ![(Int, Int)] deriving (Eq, Show) @@ -159,14 +204,16 @@ EStr ![StringPart] | -- | Indented string (double single-quoted). EIndStr ![StringPart] - | -- | Path literal with interpolations (@.\/${v}\/x@). The first - -- part is always the literal head piece. Evaluates to a path: - -- the pieces concatenate with no separator, each interpolation - -- coerced as a path segment (a path contributes its text without - -- a store copy; a string carrying store-path context is refused), - -- and the whole is canonicalized - the same semantics as the - -- @+@ chain @head + s1 + s2@, which upstream desugars it to. - EPathStr ![StringPart] + | -- | Path literal with interpolations (@.\/${v}\/x@): the literal + -- head piece, text because a relative one is joined to the base + -- directory ('Nix.Expr.Resolve.resolveRelativePaths'), and the pieces + -- after it. Evaluates to a path: the pieces concatenate with + -- no separator, each interpolation coerced as a path segment (a path + -- contributes its text without a store copy; a string carrying + -- store-path context is refused), and the whole is canonicalized - + -- the same semantics as the @+@ chain @head + s1 + s2@, which + -- upstream desugars it to. + EPathStr !Text ![StringPart] | -- | Variable reference. EVar !Text | -- | Attribute set: @{ bindings }@ or @rec { bindings }@. @@ -217,6 +264,7 @@ | -- | Variable resolved via with-scopes (not lexical). -- Produced by 'Nix.Expr.Resolve.resolveVars' for names inside -- a @with@ body that are not found in any lexical scope. - -- At runtime, looked up in 'envWithScopes' (with builtins fallback). + -- At runtime, looked up in the env's with-scopes + -- ('Nix.Eval.Types.envWithScopesRaw'), with builtins as the fallback. EWithVar !Text deriving (Eq, Show) diff --git a/src/Nix/Hash.hs b/src/Nix/Hash.hs --- a/src/Nix/Hash.hs +++ b/src/Nix/Hash.hs @@ -73,7 +73,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) -import Nix.Store.Path (StoreDir (..), StorePath, StorePathNameError, checkStorePathName, defaultStoreDir, storePathToText) +import Nix.Store.Path (BadStorePath (BadStorePath), StoreDir (..), StorePath, checkStorePathName, defaultStoreDir, storePathToText) import Nix.Store.Path.Internal (StorePath (StorePath)) import NovaCache.Base32 (encode) import NovaCache.Hash (formatNixHash, hashBytes, parseNixHash) @@ -239,26 +239,27 @@ -- for recursive fixed-output paths. -- -- 'Left' when the name breaks the store-path name rules --- ('checkStorePathName'). Construction validates like the parse boundary --- does, so every 'StorePath' that exists has a clean name: the write sinks --- downstream (store copies, the builder's delete-and-move) never see a --- path that resolves outside the store root, and no sink needs its own --- ad hoc name check. -makeStorePath :: StoreDir -> Text -> BS.ByteString -> Text -> Either StorePathNameError StorePath +-- ('checkStorePathName'), carrying the hash part the path would have had: +-- upstream hashes before it checks the name, and its refusal names both. +-- Construction validates like the parse boundary does, so every +-- t'StorePath' that exists has a clean name: the write sinks downstream +-- (store copies, the builder's delete-and-move) never see a path that +-- resolves outside the store root, and no sink needs its own ad hoc name +-- check. +makeStorePath :: StoreDir -> Text -> BS.ByteString -> Text -> Either BadStorePath StorePath makeStorePath (StoreDir dir) typ innerDigest name = - case checkStorePathName name of - Left err -> Left err - Right () -> - let preimage = - typ - <> ":sha256:" - <> bytesToHexText innerDigest - <> ":" - <> T.pack dir - <> ":" - <> name - compressed = compressHash storePathHashBytes (sha256Digest (encodeUtf8 preimage)) - in Right (StorePath (encode compressed) name) + let preimage = + typ + <> ":sha256:" + <> bytesToHexText innerDigest + <> ":" + <> T.pack dir + <> ":" + <> name + hashPart = encode (compressHash storePathHashBytes (sha256Digest (encodeUtf8 preimage))) + in case checkStorePathName name of + Left err -> Left (BadStorePath hashPart err) + Right () -> Right (StorePath hashPart name) -- | Construct a text store path (used for @.drv@ files and @builtins.toFile@). -- The references are embedded in the @type@ string - @\"text\"@ followed by @@ -266,7 +267,7 @@ -- on the paths of all its inputs. @contentsDigest@ is the SHA-256 of the file -- contents (the ATerm, for a @.drv@). 'Left' on an invalid name, as -- 'makeStorePath'. -makeTextPath :: Text -> BS.ByteString -> [StorePath] -> Either StorePathNameError StorePath +makeTextPath :: Text -> BS.ByteString -> [StorePath] -> Either BadStorePath StorePath makeTextPath name contentsDigest refs = let sortedRefs = Set.toAscList (Set.fromList refs) typ = "text" <> T.concat [":" <> storePathToText defaultStoreDir r | r <- sortedRefs] @@ -280,7 +281,7 @@ -- * otherwise, @makeStorePath \"output:out\" sha256(\"fixed:out:\" prefix algo \":\" hex \":\") name@ -- -- 'Left' on an invalid name, as 'makeStorePath'. -makeFixedOutputPath :: Text -> Text -> Text -> BS.ByteString -> Either StorePathNameError StorePath +makeFixedOutputPath :: Text -> Text -> Text -> BS.ByteString -> Either BadStorePath StorePath makeFixedOutputPath name algo mode foHashDigest | algo == "sha256" && mode == "recursive" = makeStorePath defaultStoreDir "source" foHashDigest name @@ -296,7 +297,7 @@ -- composed name is what gets validated - a name and output each clean on -- their own can still compose past the length limit, so the check belongs -- here, after composition. 'Left' as 'makeStorePath'. -makeOutputPath :: Text -> BS.ByteString -> Text -> Either StorePathNameError StorePath +makeOutputPath :: Text -> BS.ByteString -> Text -> Either BadStorePath StorePath makeOutputPath outName moduloDigest drvName = let pathName = if outName == "out" then drvName else drvName <> "-" <> outName in makeStorePath defaultStoreDir ("output:" <> outName) moduloDigest pathName diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -18,7 +18,8 @@ -- -- hnix used Megaparsec and it was 10x slower than C++ Nix (38% of runtime -- in GC from parser allocations). We use a hand-rolled recursive descent --- parser with 'Data.Text' slicing to minimize allocations. +-- parser over a lexer that slices the source's bytes to minimize +-- allocations. -- -- == Operator precedence (lowest to highest) -- @@ -49,8 +50,8 @@ parseNixWithScope, parseNixFile, - -- * Encoding - readFileAutoEncoding, + -- * Origins + SourceOrigin (..), -- * Errors SourceError (..), @@ -59,18 +60,21 @@ where import Data.Bifunctor (first) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) +import Data.Word (Word32, Word8) import Nix.Expr.ClosureTrim (trimClosures) import Nix.Expr.Resolve (resolveRelativePaths, resolveVars, staticGlobalNames) -import Nix.Expr.Types (Expr) +import Nix.Expr.Types (Expr, SourceOrigin (..), sourceName) import Nix.Parser.Expr (parseTopLevel) import Nix.Parser.Internal (ParseState (..), runParser) -import Nix.Parser.Lexer (tokenize) +import Nix.Parser.Lexer (positionAfter, tokenize) import Nix.Parser.ParseError (ParseError (..)) import System.FilePath (takeDirectory) @@ -85,13 +89,17 @@ UndefinedVariable !Text deriving (Eq, Show) --- | Parse a Nix expression from source text and bind its variables against --- the root environment's names under the default policy +-- | Parse a Nix expression from source bytes and bind its variables +-- against the root environment's names under the default policy -- ('staticGlobalNames'). -- --- The input is the full file contents. The file name is used only for --- error messages. Strips a leading UTF-8 BOM if present - Windows --- editors (Notepad, PowerShell) commonly add one. +-- The input is the full file contents, as read from disk: a leading byte +-- order mark is read as 'sourceUtf8' describes, and every other byte is +-- lexed as it is, so a string literal's bytes are its value's. The origin +-- names the source in error messages and decides what the positions +-- recorded in it report: a 'SourceFile' position names the file, as +-- upstream's do for a file it parses, and a 'SourceText' one names none, +-- as upstream's do for an @--expr@ string. -- -- The base directory is what relative path literals resolve against, and it -- is an argument here rather than something the evaluator supplies later @@ -102,7 +110,7 @@ -- same reason. Pass the directory holding the file; for source with no file -- behind it (@--expr@) pass the working directory, which is what upstream -- parses against. -parseNix :: FilePath -> Text -> Text -> Either SourceError Expr +parseNix :: FilePath -> SourceOrigin -> ByteString -> Either SourceError Expr parseNix = parseNixWithScope staticGlobalNames -- | 'parseNix' against the names the environment the source is evaluated in @@ -111,59 +119,101 @@ -- with a @scopedImport@ scope's attributes over them, which upstream binds -- in a static environment of their own over the base one. Every one binds -- like a global, so a @with@ in the source cannot shadow it. -parseNixWithScope :: Set Text -> FilePath -> Text -> Text -> Either SourceError Expr -parseNixWithScope scope baseDir fileName source = do - tokens <- first SyntaxError (tokenize fileName (stripBOM source)) - let st = ParseState {psTokens = tokens, psFile = fileName} +parseNixWithScope :: Set Text -> FilePath -> SourceOrigin -> ByteString -> Either SourceError Expr +parseNixWithScope scope baseDir origin source = do + utf8 <- first SyntaxError (sourceUtf8 (sourceName origin) source) + tokens <- first SyntaxError (tokenize (sourceName origin) utf8) + let st = ParseState {psTokens = tokens, psOrigin = origin} (expr, _remaining) <- first SyntaxError (runParser parseTopLevel st) resolved <- first UndefinedVariable (resolveVars scope expr) pure (resolveRelativePaths baseDir (trimClosures resolved)) --- | Strip a leading UTF-8 byte order mark (U+FEFF) if present. -stripBOM :: Text -> Text -stripBOM t = case T.uncons t of - Just ('\xFEFF', rest) -> rest - _ -> t - -- | Parse a @.nix@ file from disk. --- Uses 'readFileAutoEncoding' to handle UTF-8, UTF-16 LE, and UTF-16 BE. parseNixFile :: FilePath -> IO (Either SourceError Expr) -parseNixFile path = do - source <- readFileAutoEncoding path - pure $ parseNix (takeDirectory path) (T.pack path) source +parseNixFile path = parseNix (takeDirectory path) (SourceFile (T.pack path)) <$> BS.readFile path -- --------------------------------------------------------------------------- -- Encoding detection -- --------------------------------------------------------------------------- --- | Read a file, detecting encoding from its byte order mark. +-- | The source as the lexer reads it: UTF-8 bytes. A leading byte order +-- mark decides the encoding, and nothing else does: -- --- Windows tools (PowerShell's @>@ operator, Notepad) commonly write --- UTF-16 LE. Nix files are normally UTF-8, but on a Windows-first --- implementation we handle all three BOM variants: +-- * @FF FE@ is UTF-16 LE (what PowerShell's @>@ writes) and @FE FF@ is +-- UTF-16 BE, either transcoded to UTF-8 +-- * @EF BB BF@ is UTF-8, the mark dropped +-- * no mark is UTF-8, every byte kept, a malformed sequence included -- --- * @FF FE@ is UTF-16 LE (PowerShell default) --- * @FE FF@ is UTF-16 BE --- * @EF BB BF@ is UTF-8 (BOM stripped) --- * No BOM is UTF-8 -readFileAutoEncoding :: FilePath -> IO Text -readFileAutoEncoding path = decodeAutoEncoding <$> BS.readFile path +-- Upstream recognizes no mark: it lexes a file's bytes as they are +-- (@EvalState::parseExprFromFile@, eval.cc at 2.24.9), so a file opening +-- with one fails to parse there. Reading them is for the Windows tools +-- that write them. +sourceUtf8 :: Text -> ByteString -> Either ParseError ByteString +sourceUtf8 name bytes + | Just body <- BS.stripPrefix utf16LeMark bytes = utf16ToUtf8 LittleEndian name body + | Just body <- BS.stripPrefix utf16BeMark bytes = utf16ToUtf8 BigEndian name body + | Just body <- BS.stripPrefix utf8Mark bytes = Right body + | otherwise = Right bytes --- | Decode bytes to 'Text' based on byte order mark. -decodeAutoEncoding :: BS.ByteString -> Text -decodeAutoEncoding bytes - | BS.length bytes >= 2, - BS.index bytes 0 == 0xFF, - BS.index bytes 1 == 0xFE = - TE.decodeUtf16LEWith lenientDecode (BS.drop 2 bytes) - | BS.length bytes >= 2, - BS.index bytes 0 == 0xFE, - BS.index bytes 1 == 0xFF = - TE.decodeUtf16BEWith lenientDecode (BS.drop 2 bytes) - | BS.length bytes >= 3, - BS.index bytes 0 == 0xEF, - BS.index bytes 1 == 0xBB, - BS.index bytes 2 == 0xBF = - TE.decodeUtf8With lenientDecode (BS.drop 3 bytes) - | otherwise = - TE.decodeUtf8With lenientDecode bytes +-- | The byte order marks 'sourceUtf8' reads. +utf16LeMark, utf16BeMark, utf8Mark :: ByteString +utf16LeMark = BS.pack [0xFF, 0xFE] +utf16BeMark = BS.pack [0xFE, 0xFF] +utf8Mark = BS.pack [0xEF, 0xBB, 0xBF] + +-- | Which byte of a UTF-16 code unit comes first. +data ByteOrder = LittleEndian | BigEndian + +-- | A UTF-16 body as UTF-8. An unpaired surrogate and an odd final byte +-- have no UTF-8 spelling, and replacing either would change the source, so +-- each is a parse error at the character it stands at: the end of the +-- UTF-8 before it, positioned by the lexer ('positionAfter'). +utf16ToUtf8 :: ByteOrder -> Text -> ByteString -> Either ParseError ByteString +utf16ToUtf8 order name = go mempty + where + go !built units = case codeUnit units of + Nothing + | BS.null units -> Right (utf8Of built) + | otherwise -> malformed built "UTF-16 source with an odd number of bytes" + Just (unit, rest) + | isHighSurrogate unit, + Just (low, afterPair) <- codeUnit rest, + isLowSurrogate low -> + go (built <> utf8CodePoint (surrogatePair unit low)) afterPair + | isSurrogate unit -> malformed built "unpaired UTF-16 surrogate" + | otherwise -> go (built <> utf8CodePoint unit) rest + codeUnit bytes = do + (leading, afterLeading) <- BS.uncons bytes + (trailing, afterTrailing) <- BS.uncons afterLeading + pure $ case order of + LittleEndian -> (widen trailing `shiftL` 8 .|. widen leading, afterTrailing) + BigEndian -> (widen leading `shiftL` 8 .|. widen trailing, afterTrailing) + widen :: Word8 -> Word32 + widen = fromIntegral + utf8Of = BL.toStrict . BB.toLazyByteString + malformed built message = + let (line, col) = positionAfter (utf8Of built) + in Left ParseError {peFile = name, peLine = line, peCol = col, peMessage = message} + +-- | UTF-16 surrogates: a high one (D800-DBFF) followed by a low one +-- (DC00-DFFF) spells one code point past U+FFFF. +isHighSurrogate, isLowSurrogate, isSurrogate :: Word32 -> Bool +isHighSurrogate unit = unit >= 0xD800 && unit < 0xDC00 +isLowSurrogate unit = unit >= 0xDC00 && unit < 0xE000 +isSurrogate unit = unit >= 0xD800 && unit < 0xE000 + +-- | The code point a high and a low surrogate spell. +surrogatePair :: Word32 -> Word32 -> Word32 +surrogatePair high low = 0x10000 + (high - 0xD800) `shiftL` 10 + (low - 0xDC00) + +-- | The UTF-8 bytes of a code point below U+110000 that is not a +-- surrogate, which is every one 'utf16ToUtf8' spells. +utf8CodePoint :: Word32 -> BB.Builder +utf8CodePoint point + | point < 0x80 = BB.word8 (fromIntegral point) + | point < 0x800 = lead 0xC0 6 <> continuation 0 + | point < 0x10000 = lead 0xE0 12 <> continuation 6 <> continuation 0 + | otherwise = lead 0xF0 18 <> continuation 12 <> continuation 6 <> continuation 0 + where + lead marker bits = BB.word8 (marker .|. fromIntegral (point `shiftR` bits)) + continuation bits = BB.word8 (0x80 .|. (fromIntegral (point `shiftR` bits) .&. 0x3F)) diff --git a/src/Nix/Parser/Expr.hs b/src/Nix/Parser/Expr.hs --- a/src/Nix/Parser/Expr.hs +++ b/src/Nix/Parser/Expr.hs @@ -23,12 +23,15 @@ where import Control.Monad (foldM, when) +import Data.ByteString (ByteString) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) +import qualified Data.Text.Encoding as TE import Nix.Expr.Types import Nix.Parser.Internal import Nix.Parser.Lexer (Token (..)) +import Nix.Parser.ParseError (ParseError (..)) -- --------------------------------------------------------------------------- -- Top level @@ -416,10 +419,7 @@ TokNull -> advance >> pure (ELit NixNull) TokUri u -> advance >> pure (ELit (NixUri u)) TokPath p -> advance >> pure (ELit (NixPath p)) - TokPathInterpStart headPiece -> do - _ <- advance - parts <- parsePathParts - pure (EPathStr (StrLit headPiece : parts)) + TokPathInterpStart headPiece -> advance >> EPathStr headPiece <$> parsePathParts TokSearchPath p -> advance >> pure (ESearchPath p) TokIdent name -> advance >> pure (EVar name) TokStringOpen -> parseString @@ -493,7 +493,7 @@ pure (reverse acc) TokPathLit txt -> do _ <- advance - go (StrLit txt : acc) + go (StrLit (TE.encodeUtf8 txt) : acc) TokInterpOpen -> do _ <- advance expr <- parseExpr @@ -557,8 +557,9 @@ -- | Accumulated definition while normalizing one binding list. data NormEntry - = -- | @name = value@ - mergeable when the value is a plain attrset literal. - StaticEntry !Text !Expr + = -- | @name = value@ at its first definition's position - mergeable when + -- the value is a plain attrset literal. + StaticEntry !SrcPos !Text !Expr | -- | An @inherit@ - its names are never mergeable. InheritEntry !Binding | -- | A dynamic-key binding - collisions surface at eval time. @@ -574,7 +575,8 @@ -- attrset literals - so @a.b = 1; a.c = 2;@ and @a = { b = 1; }; a.c = 2;@ -- both work, with inner duplicates checked recursively. A @rec@ marker -- on the existing set governs the merged result; one on the new set is --- discarded, exactly as upstream; +-- discarded, exactly as upstream. The key keeps its first definition's +-- position and each merged binding its own, as upstream's do; -- * any other duplicate definition is a parse error, as upstream -- (@a = 1; a = 2;@, an @inherit@ name reused, merging into a -- non-literal value). @@ -596,17 +598,17 @@ where step :: ([NormEntry], Map Text DefKind) -> Binding -> Either Text ([NormEntry], Map Text DefKind) step (entries, defined) binding = case binding of - NamedBinding (StaticKey key) value -> + NamedBinding pos (StaticKey key) value -> case Map.lookup key defined of Nothing -> - Right (StaticEntry key value : entries, Map.insert key DefStatic defined) + Right (StaticEntry pos key value : entries, Map.insert key DefStatic defined) Just DefStatic -> do updated <- mergeIntoEntries key value entries Right (updated, defined) Just DefInherit -> Left (duplicateAttr key) - b@(NamedBinding _ _) -> Right (DynamicEntry b : entries, defined) - b@(Inherit name _) -> inheritEntry b [name] - b@(InheritFrom _ names) -> inheritEntry b names + b@(NamedBinding {}) -> Right (DynamicEntry b : entries, defined) + b@(Inherit _ name _) -> inheritEntry b [name] + b@(InheritFrom _ names) -> inheritEntry b [name | InheritedName _ name <- names] where -- One name at a time, so a name repeated within the clause is a -- duplicate too, as upstream's per-name dupAttr check makes it. @@ -620,10 +622,10 @@ -- Replace the existing entry for @key@ with the merged value. mergeIntoEntries key newValue entries = case entries of [] -> Left (duplicateAttr key) - (StaticEntry existingKey existingValue : rest) + (StaticEntry existingPos existingKey existingValue : rest) | existingKey == key -> do merged <- mergeAttrValues key existingValue newValue - Right (StaticEntry existingKey merged : rest) + Right (StaticEntry existingPos existingKey merged : rest) (entry : rest) -> (entry :) <$> mergeIntoEntries key newValue rest -- Upstream's addAttr (parser-state.hh) merges ANY two attrset @@ -637,7 +639,7 @@ <$> normalizeBindingList (existingBindings ++ newBindings) mergeAttrValues key _ _ = Left (duplicateAttr key) - renderEntry (StaticEntry key value) = NamedBinding (StaticKey key) value + renderEntry (StaticEntry pos key value) = NamedBinding pos (StaticKey key) value renderEntry (InheritEntry b) = b renderEntry (DynamicEntry b) = b @@ -645,21 +647,23 @@ -- | @a.b.c = v;@ as one binding under its first key, the rest of the -- path hoisted into nested set literals, one per level: @a = { b = { c = --- v; }; };@, as upstream's @addAttr@ builds them. +-- v; }; };@, as upstream's @addAttr@ builds them, every level at the +-- path's position. parseNamedBinding :: Parser Binding parseNamedBinding = do + pos <- currentPos firstKey <- parseAttrKey - rest <- pMany (expect TokDot >> parseAttrKey) + rest <- dottedKeys expect TokAssign val <- parseExpr expect TokSemicolon - pure (NamedBinding firstKey (nestUnder rest val)) - where - nestUnder [] value = value - nestUnder (key : keys) value = EAttrs False [NamedBinding key (nestUnder keys value)] NoCaptureInfo + let nestUnder [] value = value + nestUnder (key : keys) value = EAttrs False [NamedBinding pos key (nestUnder keys value)] NoCaptureInfo + pure (NamedBinding pos firstKey (nestUnder rest val)) -- | An @inherit@ clause: one 'InheritFrom' for @inherit (from) x y;@, one -- 'Inherit' per name for @inherit x y;@, each holding the variable it copies. +-- Each name is at its own position, as upstream's parser.y records them. parseInherit :: Parser [Binding] parseInherit = do expect TokInherit @@ -675,38 +679,40 @@ _ -> do names <- parseInheritNames expect TokSemicolon - pure [Inherit name (EVar name) | name <- names] + pure [Inherit pos name (EVar name) | InheritedName pos name <- names] -parseInheritNames :: Parser [Text] +parseInheritNames :: Parser [InheritedName] parseInheritNames = go [] where go acc = do + pos <- currentPos tok <- peek case tok of TokIdent name -> do _ <- advance - go (name : acc) + go (InheritedName pos name : acc) -- Keywords are valid as inherit names: inherit if then else; _ | Just name <- keywordToText tok -> do _ <- advance - go (name : acc) + go (InheritedName pos name : acc) -- Quoted strings for keywords used as attribute names: inherit "or"; TokStringOpen -> do _ <- advance - name <- parseQuotedInheritName - go (name : acc) + name <- parseQuotedInheritName pos + go (InheritedName pos name : acc) _ -> pure (reverse acc) --- | Parse a quoted inherit name: a simple string literal (no interpolation). --- Used for keywords like @"or"@ in @inherit (self.trivial) "or";@. -parseQuotedInheritName :: Parser Text -parseQuotedInheritName = do +-- | Parse a quoted inherit name: a simple string literal (no interpolation), +-- the string opening at the position given. Used for keywords like @"or"@ +-- in @inherit (self.trivial) "or";@. +parseQuotedInheritName :: SrcPos -> Parser Text +parseQuotedInheritName pos = do tok <- peek case tok of TokStringLit s -> do _ <- advance expect TokStringClose - pure s + attrNameText pos s TokStringClose -> do _ <- advance pure "" @@ -715,9 +721,25 @@ parseAttrPath :: Parser AttrPath parseAttrPath = do first <- parseAttrKey - rest <- pMany (expect TokDot >> parseAttrKey) + rest <- dottedKeys pure (first : rest) +-- | The keys after an attribute path's first, each after a dot. A dot +-- commits to the key after it, as upstream's LR grammar does (the +-- @attrpath@ rule, parser.y at 2.24.9), so a key that fails to parse +-- reports its own error, a string key that is not UTF-8 among them, +-- rather than backtracking to blame the dot. +dottedKeys :: Parser [AttrKey] +dottedKeys = go [] + where + go acc = do + dotted <- match TokDot + if dotted + then do + key <- parseAttrKey + go (key : acc) + else pure (reverse acc) + parseAttrKey :: Parser AttrKey parseAttrKey = do tok <- peek @@ -727,11 +749,14 @@ -- { if = 1; }, a.then, { else = 2; }, etc. _ | Just name <- keywordToText tok -> advance >> pure (StaticKey name) TokStringOpen -> do + pos <- currentPos strExpr <- parseString -- A string key with no interpolation is static, as in upstream Nix's -- parser (the string becomes a symbol at parse time) - which is also -- what makes @let "x" = 1; in x@ legal. - pure (maybe (DynamicKey strExpr) StaticKey (literalStringKey strExpr)) + case literalStringKey strExpr of + Just bytes -> StaticKey <$> attrNameText pos bytes + Nothing -> pure (DynamicKey strExpr) TokInterpOpen -> do _ <- advance expr <- parseExpr @@ -741,17 +766,32 @@ pure (DynamicKey expr) _ -> parseError ("expected attribute key, got " <> showToken tok) --- | The literal text of a string expression that contains no interpolation. --- Escape handling can split a literal into several 'StrLit' chunks, so the --- parts are concatenated; any 'StrInterp' makes the key dynamic. -literalStringKey :: Expr -> Maybe Text +-- | The bytes of a string expression that contains no interpolation; any +-- 'StrInterp' makes the key dynamic. +literalStringKey :: Expr -> Maybe ByteString literalStringKey (EStr parts) = mconcat <$> traverse literalPart parts where - literalPart (StrLit t) = Just t - literalPart (StrEsc t) = Just t + literalPart (StrLit bytes) = Just bytes + literalPart (StrEsc bytes) = Just bytes literalPart (StrInterp _) = Nothing literalStringKey _ = Nothing +-- | The name a string attribute key spells, the string opening at the +-- position given. Attribute names are text here, so a key whose bytes are +-- not UTF-8 is a syntax error at the string, where upstream makes a symbol +-- of any bytes (the @attrpath@ and @attrs@ rules, parser.y at 2.24.9). +attrNameText :: SrcPos -> ByteString -> Parser Text +attrNameText (SrcPos origin line col) bytes = case TE.decodeUtf8' bytes of + Right name -> pure name + Left _ -> + failWithError + ParseError + { peFile = sourceName origin, + peLine = line, + peCol = col, + peMessage = "attribute name is not valid UTF-8" + } + -- | Convert keyword tokens to their text for use as attribute names. -- All Nix keywords are valid as attr keys in binding and select position. keywordToText :: Token -> Maybe Text @@ -792,7 +832,7 @@ -- nested dynamic keys (let a.${k} = 1) live in a nested attrset -- and are fine. case binding of - NamedBinding (DynamicKey _) _ -> + NamedBinding _ (DynamicKey _) _ -> parseError "dynamic attributes not allowed in let" _ -> go (binding : acc) diff --git a/src/Nix/Parser/Internal.hs b/src/Nix/Parser/Internal.hs --- a/src/Nix/Parser/Internal.hs +++ b/src/Nix/Parser/Internal.hs @@ -20,12 +20,14 @@ tryParserKeepError, deeperError, failWithError, - pMany, atEnd, -- * Specific expects expectIdent, + -- * Positions + currentPos, + -- * Errors parseError, @@ -36,15 +38,21 @@ import Data.Text (Text) import qualified Data.Text as T +import Nix.Expr.Types (SourceOrigin, SrcPos (..), sourceName) import Nix.Parser.Lexer (Located (..), Token (..)) import Nix.Parser.ParseError (ParseError (..)) --- | Remaining tokens plus file name for error messages. +-- | Remaining tokens plus where they came from, for error messages and +-- the positions the parser records. data ParseState = ParseState { psTokens :: ![Located], - psFile :: !Text + psOrigin :: !SourceOrigin } +-- | The name errors give the source being parsed. +psFile :: ParseState -> Text +psFile = sourceName . psOrigin + -- | A parser that consumes tokens and produces a value or an error. newtype Parser a = Parser { unParser :: ParseState -> Either ParseError (a, ParseState) @@ -126,11 +134,11 @@ Left _ -> Right (Nothing, st) Right (val, st2) -> Right (Just val, st2) --- | Backtracking that keeps the failure instead of discarding it. --- 'tryParser' is right for iteration ('pMany') and wrong for --- alternation between competing readings, where the discarded error --- may be the true one: a failure deep in a lambda body used to --- surface as the attr-set branch's complaint at the top of the file. +-- | Backtracking that keeps the failure instead of discarding it, for +-- alternation between competing readings, where the error 'tryParser' +-- would discard may be the true one: a failure deep in a lambda body +-- would otherwise surface as the attr-set branch's complaint at the top +-- of the file. tryParserKeepError :: Parser a -> Parser (Either ParseError a) tryParserKeepError (Parser p) = Parser $ \st -> case p st of Left err -> Right (Left err, st) @@ -156,16 +164,6 @@ failWithError :: ParseError -> Parser a failWithError err = Parser $ \_ -> Left err --- | Parse zero or more occurrences. -pMany :: Parser a -> Parser [a] -pMany p = go [] - where - go acc = do - result <- tryParser p - case result of - Nothing -> pure (reverse acc) - Just val -> go (val : acc) - -- | Check if we've consumed all tokens. atEnd :: Parser Bool atEnd = Parser $ \st -> case psTokens st of @@ -200,6 +198,15 @@ peCol = 0, peMessage = "expected identifier but got end of input" } + +-- | The position of the next token, without consuming it. Upstream +-- records a construct at its first token's start (@ParserState::at@, +-- parser-state.hh at 2.24.9), so taking this before a construct's first +-- token gives the position upstream gives it. +currentPos :: Parser SrcPos +currentPos = Parser $ \st -> case psTokens st of + (Located ln col _ : _) -> Right (SrcPos (psOrigin st) ln col, st) + [] -> Left (makeEOF st) -- --------------------------------------------------------------------------- -- Helpers diff --git a/src/Nix/Parser/Lexer.hs b/src/Nix/Parser/Lexer.hs --- a/src/Nix/Parser/Lexer.hs +++ b/src/Nix/Parser/Lexer.hs @@ -1,7 +1,25 @@ --- | Lexer for the Nix language: 'Text' to @['Located']@. +-- | Lexer for the Nix language: source bytes to @[t'Located']@. -- -- Handles all Nix tokens including string interpolation via a mode stack. -- Entirely pure - no IO. +-- +-- The source is bytes, as upstream's flex scanner reads it (lexer.l at +-- 2.24.9). Every token class is ASCII, as upstream's are, so a byte +-- outside ASCII never continues an identifier, number, path, URI or run of +-- whitespace, while string literals and comments hold whatever bytes they +-- hold: a string chunk is the source's bytes with its escapes resolved, +-- which is what the eval string gets. Bytes are matched as Latin-1 +-- 'Char's through "Data.ByteString.Char8" so the grammar reads as +-- character literals, which is why no predicate here is one of +-- "Data.Char"'s Unicode classes: 'Data.Char.isAlpha' calls the byte 0xE9 +-- a letter. +-- +-- A column counts characters: a byte that continues a UTF-8 sequence does +-- not advance it, so valid UTF-8 advances one column per character. A +-- line ends at an LF, a CRLF or a bare CR, as upstream's position table +-- splits a source (@Pos::LinesIterator@, position.cc). Every byte the +-- lexer takes passes through 'consume', which holds that rule, so no +-- token, comment or string counts lines its own way. module Nix.Parser.Lexer ( -- * Tokens Token (..), @@ -9,17 +27,23 @@ -- * Tokenizing tokenize, + + -- * Positions + positionAfter, ) where -import Data.Char (isAlpha, isAlphaNum, isDigit, isSpace) +import Control.Applicative ((<|>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord) import Data.Int (Int64) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Foreign (lengthWord8) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Encoding as TE import Nix.Parser.ParseError (ParseError (..)) +import Numeric (showHex) -- | A positioned token. data Located = Located @@ -64,14 +88,15 @@ | TokStringClose | TokIndStringOpen | TokIndStringClose - | TokStringLit !Text + | -- | A literal chunk of a string: the source's bytes, escapes resolved. + TokStringLit !ByteString | -- | Resolved escape text inside an indented string (@'''@, @''$@, -- @''${@, @''\x@). Kept apart from 'TokStringLit' because upstream's -- lexer.l emits an escape without the hasIndentation mark: the -- indentation scan skips it (it ends a line's leading whitespace -- without being measured) while the strip runs over it as over any -- literal. - TokStringEsc !Text + TokStringEsc !ByteString | TokInterpOpen | TokInterpClose | -- Operators @@ -132,7 +157,7 @@ -- Without the stack, a nested interpolated string inside braces zeroes the -- enclosing count and the outer attrset's @}@ mislexes as TokInterpClose. data LexState = LexState - { lsInput :: !Text, + { lsInput :: !ByteString, lsFile :: !Text, lsLine :: !Int, lsCol :: !Int, @@ -159,23 +184,32 @@ -- --------------------------------------------------------------------------- -- | Tokenize a Nix source file. Returns tokens or a lex error. -tokenize :: Text -> Text -> Either ParseError [Located] -tokenize fileName source = - let initialState = - LexState - { lsInput = source, - lsFile = fileName, - lsLine = 1, - lsCol = 1, - lsModes = [ModeNormal], - lsBraceDepth = 0, - lsBraceStack = [], - -- No runs scanned yet: nothing may shortcut. - lsNoSlashFloor = maxBound, - lsNoColonFloor = maxBound - } - in lexLoop initialState [] +tokenize :: Text -> ByteString -> Either ParseError [Located] +tokenize fileName source = lexLoop (initialState fileName source) [] +-- | The line and column just past a source's last byte, counted as +-- 'tokenize' counts them. +positionAfter :: ByteString -> (Int, Int) +positionAfter source = + let atEnd = consume (BS.length source) (initialState T.empty source) + in (lsLine atEnd, lsCol atEnd) + +-- | The state at the start of a source. +initialState :: Text -> ByteString -> LexState +initialState fileName source = + LexState + { lsInput = source, + lsFile = fileName, + lsLine = 1, + lsCol = 1, + lsModes = [ModeNormal], + lsBraceDepth = 0, + lsBraceStack = [], + -- No runs scanned yet: nothing may shortcut. + lsNoSlashFloor = maxBound, + lsNoColonFloor = maxBound + } + -- --------------------------------------------------------------------------- -- Main loop -- --------------------------------------------------------------------------- @@ -188,7 +222,7 @@ _ -> lexNormalMode st acc lexNormalMode :: LexState -> [Located] -> Either ParseError [Located] -lexNormalMode st acc = case T.uncons (lsInput st) of +lexNormalMode st acc = case BC.uncons (lsInput st) of Nothing -> Right (reverse (Located (lsLine st) (lsCol st) TokEOF : acc)) Just (c, rest) -> -- Lazy: forced only by the three path guards below. Branches taken @@ -201,27 +235,27 @@ -- | The normal-mode dispatch, after the path lookahead has been prepared. -- @st@ is the incoming state; @flooredSt@ carries the advanced path -- watermark for the continuations that bypassed a path reading. -lexNormalModeAt :: LexState -> LexState -> Bool -> Char -> Text -> [Located] -> Either ParseError [Located] +lexNormalModeAt :: LexState -> LexState -> Bool -> Char -> ByteString -> [Located] -> Either ParseError [Located] lexNormalModeAt st flooredSt startsPath c rest acc = case c of - _ | isSpace c -> lexNormalMode (skipWhitespace st) acc + _ | isNixSpace c -> lexNormalMode (skipWhitespace st) acc '#' -> lexNormalMode (skipLineComment st) acc '/' | Just '*' <- safeHead rest -> - case skipBlockComment (advanceCol 2 st {lsInput = T.drop 2 (lsInput st)}) of + case skipBlockComment (consume 2 st) of Left err -> Left err Right newSt -> lexNormalMode newSt acc '"' -> let tok = Located (lsLine st) (lsCol st) TokStringOpen - newSt = advanceCol 1 st {lsInput = rest, lsModes = ModeString : lsModes st} + newSt = consume 1 st {lsModes = ModeString : lsModes st} in lexLoop newSt (tok : acc) '\'' | Just '\'' <- safeHead rest -> let tok = Located (lsLine st) (lsCol st) TokIndStringOpen - opened = advanceCol 2 st {lsInput = T.drop 2 (lsInput st), lsModes = ModeIndString : lsModes st} + opened = consume 2 st {lsModes = ModeIndString : lsModes st} in lexLoop (skipIndStringOpenerLine opened) (tok : acc) '.' | Just '.' <- safeHead rest, - Just '.' <- safeHead (T.drop 1 rest) -> + Just '.' <- safeHead (BS.drop 1 rest) -> emit3 st TokEllipsis acc '.' -- Maximal munch, as upstream's PATH regex: a dot-led path-char run @@ -244,7 +278,7 @@ ']' -> emit1 st TokRBracket acc '{' -> let tok = Located (lsLine st) (lsCol st) TokLBrace - newSt = advanceCol 1 st {lsInput = rest, lsBraceDepth = lsBraceDepth st + 1} + newSt = consume 1 st {lsBraceDepth = lsBraceDepth st + 1} in lexNormalMode newSt (tok : acc) '}' -> case lsModes st of @@ -258,11 +292,10 @@ (saved : outerSaved) -> (saved, outerSaved) [] -> (0, []) newSt = - advanceCol + consume 1 st - { lsInput = rest, - lsModes = outerMode : restModes, + { lsModes = outerMode : restModes, lsBraceDepth = restoredDepth, lsBraceStack = restoredStack } @@ -271,7 +304,7 @@ let depth = lsBraceDepth st newDepth = if depth > 0 then depth - 1 else 0 tok = Located (lsLine st) (lsCol st) TokRBrace - newSt = advanceCol 1 st {lsInput = rest, lsBraceDepth = newDepth} + newSt = consume 1 st {lsBraceDepth = newDepth} in lexNormalMode newSt (tok : acc) '+' | Just '+' <- safeHead rest -> emit2 st TokConcat acc '+' -> emit1 st TokPlus acc @@ -286,7 +319,7 @@ '=' -> emit1 st TokAssign acc '<' | Just '=' <- safeHead rest -> emit2 st TokLte acc '<' - | maybe False (\ch -> isAlpha ch || ch == '_') (safeHead rest) -> + | maybe False (\ch -> isAsciiAlpha ch || ch == '_') (safeHead rest) -> lexSearchPath st acc '<' -> emit1 st TokLt acc '>' | Just '=' <- safeHead rest -> emit2 st TokGte acc @@ -306,7 +339,7 @@ -- interpolation like "${env.${name}}" prematurely ends the -- outer interpolation. let tok = Located (lsLine st) (lsCol st) TokInterpOpen - newSt = advanceCol 2 st {lsInput = T.drop 1 rest, lsBraceDepth = lsBraceDepth st + 1} + newSt = consume 2 st {lsBraceDepth = lsBraceDepth st + 1} in lexNormalMode newSt (tok : acc) '~' | Just '/' <- safeHead rest -> @@ -322,15 +355,35 @@ { peFile = lsFile st, peLine = lsLine st, peCol = lsCol st, - peMessage = "unexpected character: " <> T.singleton c + peMessage = unexpectedInput c rest } +-- | What a parse error says of input that starts no token: the character +-- there when its bytes are one (ASCII, or a whole UTF-8 sequence), and +-- otherwise the byte, which shown as a Latin-1 character would name a +-- character the source does not hold. +unexpectedInput :: Char -> ByteString -> Text +unexpectedInput c rest = + case TE.decodeUtf8' (BC.cons c (BS.take (utf8TrailLength c) rest)) of + Right character -> "unexpected character: " <> character + Left _ -> "unexpected byte 0x" <> T.pack (showHex (ord c) "") + +-- | How many bytes after a UTF-8 lead byte its sequence takes, by the +-- lead's high bits; 0 for any other byte. The decode that reads them +-- decides whether they form a character. +utf8TrailLength :: Char -> Int +utf8TrailLength c + | c >= '\xF0' = 3 + | c >= '\xE0' = 2 + | c >= '\xC0' = 1 + | otherwise = 0 + -- --------------------------------------------------------------------------- -- String modes -- --------------------------------------------------------------------------- lexStringMode :: LexState -> [Located] -> Either ParseError [Located] -lexStringMode st acc = case T.uncons (lsInput st) of +lexStringMode st acc = case BC.uncons (lsInput st) of Nothing -> Left ParseError @@ -342,17 +395,16 @@ Just (c, rest) -> case c of '"' -> let tok = Located (lsLine st) (lsCol st) TokStringClose - newSt = advanceCol 1 st {lsInput = rest, lsModes = safeTail (lsModes st)} + newSt = consume 1 st {lsModes = safeTail (lsModes st)} in lexLoop newSt (tok : acc) '$' | Just '{' <- safeHead rest -> let tok = Located (lsLine st) (lsCol st) TokInterpOpen newSt = - advanceCol + consume 2 st - { lsInput = T.drop 1 rest, - lsModes = ModeNormal : lsModes st, + { lsModes = ModeNormal : lsModes st, -- Fresh count for the interpolation body; the -- enclosing context's count is restored at the -- matching TokInterpClose. @@ -367,16 +419,18 @@ -- @\'\'(\ *\n)?@), so content starts on the next line and the opening -- line's trailing spaces never reach the indentation scan. Only spaces -- qualify: a tab after @''@ is content, as are spaces not followed by a --- newline. +-- newline. The newline is an LF alone, so a line that ends in CRLF or a +-- bare CR is content too, from its spaces on. skipIndStringOpenerLine :: LexState -> LexState -skipIndStringOpenerLine st = - case T.uncons (T.dropWhile (== ' ') (lsInput st)) of - Just ('\n', rest) -> st {lsInput = rest, lsLine = lsLine st + 1, lsCol = 1} - _ -> st +skipIndStringOpenerLine st + | "\n" `BS.isPrefixOf` afterSpaces = consume (BS.length spaces + 1) st + | otherwise = st + where + (spaces, afterSpaces) = BC.span (== ' ') (lsInput st) lexIndStringMode :: LexState -> [Located] -> Either ParseError [Located] lexIndStringMode st acc - | T.null (lsInput st) = + | BS.null (lsInput st) = Left ParseError { peFile = lsFile st, @@ -386,41 +440,30 @@ } | otherwise = let input = lsInput st - in case T.uncons input of - Just ('\'', rest1) | Just ('\'', rest2) <- T.uncons rest1 -> + in case BC.uncons input of + Just ('\'', rest1) | Just ('\'', rest2) <- BC.uncons rest1 -> -- Check for escape sequences: ''', ''$, ''\x, ''${ - case T.uncons rest2 of - Just ('\'', rest3) -> + case BC.uncons rest2 of + Just ('\'', _) -> -- ''' escapes a literal '' (two quotes) - Nix's escape for the -- indented-string terminator, not a single quote. let escTok = Located (lsLine st) (lsCol st) (TokStringEsc "''") - newSt = advanceCol 3 st {lsInput = rest3} - in lexIndStringMode newSt (escTok : acc) + in lexIndStringMode (consume 3 st) (escTok : acc) Just ('$', rest3) - | Just ('{', rest4) <- T.uncons rest3 -> + | Just ('{', _) <- BC.uncons rest3 -> -- ''${ is a literal ${ let escTok = Located (lsLine st) (lsCol st) (TokStringEsc "${") - newSt = advanceCol 4 st {lsInput = rest4} - in lexIndStringMode newSt (escTok : acc) - Just ('$', rest3) -> + in lexIndStringMode (consume 4 st) (escTok : acc) + Just ('$', _) -> -- ''$ (without brace) is a literal $ let escTok = Located (lsLine st) (lsCol st) (TokStringEsc "$") - newSt = advanceCol 3 st {lsInput = rest3} - in lexIndStringMode newSt (escTok : acc) + in lexIndStringMode (consume 3 st) (escTok : acc) Just ('\\', rest3) -> -- ''\x is an escape sequence - case T.uncons rest3 of - Just (ec, rest4) -> - let escaped = case ec of - 'n' -> "\n" - 't' -> "\t" - 'r' -> "\r" - '\\' -> "\\" - -- Unknown escape: Nix drops the backslash (''\q -> q). - _ -> T.singleton ec - escTok = Located (lsLine st) (lsCol st) (TokStringEsc escaped) - newSt = advanceCol 4 st {lsInput = rest4} - in lexIndStringMode newSt (escTok : acc) + case BC.uncons rest3 of + Just (escaped, _) -> + let escTok = Located (lsLine st) (lsCol st) (TokStringEsc (escapedBytes escaped)) + in lexIndStringMode (consume 4 st) (escTok : acc) Nothing -> Left ParseError @@ -432,18 +475,17 @@ _ -> -- '' followed by non-escape closes the indented string let tok = Located (lsLine st) (lsCol st) TokIndStringClose - newSt = advanceCol 2 st {lsInput = rest2, lsModes = safeTail (lsModes st)} + newSt = consume 2 st {lsModes = safeTail (lsModes st)} in lexLoop newSt (tok : acc) Just ('$', rest1) - | Just ('{', rest2) <- T.uncons rest1 -> + | Just ('{', _) <- BC.uncons rest1 -> -- \${ in indented string is interpolation let tok = Located (lsLine st) (lsCol st) TokInterpOpen newSt = - advanceCol + consume 2 st - { lsInput = rest2, - lsModes = ModeNormal : lsModes st, + { lsModes = ModeNormal : lsModes st, -- Fresh count; enclosing context restored at -- the matching TokInterpClose. lsBraceDepth = 0, @@ -452,152 +494,142 @@ in lexLoop newSt (tok : acc) _ -> lexIndStringLiteral st acc --- | Lex a literal segment inside a regular string. --- Uses 'TB.Builder' for O(1) amortized append instead of O(n) 'T.snoc'. +-- | Lex a literal segment inside a regular string. A run of bytes the +-- string grammar gives no meaning is taken whole, and the pieces are +-- joined once when the chunk ends, so a chunk that is one such run is a +-- slice of the source. lexStringLiteral :: LexState -> [Located] -> Either ParseError [Located] -lexStringLiteral st0 acc = go st0 mempty +lexStringLiteral st0 acc = go st0 [] where - go st !builder = case T.uncons (lsInput st) of - Nothing -> - Left - ParseError - { peFile = lsFile st, - peLine = lsLine st, - peCol = lsCol st, - peMessage = "unterminated string" - } - Just (c, rest) -> case c of - '"' -> finishChunk st builder - -- \$$ is two literal dollars (maximal munch): the second $ cannot begin an - -- interpolation, so $${ does not interpolate (documented Nix behavior). - '$' - | Just '$' <- safeHead rest -> - go (advanceCol 2 st {lsInput = T.drop 1 rest}) (builder <> TB.singleton '$' <> TB.singleton '$') - '$' | Just '{' <- safeHead rest -> finishChunk st builder - '\\' -> case T.uncons rest of - Just (ec, rest2) -> - let escaped = case ec of - 'n' -> TB.singleton '\n' - 't' -> TB.singleton '\t' - 'r' -> TB.singleton '\r' - '\\' -> TB.singleton '\\' - '"' -> TB.singleton '"' - '$' -> TB.singleton '$' - -- Unknown escape: Nix drops the backslash (\q -> q). - _ -> TB.singleton ec - newSt = advanceBy ec (advanceCol 1 st {lsInput = rest2}) - in go newSt (builder <> escaped) - Nothing -> - Left - ParseError - { peFile = lsFile st, - peLine = lsLine st, - peCol = lsCol st, - peMessage = "unterminated escape in string" - } - '\n' -> - let newSt = st {lsInput = rest, lsLine = lsLine st + 1, lsCol = 1} - in go newSt (builder <> TB.singleton '\n') - -- Raw CR and CRLF normalize to LF, matching upstream unescapeStr - -- (lexer.l). Only double-quoted strings do this: indented-string - -- chunks bypass unescapeStr upstream and keep CR verbatim. An - -- ESCAPED CR (backslash before it) stays literal via the escape - -- branch above, also matching upstream. - '\r' -> - let afterEol = case T.uncons rest of - Just ('\n', afterCrlf) -> afterCrlf - _ -> rest - newSt = st {lsInput = afterEol, lsLine = lsLine st + 1, lsCol = 1} - in go newSt (builder <> TB.singleton '\n') - _ -> - let newSt = advanceCol 1 st {lsInput = rest} - in go newSt (builder <> TB.singleton c) - finishChunk st builder - | builderIsEmpty = lexStringMode st acc + go st pieces = + let (run, afterRun) = BC.break endsStringRun (lsInput st) + runSt = consume (BS.length run) st + withRun = run : pieces + in case BC.uncons afterRun of + Nothing -> + Left + ParseError + { peFile = lsFile runSt, + peLine = lsLine runSt, + peCol = lsCol runSt, + peMessage = "unterminated string" + } + Just (c, rest) -> case c of + '"' -> finishChunk runSt withRun + -- \$$ is two literal dollars (maximal munch): the second $ cannot begin an + -- interpolation, so $${ does not interpolate (documented Nix behavior). + '$' + | Just '$' <- safeHead rest -> go (consume 2 runSt) ("$$" : withRun) + | Just '{' <- safeHead rest -> finishChunk runSt withRun + | otherwise -> go (consume 1 runSt) ("$" : withRun) + '\\' -> case BC.uncons rest of + Just (escaped, _) -> go (consume 2 runSt) (escapedBytes escaped : withRun) + Nothing -> + Left + ParseError + { peFile = lsFile runSt, + peLine = lsLine runSt, + peCol = lsCol runSt, + peMessage = "unterminated escape in string" + } + -- A line ending, the run's one other end. LF, CRLF and a + -- raw CR each read as one LF, matching upstream unescapeStr + -- (lexer.l). Only double-quoted strings do this: + -- indented-string chunks bypass unescapeStr upstream and keep + -- CR verbatim. An ESCAPED CR (backslash before it) stays + -- literal via the escape branch above, also matching upstream. + _ -> + let ending = if "\r\n" `BS.isPrefixOf` afterRun then 2 else 1 + in go (consume ending runSt) ("\n" : withRun) + finishChunk st pieces + | BS.null chunk = lexStringMode st acc | otherwise = - let chunk = TL.toStrict (TB.toLazyText builder) - tok = Located (lsLine st0) (lsCol st0) (TokStringLit chunk) + let tok = Located (lsLine st0) (lsCol st0) (TokStringLit chunk) in lexStringMode st (tok : acc) where - builderIsEmpty = TL.null (TB.toLazyText builder) + chunk = BS.concat (reverse pieces) +-- | The bytes that end a plain run in a double-quoted string, each of +-- which means something there. +endsStringRun :: Char -> Bool +endsStringRun c = c == '"' || c == '$' || c == '\\' || c == '\n' || c == '\r' + +-- | What an escaped byte stands for, as upstream's unescapeStr reads it +-- (lexer.l): @n@, @r@ and @t@ name control characters, and any other byte +-- stands for itself, the backslash dropped (@\\q@ is @q@). +escapedBytes :: Char -> ByteString +escapedBytes 'n' = "\n" +escapedBytes 'r' = "\r" +escapedBytes 't' = "\t" +escapedBytes other = BC.singleton other + -- | Lex a literal segment inside an indented string. -- No escape sequences here (those are handled by 'lexIndStringMode'), --- so the chunk is identical to the source text - count chars, then slice --- once at the end. This avoids O(n^2) 'T.snoc' allocation. +-- so the chunk is identical to the source bytes - scan runs, then slice +-- once at the end. -- -- Raw CR\/CRLF is deliberately NOT normalized here: upstream's indented -- string chunks bypass unescapeStr (lexer.l), and stripIndentation treats -- CR as ordinary content, so only double-quoted strings normalize line -- endings. lexIndStringLiteral :: LexState -> [Located] -> Either ParseError [Located] -lexIndStringLiteral st0 acc = go st0 0 +lexIndStringLiteral st0 acc = go st0 where startInput = lsInput st0 - go st !consumed - | T.null (lsInput st) = - Left - ParseError - { peFile = lsFile st, - peLine = lsLine st, - peCol = lsCol st, - peMessage = "unterminated indented string" - } - | otherwise = - let input = lsInput st - in case T.uncons input of - Just ('\'', rest1) - | Just ('\'', _) <- T.uncons rest1 -> - finishChunk st consumed - Just ('$', rest1) - | Just ('$', _) <- T.uncons rest1 -> - -- \$$ is two literal dollars; the second cannot begin an - -- interpolation (matches lexStringLiteral and Nix). - go (advanceCol 2 st {lsInput = T.drop 1 rest1}) (consumed + 2) - Just ('$', rest1) - | Just ('{', _) <- T.uncons rest1 -> - finishChunk st consumed - Just ('\n', rest1) -> - let newSt = st {lsInput = rest1, lsLine = lsLine st + 1, lsCol = 1} - in go newSt (consumed + 1) - Just (_c, rest1) -> - let newSt = advanceCol 1 st {lsInput = rest1} - in go newSt (consumed + 1) - Nothing -> - Left - ParseError - { peFile = lsFile st, - peLine = lsLine st, - peCol = lsCol st, - peMessage = "unterminated indented string" - } - finishChunk st consumed - | consumed == 0 = lexIndStringMode st acc + go st = + let (run, afterRun) = BC.break endsIndStringRun (lsInput st) + runSt = consume (BS.length run) st + in case BC.uncons afterRun of + Nothing -> + Left + ParseError + { peFile = lsFile runSt, + peLine = lsLine runSt, + peCol = lsCol runSt, + peMessage = "unterminated indented string" + } + Just ('$', rest) + -- \$$ is two literal dollars; the second cannot begin an + -- interpolation (matches lexStringLiteral and Nix). + | Just '$' <- safeHead rest -> go (consume 2 runSt) + | Just '{' <- safeHead rest -> finishChunk runSt + | otherwise -> go (consume 1 runSt) + -- The quote, the run's one other end. + Just (_, rest) + | Just '\'' <- safeHead rest -> finishChunk runSt + | otherwise -> go (consume 1 runSt) + finishChunk st + | BS.null chunk = lexIndStringMode st acc | otherwise = - let chunk = T.take consumed startInput - tok = Located (lsLine st0) (lsCol st0) (TokStringLit chunk) + let tok = Located (lsLine st0) (lsCol st0) (TokStringLit chunk) in lexIndStringMode st (tok : acc) + where + chunk = BS.take (BS.length startInput - BS.length (lsInput st)) startInput +-- | The bytes that end a plain run in an indented string. +endsIndStringRun :: Char -> Bool +endsIndStringRun c = c == '\'' || c == '$' + -- --------------------------------------------------------------------------- -- Numbers -- --------------------------------------------------------------------------- lexNumber :: LexState -> [Located] -> Either ParseError [Located] lexNumber st acc = - let (digits, after) = T.span isDigit (lsInput st) - len = T.length digits - in case T.uncons after of + let (digitBytes, after) = BC.span isDigit (lsInput st) + digits = asciiText digitBytes + len = BS.length digitBytes + in case BC.uncons after of -- A '.' after the integer part starts a float even with no fractional -- digits or with only an exponent - Nix's grammar is [0-9]+\.[0-9]*(exp)?, -- so 12. and 12.e5 are floats, not an integer followed by a dot. Just ('.', after2) -> - let (decimals, after3) = T.span isDigit after2 - (expVal, after4, expLen) = lexExponent after3 - fullLen = T.length digits + 1 + T.length decimals + expLen - val = readDouble digits decimals expVal + let (decimals, after3) = BC.span isDigit after2 + (expVal, expLen) = lexExponent after3 + fullLen = len + 1 + BS.length decimals + expLen + val = readDouble digits (asciiText decimals) expVal tok = Located (lsLine st) (lsCol st) (TokFloat val) - newSt = advanceCol fullLen st {lsInput = after4} - in lexNormalMode newSt (tok : acc) + in lexNormalMode (consume fullLen st) (tok : acc) _ -- C++ Nix rejects out-of-range integer literals rather than -- silently wrapping modulo 2^64. Range is decided by digit @@ -614,8 +646,7 @@ | otherwise -> let val = fromIntegral (readInteger digits) :: Int64 tok = Located (lsLine st) (lsCol st) (TokInt val) - newSt = advanceCol len st {lsInput = after} - in lexNormalMode newSt (tok : acc) + in lexNormalMode (consume len st) (tok : acc) -- | Read an integer from text without using the partial 'read'. readInteger :: Text -> Integer @@ -700,23 +731,23 @@ positiveInfinity = 1 / 0 -- | Consume an optional exponent @[eE][+-]?[0-9]+@ after a float's digits. --- Returns the signed exponent, the remaining input, and the characters --- consumed. An @e@ not followed by digits is not an exponent (consumes 0), so --- e.g. @1.5e@ lexes as the float @1.5@ followed by the identifier @e@. -lexExponent :: Text -> (Integer, Text, Int) +-- Returns the signed exponent and the characters consumed. An @e@ not +-- followed by digits is not an exponent (consumes 0), so e.g. @1.5e@ lexes +-- as the float @1.5@ followed by the identifier @e@. +lexExponent :: ByteString -> (Integer, Int) lexExponent input = - case T.uncons input of + case BC.uncons input of Just (e, afterE) | e == 'e' || e == 'E' -> - let (sign, afterSign, signLen) = case T.uncons afterE of + let (sign, afterSign, signLen) = case BC.uncons afterE of Just ('+', rest) -> (1, rest, 1) Just ('-', rest) -> (-1, rest, 1) _ -> (1, afterE, 0) - (expDigits, afterExp) = T.span isDigit afterSign - in if T.null expDigits - then (0, input, 0) - else (sign * exponentMagnitude expDigits, afterExp, 1 + signLen + T.length expDigits) - _ -> (0, input, 0) + expDigits = BC.takeWhile isDigit afterSign + in if BS.null expDigits + then (0, 0) + else (sign * exponentMagnitude (asciiText expDigits), 1 + signLen + BS.length expDigits) + _ -> (0, 0) -- | The magnitude of an exponent's digit run. Reading n digits builds -- an n-digit bignum quadratically, so runs past 'exponentDigitBound' @@ -745,14 +776,13 @@ -- The current input begins with the @.@. lexLeadingDotFloat :: LexState -> [Located] -> Either ParseError [Located] lexLeadingDotFloat st acc = - let afterDot = T.drop 1 (lsInput st) - (decimals, after3) = T.span isDigit afterDot - (expVal, after4, expLen) = lexExponent after3 - fullLen = 1 + T.length decimals + expLen - val = readDouble "" decimals expVal + let afterDot = BS.drop 1 (lsInput st) + (decimals, after3) = BC.span isDigit afterDot + (expVal, expLen) = lexExponent after3 + fullLen = 1 + BS.length decimals + expLen + val = readDouble "" (asciiText decimals) expVal tok = Located (lsLine st) (lsCol st) (TokFloat val) - newSt = advanceCol fullLen st {lsInput = after4} - in lexNormalMode newSt (tok : acc) + in lexNormalMode (consume fullLen st) (tok : acc) -- | Base for decimal digit accumulation. decimalBase :: Integer @@ -769,51 +799,49 @@ lexIdentOrKeyword :: LexState -> [Located] -> Either ParseError [Located] lexIdentOrKeyword st acc = let input = lsInput st - (ident, after) = T.span isIdentChar input + ident = BC.takeWhile isIdentChar input (uriReading, advancedFloor) = uriSpanFrom (lsNoColonFloor st) input in case uriReading of -- Flex maximal munch: the URI rule beats identifiers AND keywords -- whenever it matches more characters, so @x:y@ is the URI "x:y" -- (the classic reason the identity function must be written -- @x: x@) and @mailto:a\@b.com@ needs no @//@. - Just (uri, afterUri) - | T.length uri > T.length ident -> - let tok = Located (lsLine st) (lsCol st) (TokUri uri) - newSt = advanceCol (T.length uri) st {lsInput = afterUri} - in lexNormalMode newSt (tok : acc) + Just uri + | BS.length uri > BS.length ident -> + let tok = Located (lsLine st) (lsCol st) (TokUri (asciiText uri)) + in lexNormalMode (consume (BS.length uri) st) (tok : acc) _ -> let tok = Located (lsLine st) (lsCol st) (identToToken ident) - newSt = advanceCol (T.length ident) st {lsInput = after, lsNoColonFloor = advancedFloor} + newSt = consume (BS.length ident) st {lsNoColonFloor = advancedFloor} in lexNormalMode newSt (tok : acc) -- | Match upstream's URI token at the start of the input: -- @[a-zA-Z][a-zA-Z0-9+.-]*:[uri-char]+@ (lexer.l). The scheme starts -- with a letter (never @_@), and one URI char after the colon suffices - --- scheme-only URIs like @mailto:x@ count. Returns the URI text and the --- remaining input. +-- scheme-only URIs like @mailto:x@ count. Returns the URI bytes. -- -- Threads the 'lsNoColonFloor' watermark: when the scheme-char run ends -- at a NON-colon, no position inside that run can start a URI (a suffix -- of the run spans to the same terminator), so the run's end is recorded -- and later positions inside it answer Nothing in O(1). A run ending at -- @:@ records nothing - a shorter suffix of it may itself be a URI. -uriSpanFrom :: Int -> Text -> (Maybe (Text, Text), Int) +uriSpanFrom :: Int -> ByteString -> (Maybe ByteString, Int) uriSpanFrom noColonFloor input - | lengthWord8 input > noColonFloor = (Nothing, noColonFloor) - | otherwise = case T.uncons input of + | BS.length input > noColonFloor = (Nothing, noColonFloor) + | otherwise = case BC.uncons input of Just (schemeStart, _) - | isAlpha schemeStart -> - let (scheme, afterScheme) = T.span isSchemeChar input - in case T.stripPrefix ":" afterScheme of + | isAsciiAlpha schemeStart -> + let (scheme, afterScheme) = BC.span isSchemeChar input + in case BS.stripPrefix ":" afterScheme of Just afterColon - | (body, afterUri) <- T.span isUriChar afterColon, - not (T.null body) -> - (Just (scheme <> ":" <> body, afterUri), noColonFloor) + | (body, afterUri) <- BC.span isUriChar afterColon, + not (BS.null body) -> + (Just (BS.take (BS.length input - BS.length afterUri) input), noColonFloor) Just _ -> (Nothing, noColonFloor) - Nothing -> (Nothing, lengthWord8 input - lengthWord8 scheme) + Nothing -> (Nothing, BS.length input - BS.length scheme) _ -> (Nothing, noColonFloor) -identToToken :: Text -> Token +identToToken :: ByteString -> Token identToToken "if" = TokIf identToToken "then" = TokThen identToToken "else" = TokElse @@ -826,7 +854,7 @@ identToToken "true" = TokTrue identToToken "false" = TokFalse identToToken "null" = TokNull -identToToken name = TokIdent name +identToToken name = TokIdent (asciiText name) -- --------------------------------------------------------------------------- -- Paths and search paths @@ -834,10 +862,10 @@ lexPath :: LexState -> [Located] -> Either ParseError [Located] lexPath st acc = - let (pathText, after) = T.span isPathChar (lsInput st) - len = T.length pathText - newSt = advanceCol len st {lsInput = after} - in if "${" `T.isPrefixOf` after + let (pathBytes, after) = BC.span isPathChar (lsInput st) + pathText = asciiText pathBytes + newSt = consume (BS.length pathBytes) st + in if "${" `BS.isPrefixOf` after then -- The literal continues through an interpolation: the head -- piece opens and 'lexPathMode' carries on, upstream's @@ -845,7 +873,7 @@ let tok = Located (lsLine st) (lsCol st) (TokPathInterpStart pathText) in lexPathMode (newSt {lsModes = ModePath : lsModes newSt}) (tok : acc) else - if T.isSuffixOf "/" pathText + if "/" `BS.isSuffixOf` pathBytes then pathTrailingSlashError st else let tok = Located (lsLine st) (lsCol st) (TokPath pathText) @@ -859,14 +887,13 @@ -- trailing slash" parse error. lexPathMode :: LexState -> [Located] -> Either ParseError [Located] lexPathMode st acc - | "${" `T.isPrefixOf` lsInput st = + | "${" `BS.isPrefixOf` lsInput st = let tok = Located (lsLine st) (lsCol st) TokInterpOpen newSt = - advanceCol + consume 2 st - { lsInput = T.drop 2 (lsInput st), - lsModes = ModeNormal : lsModes st, + { lsModes = ModeNormal : lsModes st, -- Fresh count for the interpolation body; the -- enclosing context's count is restored at the -- matching TokInterpClose. @@ -875,25 +902,24 @@ } in lexLoop newSt (tok : acc) | otherwise = - let (chunk, after) = T.span isPathChar (lsInput st) - len = T.length chunk - newSt = advanceCol len st {lsInput = after} + let (chunk, after) = BC.span isPathChar (lsInput st) + newSt = consume (BS.length chunk) st endTok = Located (lsLine newSt) (lsCol newSt) TokPathEnd popped = newSt {lsModes = safeTail (lsModes newSt)} - in if T.null chunk + in if BS.null chunk then -- The character after an interpolation is not a path -- character: the literal ends right there. lexNormalMode popped (endTok : acc) else - if "${" `T.isPrefixOf` after + if "${" `BS.isPrefixOf` after then - let tok = Located (lsLine st) (lsCol st) (TokPathLit chunk) + let tok = Located (lsLine st) (lsCol st) (TokPathLit (asciiText chunk)) in lexPathMode newSt (tok : acc) else - if T.isSuffixOf "/" chunk + if "/" `BS.isSuffixOf` chunk then pathTrailingSlashError st else - let tok = Located (lsLine st) (lsCol st) (TokPathLit chunk) + let tok = Located (lsLine st) (lsCol st) (TokPathLit (asciiText chunk)) in lexNormalMode popped (endTok : tok : acc) -- | Upstream's INPATH_SLASH error, verbatim: a path literal may not end @@ -911,14 +937,13 @@ lexSearchPath :: LexState -> [Located] -> Either ParseError [Located] lexSearchPath st acc = -- st is at '<', skip it - let after = T.drop 1 (lsInput st) - (name, after2) = T.span isSearchPathChar after - in case T.uncons after2 of - Just ('>', after3) -> - let tok = Located (lsLine st) (lsCol st) (TokSearchPath name) - totalLen = T.length name + 2 -- < + name + > - newSt = advanceCol totalLen st {lsInput = after3} - in lexNormalMode newSt (tok : acc) + let after = BS.drop 1 (lsInput st) + (name, after2) = BC.span isSearchPathChar after + in case BC.uncons after2 of + Just ('>', _) -> + let tok = Located (lsLine st) (lsCol st) (TokSearchPath (asciiText name)) + totalLen = BS.length name + 2 -- < + name + > + in lexNormalMode (consume totalLen st) (tok : acc) _ -> -- Not a search path, just '<' emit1 st TokLt acc @@ -928,47 +953,61 @@ -- --------------------------------------------------------------------------- skipWhitespace :: LexState -> LexState -skipWhitespace st = case T.uncons (lsInput st) of - Just ('\n', rest) -> skipWhitespace st {lsInput = rest, lsLine = lsLine st + 1, lsCol = 1} - Just (c, rest) | isSpace c -> skipWhitespace (advanceCol 1 st {lsInput = rest}) - _ -> st +skipWhitespace st = consume (BS.length (BC.takeWhile isNixSpace (lsInput st))) st +-- | Skip a line comment, which ends before the first CR or LF, as +-- upstream's @\#[^\\r\\n]*@ rule (lexer.l) ends it: the line ending is +-- whitespace. skipLineComment :: LexState -> LexState -skipLineComment st = - let (_, after) = T.break (== '\n') (lsInput st) - in case T.uncons after of - Just ('\n', rest) -> st {lsInput = rest, lsLine = lsLine st + 1, lsCol = 1} - _ -> st {lsInput = after} +skipLineComment st = consume (BS.length (BC.takeWhile (not . isLineEndingByte) (lsInput st))) st +-- | Skip a block comment's body and its @*\/@, the opening @\/*@ already +-- consumed. The comment ends at the first @*\/@, as upstream's rule +-- (lexer.l) ends it. skipBlockComment :: LexState -> Either ParseError LexState -skipBlockComment st = case T.uncons (lsInput st) of - Nothing -> - Left - ParseError - { peFile = lsFile st, - peLine = lsLine st, - peCol = lsCol st, - peMessage = "unterminated block comment" - } - Just (c, rest) -> case c of - '*' - | Just '/' <- safeHead rest -> - Right (advanceCol 2 st {lsInput = T.drop 1 rest}) - '\n' -> skipBlockComment st {lsInput = rest, lsLine = lsLine st + 1, lsCol = 1} - _ -> skipBlockComment (advanceCol 1 st {lsInput = rest}) +skipBlockComment st = + let (body, after) = BS.breakSubstring "*/" (lsInput st) + bodySt = consume (BS.length body) st + in if BS.null after + then + Left + ParseError + { peFile = lsFile bodySt, + peLine = lsLine bodySt, + peCol = lsCol bodySt, + peMessage = "unterminated block comment" + } + else Right (consume 2 bodySt) -- --------------------------------------------------------------------------- -- Character predicates -- --------------------------------------------------------------------------- +-- | Upstream's whitespace class, @[ \\t\\r\\n]@ (lexer.l). A vertical tab, +-- a form feed and every non-ASCII space start no token there. +isNixSpace :: Char -> Bool +isNixSpace c = c == ' ' || c == '\t' || c == '\r' || c == '\n' + +-- | A byte a line ending is made of, CR or LF. +isLineEndingByte :: Char -> Bool +isLineEndingByte c = c == '\r' || c == '\n' + +-- | An ASCII letter, upstream's @[a-zA-Z]@. +isAsciiAlpha :: Char -> Bool +isAsciiAlpha c = isAsciiUpper c || isAsciiLower c + +-- | An ASCII letter or digit, upstream's @[a-zA-Z0-9]@. +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = isAsciiAlpha c || isDigit c + isIdentStart :: Char -> Bool -isIdentStart c = isAlpha c || c == '_' +isIdentStart c = isAsciiAlpha c || c == '_' isIdentChar :: Char -> Bool -isIdentChar c = isAlphaNum c || c == '_' || c == '\'' || c == '-' +isIdentChar c = isAsciiAlphaNum c || c == '_' || c == '\'' || c == '-' isPathChar :: Char -> Bool -isPathChar c = isAlphaNum c || c `elem` ("/.~_-+" :: [Char]) +isPathChar c = isAsciiAlphaNum c || c `elem` ("/.~_-+" :: [Char]) -- | Does the maximal path-char run at the start of the input contain a -- @/@-segment (a slash followed by a non-slash path char)? If so it lexes @@ -982,42 +1021,51 @@ -- a path, since the run's characters and its terminator are the same -- bytes every later check would rescan). A run that CONTAINS a slash -- records nothing: a later position inside it can legitimately answer --- differently (@a//b.c/d@ is update-then-path). 'lengthWord8' is the --- O(1) position measure; byte counts, so it is monotone under suffixing. -looksLikePathFrom :: Int -> Text -> (Bool, Int) +-- differently (@a//b.c/d@ is update-then-path). The remaining input's +-- length is the O(1) position measure, monotone under suffixing. +looksLikePathFrom :: Int -> ByteString -> (Bool, Int) looksLikePathFrom noSlashFloor input - | lengthWord8 input > noSlashFloor = (False, noSlashFloor) + | BS.length input > noSlashFloor = (False, noSlashFloor) | otherwise = - let run = T.takeWhile isPathChar input - (_, slashAndRest) = T.break (== '/') run + let run = BC.takeWhile isPathChar input + (_, slashAndRest) = BC.break (== '/') run -- Upstream's PATH_SEG rule: a run ending in @/@ immediately -- followed by @${@ opens an interpolated path (@./${v}@, -- @/${v}@, @a/${v}@), even though the slash has no segment -- after it yet - the segment arrives at eval. Such runs -- contain a slash, so the slash-free watermark is untouched. interpFollows = - T.isSuffixOf "/" run - && "${" `T.isPrefixOf` T.drop (T.length run) input - in if T.null slashAndRest - then (False, lengthWord8 input - lengthWord8 run) - else case T.uncons (T.drop 1 slashAndRest) of + "/" `BS.isSuffixOf` run + && "${" `BS.isPrefixOf` BS.drop (BS.length run) input + in if BS.null slashAndRest + then (False, BS.length input - BS.length run) + else case BC.uncons (BS.drop 1 slashAndRest) of Just (afterSlash, _) -> (interpFollows || (isPathChar afterSlash && afterSlash /= '/'), noSlashFloor) Nothing -> (interpFollows, noSlashFloor) isSearchPathChar :: Char -> Bool -isSearchPathChar c = isAlphaNum c || c `elem` ("/.~_-+" :: [Char]) +isSearchPathChar c = isAsciiAlphaNum c || c `elem` ("/.~_-+" :: [Char]) -- | Chars allowed in a URI scheme after the leading letter, per upstream -- lexer.l: @[a-zA-Z][a-zA-Z0-9+.-]*@. isSchemeChar :: Char -> Bool -isSchemeChar c = isAlphaNum c || c `elem` ("+.-" :: [Char]) +isSchemeChar c = isAsciiAlphaNum c || c `elem` ("+.-" :: [Char]) -- | Chars allowed after the scheme colon, exactly upstream lexer.l's URI -- class @[a-zA-Z0-9%\/?:\@&=+$,-_.!~*']@. Notably @#@ is NOT a URI char -- (it starts a comment mid-URI upstream), while @*@ and @'@ are. isUriChar :: Char -> Bool -isUriChar c = isAlphaNum c || c `elem` ("%/?:@&=+$,-_.!~*'" :: [Char]) +isUriChar c = isAsciiAlphaNum c || c `elem` ("%/?:@&=+$,-_.!~*'" :: [Char]) +-- | A byte that continues a UTF-8 sequence, @10xxxxxx@. +isContinuationByte :: Char -> Bool +isContinuationByte c = c >= '\x80' && c < '\xC0' + +-- | The text of bytes an ASCII class matched. Latin-1 agrees with ASCII +-- on every byte such a class admits, and 'TE.decodeLatin1' is total. +asciiText :: ByteString -> Text +asciiText = TE.decodeLatin1 + -- --------------------------------------------------------------------------- -- Emit helpers -- --------------------------------------------------------------------------- @@ -1025,36 +1073,61 @@ emit1 :: LexState -> Token -> [Located] -> Either ParseError [Located] emit1 st tok acc = let located = Located (lsLine st) (lsCol st) tok - newSt = advanceCol 1 st {lsInput = T.drop 1 (lsInput st)} + newSt = consume 1 st in lexNormalMode newSt (located : acc) emit2 :: LexState -> Token -> [Located] -> Either ParseError [Located] emit2 st tok acc = let located = Located (lsLine st) (lsCol st) tok - newSt = advanceCol 2 st {lsInput = T.drop 2 (lsInput st)} + newSt = consume 2 st in lexNormalMode newSt (located : acc) emit3 :: LexState -> Token -> [Located] -> Either ParseError [Located] emit3 st tok acc = let located = Located (lsLine st) (lsCol st) tok - newSt = advanceCol 3 st {lsInput = T.drop 3 (lsInput st)} + newSt = consume 3 st in lexNormalMode newSt (located : acc) -- --------------------------------------------------------------------------- -- State helpers -- --------------------------------------------------------------------------- -advanceCol :: Int -> LexState -> LexState -advanceCol n st = st {lsCol = lsCol st + n} +-- | Take the next @n@ bytes of input, moving the position past them. +consume :: Int -> LexState -> LexState +consume n st = + let (taken, rest) = BS.splitAt n (lsInput st) + in advanceOver taken rest st {lsInput = rest} -advanceBy :: Char -> LexState -> LexState -advanceBy '\n' st = st {lsLine = lsLine st + 1, lsCol = 1} -advanceBy _ st = st {lsCol = lsCol st + 1} +-- | The position past bytes taken from the input, @rest@ being the input +-- after them: each line that ends in them moves it to the start of the +-- next line, and the bytes after the last ending add their columns. +advanceOver :: ByteString -> ByteString -> LexState -> LexState +advanceOver taken rest !st = case afterLineEnding rest taken of + Just nextLine -> advanceOver nextLine rest st {lsLine = lsLine st + 1, lsCol = 1} + Nothing -> st {lsCol = lsCol st + charColumns taken} -safeHead :: Text -> Maybe Char -safeHead t = case T.uncons t of - Just (c, _) -> Just c +-- | The bytes after the first line ending in bytes taken from the input, +-- @rest@ being the input after them. A line ends at an LF, and at a CR +-- that no LF follows, so a CRLF is one ending, as upstream's +-- @Pos::LinesIterator@ (position.cc at 2.24.9) splits a source: at the +-- first CR or LF, a CRLF there taken whole. A CR the bytes end with +-- reads the byte after it from @rest@, so a CRLF that two calls of +-- 'consume' take apart (an escaped CR, then its LF) is still one ending. +afterLineEnding :: ByteString -> ByteString -> Maybe ByteString +afterLineEnding rest bytes = case BC.uncons (BC.dropWhile (not . isLineEndingByte) bytes) of + Just ('\r', afterCr) + | (safeHead afterCr <|> safeHead rest) == Just '\n' -> afterLineEnding rest afterCr + Just (_, afterEnding) -> Just afterEnding Nothing -> Nothing + +-- | The columns a run of bytes with no line ending in it takes: one per +-- byte that does not continue a UTF-8 sequence, so one per character of +-- valid UTF-8. +charColumns :: ByteString -> Int +charColumns = BC.foldl' (\n c -> if isContinuationByte c then n else n + 1) 0 + +safeHead :: ByteString -> Maybe Char +safeHead = fmap fst . BC.uncons safeTail :: [a] -> [a] safeTail [] = [] diff --git a/src/Nix/Push.hs b/src/Nix/Push.hs --- a/src/Nix/Push.hs +++ b/src/Nix/Push.hs @@ -131,12 +131,12 @@ deriving (Eq, Show) -- | The accepted @--compression@ spellings, for parser errors and the --- CLI help line - one rendering of the register in 'Nix.Compression'. +-- CLI help line - one rendering of the register in "Nix.Compression". pushCompressionValues :: Text pushCompressionValues = compressionNameNone <> ", " <> compressionNameZstd -- | Parse the CLI spelling of a push compression. The spellings are --- the narinfo @Compression@ names from 'Nix.Compression', so the CLI +-- the narinfo @Compression@ names from "Nix.Compression", so the CLI -- vocabulary and the wire vocabulary cannot drift. parsePushCompression :: Text -> Either Text PushCompression parsePushCompression name @@ -313,7 +313,7 @@ -- | Construct the narinfo describing a store path. Every artifact -- and NAR field - file hash, file size, compression, object name, NAR --- hash, NAR size - comes from the one 'PushArtifact', so the narinfo +-- hash, NAR size - comes from the one t'PushArtifact', so the narinfo -- is internally consistent by construction. The @StorePath@ uses -- the canonical @\/nix\/store@ form; references and the deriver are -- basenames, matching the wire format. @@ -452,11 +452,11 @@ ) | otherwise -> Right () --- | Recorded and computed NAR hashes match when their decoded digests --- agree, so any valid spelling of one digest matches (a foreign cache --- may record base16 where local hashing renders nix-base32). A --- recorded value no spelling parses falls back to exact text equality, --- keeping legacy rows comparable rather than un-checkable. +-- | Recorded and computed NAR hashes match when both parse as +-- @sha256:@ and nix-base32 and their decoded digests agree. A recorded +-- value that does not parse, such as a foreign cache's base16, falls +-- back to exact text equality, keeping legacy rows comparable rather +-- than un-checkable. narHashMatches :: Text -> Text -> Bool narHashMatches recorded computed = case (Hash.parseNixHash recorded, Hash.parseNixHash computed) of diff --git a/src/Nix/Realise.hs b/src/Nix/Realise.hs new file mode 100644 --- /dev/null +++ b/src/Nix/Realise.hs @@ -0,0 +1,323 @@ +-- | Deciding how to realise a derivation graph: what to substitute, what to +-- build, and in what order, root first. +-- +-- Upstream tries a derivation's outputs before its inputs, so a package a +-- cache holds never pulls in what it was built from +-- (@DerivationGoal::haveDerivation@ at 2.24.9). A substituted path needs its +-- references instead, and those arrive first, so the store stays closed under +-- references at every step (@PathSubstitutionGoal::init@). +-- +-- A cache that lacks a path and one that fails are told apart, as upstream +-- tells them apart. What no cache holds builds. A substitute that a cache +-- offers and fails to deliver stops the build, unless 'BuildFromSource' +-- (upstream's @fallback@) says to build instead +-- (@DerivationGoal::outputsSubstitutionTried@). A cache that cannot be asked +-- stops the build at once ('QueryFailed'); under 'BuildFromSource' the caller +-- asks the next cache instead, so that failure never arrives here. +-- +-- Every effect is a record field, so the decisions run in tests over a fake +-- cache and store. "Nix.Builder" supplies the real ones. +module Nix.Realise + ( -- * Substituting a closure + SubstEffects (..), + Offer (..), + FetchOutcome (..), + ClosureOutcome (..), + substituteClosure, + + -- * Realising a graph + Fallback (..), + RealiseEffects (..), + Realised (..), + RealiseFailure (..), + realiseFailureMessage, + realise, + ) +where + +import Control.Monad (filterM, void) +import Control.Monad.Except (ExceptT (..), runExceptT) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Nix.DependencyGraph (DepGraph (..), DepNode (..), directDeps) +import Nix.Derivation (Derivation (..), DerivationOutput (..)) +import Nix.Store.Path (StorePath, defaultStoreDir, storePathToText) + +-- --------------------------------------------------------------------------- +-- Substituting a closure +-- --------------------------------------------------------------------------- + +-- | What substitution needs from the store and the caches. +data SubstEffects m = SubstEffects + { -- | Is this path already valid in the store? + seValid :: !(StorePath -> m Bool), + -- | What the caches say about a path before anything is fetched. + seReferences :: !(StorePath -> m Offer), + -- | Fetch and register these paths, all of them or none. + seFetch :: !([StorePath] -> m FetchOutcome) + } + +-- | What the caches answer for one path, before anything is fetched. +data Offer + = -- | A cache serves the path, with these references. + Offered ![StorePath] + | -- | No cache serves it. + NotOffered + | -- | A cache could not be asked, and why. Upstream rethrows a failed + -- narinfo query unless @fallback@ is set, which ends the whole build + -- (@PathSubstitutionGoal::init@ at 2.24.9). + QueryFailed !Text + deriving (Eq, Show) + +-- | How fetching a batch of paths ended. +data FetchOutcome + = -- | Every path is valid. + Fetched + | -- | No cache supplied some path, and none failed to. + FetchMissed + | -- | A cache that offered a path failed to deliver it, and no other cache + -- delivered it: upstream's failed substitution. + FetchFailed + deriving (Eq, Show) + +-- | How an attempt to substitute a set of paths ended. +data ClosureOutcome + = -- | The paths and everything they reference are valid. + ClosureComplete + | -- | No cache could supply the paths themselves. + ClosureUnavailable + | -- | A cache has the paths but not something they reference. Building + -- the inputs can supply the hole, so substitution is worth retrying + -- afterwards. + ClosureIncomplete + | -- | A substitute for the paths, or for something they reference, failed + -- ('FetchFailed'). + ClosureFailed + | -- | A cache could not be asked about one of them ('QueryFailed'). + ClosureQueryFailed !Text + deriving (Eq, Show) + +-- | Substitute paths with their closure, references first. +-- +-- The paths arrive together through 'seFetch', because the outputs of one +-- derivation may reference each other and a batch that cannot land whole +-- registers nothing. Anything else they reference arrives first, each path +-- on its own, as upstream's does: a reference that lands before a later +-- failure stays, a valid path like any other, and so can leave its own +-- derivation with only some outputs valid. +substituteClosure :: (Monad m) => SubstEffects m -> [StorePath] -> m ClosureOutcome +substituteClosure effects paths = + fst <$> closureOf effects (Set.fromList paths) paths + +-- | 'substituteClosure', threading the paths already visited. A cache's +-- declared references are not trusted to be acyclic: a cycle ends here at the +-- visited set, and the registration it reaches refuses the unregistered +-- referent. +closureOf :: + (Monad m) => + SubstEffects m -> + Set StorePath -> + [StorePath] -> + m (ClosureOutcome, Set StorePath) +closureOf effects visited paths = do + missing <- filterM (fmap not . seValid effects) paths + -- A failed query ends the build, so it is the last one asked. + declared <- runExceptT (traverse (ExceptT . fmap offeredReferences . seReferences effects) missing) + case (missing, sequence <$> declared) of + ([], _) -> pure (ClosureComplete, visited) + (_, Left failure) -> pure (ClosureQueryFailed failure, visited) + (_, Right Nothing) -> pure (ClosureUnavailable, visited) + (_, Right (Just references)) -> do + let outside = Set.fromList (concat references) `Set.difference` Set.fromList missing + (held, deeper) <- referencesFirst effects visited (Set.toAscList outside) + case held of + ClosureComplete -> do + fetched <- seFetch effects missing + pure (fetchedClosure fetched, deeper) + _ -> pure (held, deeper) + +-- | An offer's references, 'Nothing' when no cache serves the path, or the +-- failure of a query that could not be asked. +offeredReferences :: Offer -> Either Text (Maybe [StorePath]) +offeredReferences (Offered references) = Right (Just references) +offeredReferences NotOffered = Right Nothing +offeredReferences (QueryFailed failure) = Left failure + +-- | What a batch fetch makes of paths whose references are all valid. +fetchedClosure :: FetchOutcome -> ClosureOutcome +fetchedClosure Fetched = ClosureComplete +fetchedClosure FetchMissed = ClosureUnavailable +fetchedClosure FetchFailed = ClosureFailed + +-- | Realise references one at a time, stopping at the first that fails. A +-- reference no cache supplies is a hole the inputs may fill, so the paths +-- naming it are incomplete. A reference whose substitute or query failed +-- passes that failure on, as upstream's goal for a path fails when a +-- reference's goal does (@PathSubstitutionGoal::tryToRun@ at 2.24.9). +referencesFirst :: + (Monad m) => + SubstEffects m -> + Set StorePath -> + [StorePath] -> + m (ClosureOutcome, Set StorePath) +referencesFirst _ visited [] = pure (ClosureComplete, visited) +referencesFirst effects visited (reference : rest) + | reference `Set.member` visited = referencesFirst effects visited rest + | otherwise = do + (outcome, deeper) <- closureOf effects (Set.insert reference visited) [reference] + case outcome of + ClosureComplete -> referencesFirst effects deeper rest + ClosureUnavailable -> pure (ClosureIncomplete, deeper) + ClosureIncomplete -> pure (ClosureIncomplete, deeper) + ClosureFailed -> pure (ClosureFailed, deeper) + ClosureQueryFailed failure -> pure (ClosureQueryFailed failure, deeper) + +-- --------------------------------------------------------------------------- +-- Realising a graph +-- --------------------------------------------------------------------------- + +-- | What a failed substitute leads to: upstream's @fallback@ setting, which +-- its @--fallback@ flag turns on. +data Fallback + = -- | The build stops and names @--fallback@, upstream's default. + NoFallback + | -- | The derivation builds from source instead. + BuildFromSource + deriving (Eq, Show) + +-- | Why realising a graph stopped. +data RealiseFailure + = -- | A derivation failed to build, with the builder's report. + BuildFailed !Text + | -- | A cache could not be asked about a path ('QueryFailed'). + CacheQueryFailed !Text + | -- | A substitute for this derivation's outputs, or for something they + -- reference, failed under 'NoFallback'. + SubstitutesFailed !StorePath + deriving (Eq, Show) + +-- | A failure as the build reports it. A failed substitute reads as +-- upstream's (@DerivationGoal::outputsSubstitutionTried@ at 2.24.9), less +-- the space its format string ends in. The @.drv@ is named under the +-- logical store directory, wherever the store's files live, as upstream's +-- @printStorePath@ names it: a store kept elsewhere still has @/nix/store@ +-- as its @storeDir@ and only its @realStoreDir@ moves. +realiseFailureMessage :: RealiseFailure -> Text +realiseFailureMessage (BuildFailed report) = report +realiseFailureMessage (CacheQueryFailed failure) = failure +realiseFailureMessage (SubstitutesFailed drvPath) = + "some substitutes for the outputs of derivation '" + <> storePathToText defaultStoreDir drvPath + <> "' failed (usually happens due to networking issues); try '--fallback' to build derivation from source" + +-- | How one derivation came to be realised. +data Realised + = -- | Every output was already valid. + AlreadyValid + | -- | Every output came from a cache. + Substituted + | -- | The derivation was built here. + Built + deriving (Eq, Show) + +-- | What realising a graph needs from the outside. +data RealiseEffects m = RealiseEffects + { reSubst :: !(SubstEffects m), + -- | Are all of this derivation's outputs valid? + reAllValid :: !(Derivation -> m Bool), + -- | Build one derivation, whose inputs are realised, given its @.drv@ + -- path. + reBuild :: !(Derivation -> StorePath -> m (Either Text ())), + -- | Report how a derivation was realised. + reReport :: !(Realised -> Derivation -> m ()) + } + +-- | Realise a graph from its root. A derivation that is valid or substituted +-- takes its inputs out of the work, and what remains builds leaves first. +-- +-- The graph has to be acyclic ('Nix.DependencyGraph.topoSort' decides that). +realise :: (Monad m) => Fallback -> RealiseEffects m -> DepGraph -> StorePath -> m (Either RealiseFailure ()) +realise fallback effects graph root = void <$> realiseNode fallback effects graph Set.empty root + +-- | Realise one node, threading the nodes already visited, so a derivation +-- several others depend on is handled once. +realiseNode :: + (Monad m) => + Fallback -> + RealiseEffects m -> + DepGraph -> + Set StorePath -> + StorePath -> + m (Either RealiseFailure (Set StorePath)) +realiseNode fallback effects graph visited node + | node `Set.member` visited = pure (Right visited) + | otherwise = case Map.lookup node (unDepGraph graph) of + -- A node outside the graph has nothing to realise. + Nothing -> pure (Right visited) + Just depNode -> do + let drv = dnDerivation depNode + seen = Set.insert node visited + allValid <- reAllValid effects drv + if allValid + then reported AlreadyValid drv seen + else do + firstTry <- substituteOutputs drv + case (firstTry, stopFor firstTry) of + (ClosureComplete, _) -> reported Substituted drv seen + (_, Just failure) -> pure (Left failure) + (_, Nothing) -> buildFromInputs firstTry drv seen + where + stopFor = substitutionStop fallback node + reported status drv done = Right done <$ reReport effects status drv + substituteOutputs drv = substituteClosure (reSubst effects) (map doPath (drvOutputs drv)) + buildFromInputs firstTry drv seen = do + inputs <- realiseAll fallback effects graph seen (directDeps graph node) + case inputs of + Left err -> pure (Left err) + Right realised -> do + -- The inputs may have supplied what the closure lacked, and then + -- the substitute is still good (upstream's retrySubstitution). + retried <- case firstTry of + ClosureIncomplete -> substituteOutputs drv + other -> pure other + case (retried, stopFor retried) of + (ClosureComplete, _) -> reported Substituted drv realised + (_, Just failure) -> pure (Left failure) + (_, Nothing) -> do + built <- reBuild effects drv node + case built of + Left err -> pure (Left (BuildFailed err)) + Right () -> reported Built drv realised + +-- | The failure a substitution attempt for a derivation stops the build +-- with, if it stops it: a failed query always, and a failed substitute +-- unless the derivation may build from source. Upstream retries a +-- substitution after the inputs only when every failure was a hole in the +-- closure, so a failed substitute that falls back is not retried. +substitutionStop :: Fallback -> StorePath -> ClosureOutcome -> Maybe RealiseFailure +substitutionStop fallback drvPath outcome = case outcome of + ClosureQueryFailed failure -> Just (CacheQueryFailed failure) + ClosureFailed -> case fallback of + NoFallback -> Just (SubstitutesFailed drvPath) + BuildFromSource -> Nothing + ClosureComplete -> Nothing + ClosureUnavailable -> Nothing + ClosureIncomplete -> Nothing + +-- | Realise nodes in order, stopping at the first failure. +realiseAll :: + (Monad m) => + Fallback -> + RealiseEffects m -> + DepGraph -> + Set StorePath -> + [StorePath] -> + m (Either RealiseFailure (Set StorePath)) +realiseAll _ _ _ visited [] = pure (Right visited) +realiseAll fallback effects graph visited (node : rest) = do + realised <- realiseNode fallback effects graph visited node + case realised of + Left err -> pure (Left err) + Right deeper -> realiseAll fallback effects graph deeper rest diff --git a/src/Nix/Store.hs b/src/Nix/Store.hs --- a/src/Nix/Store.hs +++ b/src/Nix/Store.hs @@ -51,8 +51,9 @@ registrationFor, materializeEvalSources, materializeEvalStoreWrites, + rewriteBytes, + rewriteStoreHashes, scanReferences, - scanTempReferences, setReadOnly, unpackNarEntry, writeDrv, @@ -85,7 +86,7 @@ ) where -import Control.Exception (IOException, bracket, catch, onException, throwIO, try, tryJust) +import Control.Exception (IOException, bracket, catch, finally, onException, throwIO, try, tryJust) import Control.Monad (guard, join, unless, when) import Data.Bool (bool) import qualified Data.ByteString as BS @@ -93,7 +94,7 @@ import Data.Char (toUpper) import Data.Foldable (traverse_) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (inits) +import Data.List (inits, stripPrefix) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) @@ -356,13 +357,13 @@ -- | Byte-scan a tree for store path references. -- --- Searches each scan unit ('collectScanUnits': regular file bytes and --- symlink target strings) for each candidate's bare 32-character hash - --- the same needle upstream Nix scans for. Matching the hash rather --- than a store-dir-prefixed path keeps the scan independent of the --- spelling the builder embedded (canonical @\/nix\/store\/...@, --- @C:\\nix\\store\\...@, MSYS2 forms): eval injects canonical --- forward-slash text into builder environments, which a +-- Searches each scan unit ('collectScanUnits': regular file bytes, +-- symlink target strings and entry names) for each candidate's bare +-- 32-character hash - the same needle upstream Nix scans for. Matching +-- the hash rather than a store-dir-prefixed path keeps the scan +-- independent of the spelling the builder embedded (canonical +-- @\/nix\/store\/...@, @C:\\nix\\store\\...@, MSYS2 forms): eval injects +-- canonical forward-slash text into builder environments, which a -- platform-store-dir prefix never matches on Windows. scanReferences :: [StorePath] -> FilePath -> IO [StorePath] scanReferences candidates dir = do @@ -374,52 +375,115 @@ pure (Set.union acc (Set.fromList [h | (needle, h) <- needles, needle `BS.isInfixOf` contents])) pure [sp | (h, sp) <- Set.toList candidateSet, Set.member h foundHashes] --- | Scan an output for references to build-temp output locations. --- --- The builder runs under a temp directory, so an output that embeds its own or --- a sibling output's path embeds the TEMP path - which 'scanReferences' does --- not look for. Given @(tempDir, storePath)@ for every output of --- the derivation, returns the store paths whose temp location is referenced --- from the scanned output, capturing self- and cross-output references. --- --- This records the dependency edge; it does not rewrite the embedded bytes --- (self-reference hash rewriting is a separate, future concern). -scanTempReferences :: [(FilePath, StorePath)] -> FilePath -> IO [StorePath] -scanTempReferences tempPairs dir = do - let needles = [(TE.encodeUtf8 (T.pack tempDir), sp) | (tempDir, sp) <- tempPairs] - units <- collectScanUnits dir - foundHashes <- foldlIO Set.empty units $ \acc unit -> do - contents <- scanUnitBytes unit - pure (Set.union acc (Set.fromList [spHash sp | (needle, sp) <- needles, needle `BS.isInfixOf` contents])) - pure [sp | (_, sp) <- tempPairs, Set.member (spHash sp) foundHashes] +-- | Replace store path hashes across a tree: file bytes, symlink targets and +-- entry names, every place a NAR carries one. Upstream rewrites the serialized +-- NAR and so reaches all three (@rewriteOutput@ in +-- @local-derivation-goal.cc@ at 2.24.9). A store path hash has one length, so +-- no offset inside a file moves. +rewriteStoreHashes :: [(Text, Text)] -> FilePath -> IO () +rewriteStoreHashes [] _ = pure () +rewriteStoreHashes rewrites root = rewriteAt id root + where + byteRewrites = [(TE.encodeUtf8 from, TE.encodeUtf8 to) | (from, to) <- rewrites] + nameRewrites = [(T.unpack from, T.unpack to) | (from, to) <- rewrites] + rewriteName name = foldl' (\acc (from, to) -> replaceInName from to acc) name nameRewrites + -- Replacing a link edits its parent, so the guard for a read-only parent + -- comes from the caller: the root's parent is the store, not the output. + rewriteAt parentGuard path = do + node <- classifyWalkNode path + case node of + WalkSymlink -> do + target <- Dir.getSymbolicLinkTarget path + let updated = rewriteName target + unless (updated == target) (parentGuard (replaceLink path updated)) + WalkDirectory -> do + entries <- listDirectory path + mapM_ (rewriteEntry path) entries + WalkRegular -> do + bytes <- BS.readFile path + let updated = rewriteBytes byteRewrites bytes + unless (updated == bytes) (whileWritable path (BS.writeFile path updated)) + WalkAbsent -> pure () + rewriteEntry dir entry = do + rewriteAt (whileWritable dir) (dir entry) + let renamed = rewriteName entry + unless (renamed == entry) $ do + taken <- doesPathExist (dir renamed) + when taken (ioError (userError ("rewriting a store hash would overwrite " <> (dir renamed)))) + whileWritable dir (renamePath (dir entry) (dir renamed)) +-- | Point a symlink somewhere else. 'Dir.removePathForcibly' removes a file +-- link or a directory link alike, which differ on Windows. +replaceLink :: FilePath -> FilePath -> IO () +replaceLink path target = do + linkOs <- OP.encodeFS path + targetOs <- OP.encodeFS target + Dir.removePathForcibly path + created <- createSymlinkOfKind linkOs targetOs + either (ioError . userError . T.unpack) pure created + +-- | Run an action on a path with write permission, then put its permissions +-- back. A builder may mark its output read-only before registration does. +whileWritable :: FilePath -> IO a -> IO a +whileWritable path action = do + permissions <- Dir.getPermissions path + setPermissions path (Dir.setOwnerWritable True permissions) + action `finally` setPermissions path permissions + +-- | Apply each replacement to bytes, in order. An empty needle matches +-- nothing. +rewriteBytes :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString -> BS.ByteString +rewriteBytes rewrites bytes = foldl' (\acc (from, to) -> replaceInBytes from to acc) bytes rewrites + +replaceInBytes :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString +replaceInBytes from to bytes + | BS.null from = bytes + | otherwise = BS.concat (pieces bytes) + where + pieces remaining = case BS.breakSubstring from remaining of + (before, rest) + | BS.null rest -> [before] + | otherwise -> before : to : pieces (BS.drop (BS.length from) rest) + +-- | 'replaceInBytes' on a path component. The rest of the name is left as +-- the operating system spelled it, so no decoding step can damage it. +replaceInName :: String -> String -> String -> String +replaceInName from to name = case name of + _ | null from -> name + [] -> [] + c : rest -> case stripPrefix from name of + Just after -> to ++ replaceInName from to after + Nothing -> c : replaceInName from to rest + -- | One scannable unit of a walked tree: a regular file's bytes read --- from disk, or a symlink's target string. The NAR serialization --- carries both, so reference scanning covers both - a link into a --- dependency (@bin\/tool -> \/nix\/store\/\-dep\/tool@) --- references the dependency even when no file byte does. -data ScanUnit = ScanFile !FilePath | ScanLinkTarget !BS.ByteString +-- from disk, a symlink's target string, or an entry's name. The NAR +-- serialization carries all three and upstream scans that serialization, +-- so reference scanning covers all three - a link into a dependency +-- (@bin\/tool -> \/nix\/store\/\-dep\/tool@) references the +-- dependency even when no file byte does. +data ScanUnit = ScanFile !FilePath | ScanText !BS.ByteString --- | Collect the scannable units under a path: regular files and symlink --- targets, links never followed. A path that is itself a regular file --- or link is its own single unit. +-- | Collect the scannable units under a path: regular files, symlink +-- targets and the names of a directory's entries, links never followed. +-- A path that is itself a regular file or link is its own single unit. collectScanUnits :: FilePath -> IO [ScanUnit] collectScanUnits path = do node <- classifyWalkNode path case node of WalkSymlink -> do target <- Dir.getSymbolicLinkTarget path - pure [ScanLinkTarget (TE.encodeUtf8 (T.pack target))] + pure [ScanText (TE.encodeUtf8 (T.pack target))] WalkDirectory -> do entries <- listDirectory path - concat <$> mapM (collectScanUnits . (path )) entries + nested <- concat <$> mapM (collectScanUnits . (path )) entries + pure (map (ScanText . TE.encodeUtf8 . T.pack) entries ++ nested) WalkRegular -> pure [ScanFile path] WalkAbsent -> pure [] -- | The bytes a 'ScanUnit' contributes to the scan. scanUnitBytes :: ScanUnit -> IO BS.ByteString scanUnitBytes (ScanFile path) = BS.readFile path -scanUnitBytes (ScanLinkTarget target) = pure target +scanUnitBytes (ScanText text) = pure text -- | Strict left fold over a list in IO. The accumulator is forced to -- WHNF each step - without it, the scan retains every scanned file's @@ -472,8 +536,8 @@ -- | Serialize a derivation to ATerm, write it to the store, and register -- it: a @.drv@ is a store object like any other, so it gets a ValidPaths -- row with its NAR hash and its references. Reference scans may name a --- @.drv@ (an output that embeds an input drv hash), and an unregistered --- referent fails the whole registration batch. +-- @.drv@ (one in a build's input closure, where a @drvPath@'s context puts +-- it), and an unregistered referent fails the whole registration batch. writeDrv :: Store -> Derivation -> StorePath -> IO () writeDrv store drv sp = do writeDrvAterm store sp (toATerm drv) @@ -862,7 +926,7 @@ ufSeen :: !(Map BS.ByteString Int) } --- | Mutable state behind a 'NarUnpackSink' - the same deliberate IO +-- | Mutable state behind a t'NarUnpackSink' - the same deliberate IO -- boundary as the store's other materializers. 'nusTargets' is the -- stack of on-disk paths the NEXT node materializes at: the -- destination at the root, plus one pushed per open directory entry. diff --git a/src/Nix/Store/DB.hs b/src/Nix/Store/DB.hs --- a/src/Nix/Store/DB.hs +++ b/src/Nix/Store/DB.hs @@ -54,6 +54,8 @@ where import Control.Exception (throwIO) +import Data.List (sortOn) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Database.SQLite.Simple @@ -68,7 +70,7 @@ query, withTransaction, ) -import Nix.Store.Path (StoreDir (..), StorePath, storePathToFilePath) +import Nix.Store.Path (StoreDir (..), StorePath, defaultStoreDir, storePathToFilePath, storePathToText) import System.Directory (createDirectoryIfMissing) import System.FilePath (()) @@ -196,10 +198,23 @@ -- Re-registering an existing path refreshes its metadata (NAR hash, size, -- deriver) via @ON CONFLICT DO UPDATE@, so a path first registered with a -- placeholder hash is corrected on a later real registration. +-- +-- A reference to a path neither registered nor in the batch refuses the +-- whole batch, recording nothing, with an 'IOError' carrying upstream's +-- message, @path \'\/nix\/store\/\-\\' is not valid@ +-- (@queryValidPathId@, local-store.cc at 2.24.9). The path is spelled +-- under the logical store directory, as upstream's @printStorePath@ +-- spells it, wherever the store's files are kept: a relocated store +-- still has @\/nix\/store@ as its @storeDir@ and only its @realStoreDir@ +-- moves (local-fs-store.hh). The edges go in upstream's order, the batch +-- by path and each path's references as a sorted set, so of several +-- unregistered references the one named is the one upstream names. The +-- sort is stable, so of two registrations of one path in a batch the +-- later's edges still win. registerPaths :: StoreDB -> [PathRegistration] -> IO () registerPaths db regs = withTransaction (sdbConn db) $ do mapM_ (insertPathRow db) regs - mapM_ (insertPathRefs db) regs + mapM_ (insertPathRefs db) (sortOn prPath regs) -- | Insert (or refresh) a single ValidPaths row. insertPathRow :: StoreDB -> PathRegistration -> IO () @@ -238,7 +253,7 @@ case referrerRows of (Only referrerId : _) -> do execute conn "DELETE FROM Refs WHERE referrer = ?" (Only referrerId) - mapM_ (insertRef conn referrerId) (prReferences reg) + mapM_ (insertRef conn referrerId) (Set.toAscList (Set.fromList (prReferences reg))) [] -> pure () -- Should not happen: the row was just inserted above. where insertRef conn referrerId refPath = do @@ -248,14 +263,7 @@ (Only refId : _) -> execute conn "INSERT OR IGNORE INTO Refs (referrer, reference) VALUES (?, ?)" (referrerId, refId) [] -> - throwIO - ( userError - ( "registerPaths: " - <> storePathToFilePath (sdbDir db) (prPath reg) - <> " references unregistered path " - <> T.unpack refPathText - ) - ) + throwIO (userError ("path '" <> T.unpack (storePathToText defaultStoreDir refPath) <> "' is not valid")) -- --------------------------------------------------------------------------- -- Queries diff --git a/src/Nix/Store/GC.hs b/src/Nix/Store/GC.hs --- a/src/Nix/Store/GC.hs +++ b/src/Nix/Store/GC.hs @@ -89,8 +89,8 @@ -- @gc.lock@, held exclusively by the collector and shared by every -- writer, plus a socket through which a writer registers roots with a -- running collector. nova-nix keeps the lock and drops the socket: --- every open 'Store' handle holds the shared lock from 'openStore' to --- 'closeStore' ("Nix.Store.Handle"), and 'collectGarbage' (and +-- every open t'Store' handle holds the shared lock from 'Nix.Store.Handle.openStore' to +-- 'Nix.Store.Handle.closeStore' ("Nix.Store.Handle"), and 'collectGarbage' (and -- 'withLiveSet', which the checked delete runs under) trades the -- handle's shared lease for the exclusive lock for the duration. A -- collection therefore runs only while no other process has the store diff --git a/src/Nix/Store/Handle.hs b/src/Nix/Store/Handle.hs --- a/src/Nix/Store/Handle.hs +++ b/src/Nix/Store/Handle.hs @@ -3,7 +3,7 @@ -- -- == The lease -- --- Every open 'Store' holds @.nova-nix\/gc.lock@ shared from 'openStore' +-- Every open t'Store' holds @.nova-nix\/gc.lock@ shared from 'openStore' -- to 'closeStore'. A collector needs that lock exclusively, so a -- collection runs only while no other process has the store open, and a -- process opening the store while one runs waits for it to finish. diff --git a/src/Nix/Store/Path.hs b/src/Nix/Store/Path.hs --- a/src/Nix/Store/Path.hs +++ b/src/Nix/Store/Path.hs @@ -44,6 +44,7 @@ storePathToText, isCanonicalStoreText, storeTextToFilePath, + qualifyPathText, parseStorePath, parseStorePathPrefix, parseStorePathBaseName, @@ -57,6 +58,8 @@ storePathNameErrorText, storePathNameReasonText, storePathNameUpstreamText, + BadStorePath (..), + badStorePathText, -- * Constants storePathHashLen, @@ -67,7 +70,7 @@ import Data.Text (Text) import qualified Data.Text as T import Nix.Store.Path.Internal (StorePath (..)) -import System.FilePath (()) +import System.FilePath (isPathSeparator, ()) import qualified System.Info -- | The base directory of the Nix store. @@ -101,12 +104,12 @@ windowsStoreDir :: StoreDir windowsStoreDir = StoreDir "C:\\nix\\store" --- | Convert a 'StorePath' to a full filesystem path under a 'StoreDir'. +-- | Convert a t'StorePath' to a full filesystem path under a t'StoreDir'. storePathToFilePath :: StoreDir -> StorePath -> FilePath storePathToFilePath (StoreDir dir) sp = dir T.unpack (spHash sp <> "-" <> spName sp) --- | Convert a 'StorePath' to canonical 'Text' with forward slashes. +-- | Convert a t'StorePath' to canonical 'Text' with forward slashes. -- Unlike 'storePathToFilePath', this always uses @\/@ as the separator, -- making it safe for ATerm serialization and cross-platform round-trips. storePathToText :: StoreDir -> StorePath -> Text @@ -125,10 +128,11 @@ -- | Resolve path-value text to the filesystem location it names: text -- under the canonical store dir resolves into the given store dir, and --- every other path is taken as written. Writers emit the canonical --- spelling into eval values, so every reader that performs IO on a path --- value must resolve through this - on Windows the rooted @\/nix@ prefix --- would otherwise resolve against the working drive. +-- every other path is 'qualifyPathText' of it. Writers emit the +-- canonical spelling into eval values, so every reader that performs IO +-- on a path value must resolve through this - on Windows the rooted +-- @\/nix@ prefix, and any other rooted path with no drive, would +-- otherwise resolve against the working drive. -- -- The store dir is a parameter rather than 'platformStoreDir' because a -- caller may have been given one: resolving reads against the platform @@ -138,14 +142,47 @@ storeTextToFilePath storeDir txt | isCanonicalStoreText txt = unStoreDir storeDir <> T.unpack (T.drop (T.length defaultStoreDirText) txt) - | otherwise = T.unpack txt + | otherwise = T.unpack (qualifyPathText storeDir txt) +-- | Path-value text named on the drive the file system reads it on, in +-- the value's own spelling: a rooted path with no drive of its own +-- (@\/src\/f.nix@) gains the store directory's drive designator, so the +-- same value names the same file whatever drive is current. Store text +-- is returned as it is: it names the store directory, not the store +-- drive's @\\nix\\store@ (under @--store D:\\s@, @\/nix\/store\/...@ is +-- under @D:\\s@ and @\/nix@ is @D:\/nix@). A store directory with no +-- drive (every POSIX one) leaves every path as it is, as does a path +-- that is relative or already names a drive, and one that leads with two +-- separators, which Windows reads as a UNC or device path naming its own +-- root (a path value never does: canonicalization collapses them). +-- +-- The access policy checks this text and the reads open +-- 'storeTextToFilePath' of it, so the path checked is the path opened. +qualifyPathText :: StoreDir -> Text -> Text +qualifyPathText storeDir txt + | isCanonicalStoreText txt = txt + | Just (lead, rest) <- T.uncons txt, + isPathSeparator lead, + not (maybe False (isPathSeparator . fst) (T.uncons rest)), + Just drive <- storeDirDrive storeDir = + drive <> txt + | otherwise = txt + +-- | The drive designator (@C:@) a store directory begins with, if any. +-- 'Nix.Store.Handle.canonicalStoreDir' makes the directory absolute, so a +-- store on a Windows drive always spells one, and a POSIX store, rooted +-- at @\/@, never does. +storeDirDrive :: StoreDir -> Maybe Text +storeDirDrive (StoreDir dir) = case dir of + letter : ':' : _ | isAsciiUpper letter || isAsciiLower letter -> Just (T.pack [letter, ':']) + _ -> Nothing + -- | Length of the Nix base-32 hash component in store paths (32 chars). storePathHashLen :: Int storePathHashLen = 32 -- | Parse a full store path string like @\/nix\/store\/abc...-name@ into --- a 'StorePath'. Returns 'Nothing' if the path doesn't match the +-- a t'StorePath'. Returns 'Nothing' if the path doesn't match the -- expected format: store dir prefix + separator + 32-char hash + dash + name. -- Accepts both @\/@ and @\\@ as the separator after the store dir, -- so paths round-trip correctly regardless of which OS serialized them. @@ -171,7 +208,7 @@ -- | Parse a store path basename like @abc...-name@ - the form narinfo -- @References@ and @Deriver@ fields carry on the wire - into a --- 'StorePath': 32 nix-base32 hash chars, dash, valid non-empty name. +-- t'StorePath': 32 nix-base32 hash chars, dash, valid non-empty name. -- -- Both components are charset-checked, as upstream does at its parse -- boundary: parsed text can come from a cache, and an unchecked @@ -202,7 +239,7 @@ | Just c <- T.find (not . isNixBase32Char) (T.take storePathHashLen base) = Just ("store path '" <> base <> "' contains illegal base-32 character '" <> T.singleton c <> "'") | Left err <- checkStorePathName (T.drop (storePathHashLen + 1) base) = - Just ("path '" <> base <> "' is not a valid store path: " <> storePathNameUpstreamText err) + Just (invalidPathNameText base err) | otherwise = Nothing -- | The nix-base32 alphabet: @0-9a-z@ without @e o u t@ (chosen upstream @@ -253,7 +290,7 @@ -- -- Enforced at BOTH boundaries: parse ('parseStorePathBaseName') and -- construction (the @makeStorePath@ family in "Nix.Hash"), so an unclean --- name cannot become a 'StorePath' from either side - in particular, no +-- name cannot become a t'StorePath' from either side - in particular, no -- write sink can be handed a path that resolves outside the store root. checkStorePathName :: Text -> Either StorePathNameError () checkStorePathName name @@ -312,6 +349,31 @@ | otherwise -> quoted <> " is not valid: first dash-separated component must not be '" <> segment <> "'" where quoted = "name '" <> name <> "'" + +-- | A store path refused where it is constructed: the hash part it would +-- have had, and why its name is refused. Upstream's @StorePath@ +-- constructor checks the name only once the hash exists (path.cc at +-- 2.24.9), so its refusal names the whole base name. +data BadStorePath = BadStorePath + { -- | The would-be hash part, in nix-base32. + bspHashPart :: !Text, + -- | Why the name is refused. + bspNameError :: !StorePathNameError + } + deriving (Eq, Show) + +-- | Upstream's @BadStorePath@ text for a refused construction: +-- @path '\-\' is not a valid store path: \@. +badStorePathText :: BadStorePath -> Text +badStorePathText (BadStorePath hashPart err) = + invalidPathNameText (hashPart <> "-" <> spneName err) err + +-- | Upstream's @checkPathName@ (path.cc at 2.24.9), which both of its +-- @StorePath@ constructors raise, so a parsed base name and a constructed +-- one are refused in the same words. +invalidPathNameText :: Text -> StorePathNameError -> Text +invalidPathNameText base err = + "path '" <> base <> "' is not a valid store path: " <> storePathNameUpstreamText err -- | Upstream's maximum store path name length. maxStorePathNameLen :: Int diff --git a/src/Nix/Store/Path/Internal.hs b/src/Nix/Store/Path/Internal.hs --- a/src/Nix/Store/Path/Internal.hs +++ b/src/Nix/Store/Path/Internal.hs @@ -1,4 +1,4 @@ --- | The bare 'StorePath' representation. Importing this module is an +-- | The bare t'StorePath' representation. Importing this module is an -- assertion: every value constructed here satisfies the store-path -- invariants (32 nix-base32 hash characters; a name -- 'Nix.Store.Path.checkStorePathName' accepts) - or is @@ -31,7 +31,7 @@ -- | The empty output-path placeholder that derivation-hash masking -- renders: upstream computes a derivation's modulo hash over an ATerm -- whose output path fields are empty strings, and this value exists --- only to carry that rendering through 'DerivationOutput'. It is +-- only to carry that rendering through t'Nix.Derivation.DerivationOutput'. It is -- never a real store identity and must never reach the store, the -- builder, or a context element. maskedOutputPath :: StorePath diff --git a/src/Nix/Substituter.hs b/src/Nix/Substituter.hs --- a/src/Nix/Substituter.hs +++ b/src/Nix/Substituter.hs @@ -17,11 +17,16 @@ -- then re-verify the materialized tree from disk -- 7. Register in the store DB with references from narinfo -- --- If the cache doesn't have it (404, or another status upstream reads --- as the file not being there), fall through to building locally. +-- A cache that lacks the path (404, or another status upstream reads as +-- the file not being there) is passed over, and what no cache holds +-- builds locally. A cache that fails is told apart from one that lacks +-- the path, as upstream tells them apart: a failed narinfo query and a +-- substitute that fails to arrive stop the build, unless +-- 'Nix.Realise.BuildFromSource' (upstream's @fallback@) says to build +-- instead ("Nix.Realise"). -- -- The whole sequence runs under an exclusive per-path lock --- ('Nix.Store.Lock'), upstream's pathlocks protocol: taken before any +-- ("Nix.Store.Lock"), upstream's pathlocks protocol: taken before any -- deletion or download, validity re-checked under it (another process's -- finished path is adopted without touching disk), and held until the -- caller's registration transaction commits. @@ -44,6 +49,7 @@ SubstResult (..), trySubstitute, trySubstituteWith, + queryReferencesWith, -- * Cache configuration CacheConfig (..), @@ -68,7 +74,8 @@ sortCaches, tryCachesWith, validateNarInfoFields, - narInfoPreflight, + NarInfoAnswer (..), + judgeNarInfo, verifySigs, verifyNarHash, verifyNarSize, @@ -97,16 +104,18 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO import Data.Word (Word64) import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTPS import qualified Network.HTTP.Types.Status as HTTP import Nix.Compression (NarCompression (..), parseNarCompression) import Nix.Http (AttemptFailure (..), FetchRetryPolicy, RetryEffects, TransferError (..), attemptFailureMessage, catchSync, defaultFetchRetryPolicy, fetchStatusFailure, ioRetryEffects, retryTransient, statusError, transferFailureHandlers, withTransfer, withUserAgent) +import Nix.Realise (Fallback (..), Offer (..)) import Nix.Store (CaseSensitivity, NarStreamFailure (..), PathLock, Store (..), abortNarUnpack, acquirePathLock, finishNarUnpack, isValid, newNarUnpackSink, releasePathLock, setReadOnly, sinkNarStream, unpackNarEntry, volumeCaseHack) import Nix.Store.DB (PathRegistration (..)) import qualified Nix.Store.ExecBit as ExecBit -import Nix.Store.Path (StoreDir, StorePath (spHash), parseStorePathBaseName, storePathHashLen, storePathToFilePath) +import Nix.Store.Path (StoreDir, StorePath (spHash, spName), parseStorePathBaseName, storePathHashLen, storePathToFilePath) import qualified NovaCache.Bzip2 as Bzip2 import qualified NovaCache.Hash as Hash import qualified NovaCache.NAR as NAR @@ -116,6 +125,7 @@ import qualified NovaCache.Xz as Xz import qualified NovaCache.Zstd as Zstd import qualified System.Directory as Dir +import System.IO (stderr) -- --------------------------------------------------------------------------- -- Types @@ -148,13 +158,13 @@ data SubstResult = -- | Verified and unpacked on disk, NOT yet registered: the carried -- registration is recorded by the caller, which batches every output - -- of a derivation into one 'registerPaths' transaction so + -- of a derivation into one 'Nix.Store.DB.registerPaths' transaction so -- cross-output reference edges are never dropped. The path's lock -- rides along STILL HELD, because the exclusion must survive until -- that transaction commits - released earlier, another process could -- meet the unpacked-but-unregistered window and delete the tree the -- row is about to describe. The caller releases it after - -- registration, on every exit path ('Nix.Builder'). + -- registration, on every exit path ("Nix.Builder"). SubstSuccess !PathRegistration !PathLock | -- | The path was already valid under its lock - another process -- registered it while this one waited - so its work is adopted: @@ -162,9 +172,14 @@ -- is needed. The caller treats this as success. No lock rides -- along; it was released before returning. SubstAlreadyValid - | -- | Cache doesn't have this path. + | -- | No cache supplied the path, and none failed to. A cache without + -- its narinfo counts, as do one whose narinfo names another path or + -- carries no trusted signature, and one whose NAR is gone: upstream + -- passes over all of them without failing the substitution. SubstNotFound - | -- | Download or verification failed. + | -- | A cache failed to deliver the path and no cache supplied it, with + -- the first failure: the narinfo query, the download, or its + -- verification. Upstream's failed substitution. SubstError !Text deriving (Eq, Show) @@ -186,7 +201,7 @@ -- Caches are checked in priority order; the first success stops the -- scan and a failing cache falls through to the remaining ones. On -- success the path is unpacked and read-only on disk but NOT --- registered - the caller records the returned 'PathRegistration'. +-- registered - the caller records the returned t'PathRegistration'. -- Every narinfo and NAR request runs under upstream's retry policy, -- 'defaultFetchRetryPolicy'. trySubstitute :: Store -> [CacheConfig] -> StorePath -> IO SubstResult @@ -194,7 +209,7 @@ -- | 'trySubstitute' under a given retry policy and effects: a build -- passes the policy its @builtin:fetchurl@ downloads run under --- ('Nix.Builder'), and a test passes effects that record rather than +-- ("Nix.Builder"), and a test passes effects that record rather than -- sleep. trySubstituteWith :: FetchRetryPolicy -> RetryEffects IO -> Store -> [CacheConfig] -> StorePath -> IO SubstResult trySubstituteWith _ _ _ [] _ = pure SubstNotFound @@ -219,12 +234,53 @@ releasePathLock lock pure other +-- | What the caches say about a path's references, from the first cache +-- whose narinfo may be used. References arrive before the path that names +-- them ("Nix.Realise"), so this runs ahead of any download, and a narinfo +-- passes the same checks as a substitution before its references are +-- believed. +-- +-- The caches are asked in priority order, as upstream's substitution goal +-- asks them (@PathSubstitutionGoal::init@ at 2.24.9). One without the +-- path is passed over. So is one whose narinfo names another path or no +-- trusted key signed, and the scan says why. A query that fails, once its +-- retries are spent or on a narinfo that does not validate, ends the scan +-- with 'QueryFailed' under 'NoFallback', as upstream rethrows it. Under +-- 'BuildFromSource' it is reported and passed over, as upstream logs it +-- and asks the next cache. +queryReferencesWith :: FetchRetryPolicy -> RetryEffects IO -> Fallback -> [CacheConfig] -> StorePath -> IO Offer +queryReferencesWith _ _ _ [] _ = pure NotOffered +queryReferencesWith policy effects fallback caches sp = do + manager <- HTTPS.getGlobalManager + firstAnswer manager (sortCaches caches) + where + firstAnswer _ [] = pure NotOffered + firstAnswer manager (cache : rest) = do + answer <- + queryNarInfo (Retrying policy effects) manager cache sp + `catchSync` \err -> pure (NarInfoFailed ("query exception: " <> T.pack (show err))) + let next = firstAnswer manager rest + failed failure = case fallback of + NoFallback -> pure (QueryFailed (ccUrl cache <> ": " <> spName sp <> ": " <> failure)) + BuildFromSource -> reportCache cache sp failure >> next + case answer of + NarInfoUsable narInfo -> either failed (pure . Offered) (parseReferences (NarInfo.niReferences narInfo)) + NarInfoAbsent -> next + NarInfoPassedOver reason -> reportCache cache sp reason >> next + NarInfoFailed failure -> failed failure + +-- | Say on stderr what one cache did with a path. +reportCache :: CacheConfig -> StorePath -> Text -> IO () +reportCache cache sp message = + TIO.hPutStrLn stderr (" [subst] " <> ccUrl cache <> ": " <> spName sp <> ": " <> message) + -- | Fold per-cache attempts in priority order. The first success wins and -- stops the scan. An erroring cache falls through to the remaining ones - -- a transient failure (DNS, TLS, HTTP 500, unsupported compression) from a -- higher-priority cache must not mask a hit in the next - and the first -- error, tagged with its cache URL, is reported only when no cache has the --- path. +-- path, as upstream's goal fails only once every substituter has been +-- tried. tryCachesWith :: (Monad m) => (CacheConfig -> m SubstResult) -> [CacheConfig] -> m SubstResult tryCachesWith attempt = go Nothing where @@ -257,51 +313,73 @@ substituteFromCache retry mgr store cache sp lock `catchSync` \err -> pure (SubstError ("substitution exception: " <> T.pack (show err))) --- | Substitution pipeline for a single cache. --- --- Each step is a pure or IO action that produces @Either@ on failure. --- The pipeline short-circuits on the first error via early return. +-- | Substitution pipeline for a single cache: the narinfo, judged +-- ('queryNarInfo'), then the NAR, streamed ('streamWithRetry'). A narinfo +-- this build passes over is a miss here without a word, because the +-- reference query asks every path first and has said why +-- ('queryReferencesWith'). substituteFromCache :: Retrying -> HTTP.Manager -> Store -> CacheConfig -> StorePath -> PathLock -> IO SubstResult substituteFromCache retry mgr store cache sp lock = do - -- 1. Fetch narinfo - narInfoResult <- fetchNarInfo retry mgr cache sp - case narInfoResult of - Left notFoundOrErr -> pure notFoundOrErr - Right narInfo - -- 1b. The served narinfo must describe the requested path. A - -- misconfigured or hostile cache could return a validly-signed narinfo - -- for a DIFFERENT path under this hash's URL. - | not (narInfoMatchesPath sp narInfo) -> - pure - ( SubstError - ( "narinfo identity mismatch: requested " - <> spHash sp - <> ", narinfo names " - <> NarInfo.niStorePath narInfo - ) - ) - | otherwise -> - -- 2-4. The pure preflight, then stream: download, - -- decompress, hash, parse, and materialize in one bounded - -- pass ('streamNarIntoStore'). - case narInfoPreflight cache narInfo of - Left err -> pure (SubstError err) - Right () -> streamWithRetry retry mgr store cache sp narInfo lock + answer <- queryNarInfo retry mgr cache sp + case answer of + -- Unsupported compression rejects before the download: the value is + -- known from the narinfo, and a multi-hundred-MB download that can + -- only fail in decompression is pure waste. It is still a failed + -- substitute, as upstream's decompressor fails one. The strict + -- 'decompressorFor' encodes the same support set; the suite pins + -- their agreement. + NarInfoUsable narInfo -> case streamingDecompressionSupported (NarInfo.niCompression narInfo) of + Left err -> pure (SubstError err) + Right () -> streamWithRetry retry mgr store cache sp narInfo lock + NarInfoAbsent -> pure SubstNotFound + NarInfoPassedOver _ -> pure SubstNotFound + NarInfoFailed failure -> pure (SubstError failure) --- | The pure preflight the pipeline runs before any download is paid --- for, everything decided from the narinfo alone: field validation --- FIRST - above all before 'verifySigs' builds the signed fingerprint --- from the fields - then the signature, then streaming decompression --- support. Unsupported compression rejects here: the value is known --- from the narinfo, and a multi-hundred-MB download that can only --- fail in decompression is pure waste. The strict 'decompressorFor' --- encodes the same support set; the suite pins their agreement. -narInfoPreflight :: CacheConfig -> NarInfo.NarInfo -> Either Text () -narInfoPreflight cache narInfo = do - validateNarInfoFields narInfo - verifySigs cache narInfo - streamingDecompressionSupported (NarInfo.niCompression narInfo) +-- | One cache's narinfo for a path, judged before anything is downloaded. +data NarInfoAnswer + = -- | A narinfo for the path that validates and that a trusted key + -- signed. + NarInfoUsable !NarInfo.NarInfo + | -- | The cache does not hold the path. + NarInfoAbsent + | -- | A narinfo this build passes over, and why: one naming another + -- path, which upstream reads as the path not being in that cache, or + -- one no trusted key signed, which it warns about and skips. + NarInfoPassedOver !Text + | -- | The query failed: the transfer once its retries are spent, a body + -- that does not parse or validate, or a trusted key that does not + -- parse. + NarInfoFailed !Text + deriving (Eq, Show) +-- | Fetch a narinfo from a cache under the substitution's retry policy +-- ('trySubstituteWith') and judge it ('judgeNarInfo'). +queryNarInfo :: Retrying -> HTTP.Manager -> CacheConfig -> StorePath -> IO NarInfoAnswer +queryNarInfo retry mgr cache sp = do + fetched <- retrying retry (fetchNarInfoOnce mgr url) + pure $ case fetched of + Left failure -> NarInfoFailed (attemptFailureMessage failure) + Right Nothing -> NarInfoAbsent + Right (Just narInfo) -> judgeNarInfo cache sp narInfo + where + url = ccUrl cache <> "/" <> spHash sp <> ".narinfo" + +-- | Whether a served narinfo may be used, decided from the narinfo alone, in +-- upstream's order. The fields validate first, standing in for upstream's +-- narinfo parser, and above all before 'verifySigs' builds the signed +-- fingerprint from them. The narinfo must then describe the requested path +-- (@goodStorePath@ in @Store::queryPathInfo@ at 2.24.9): a misconfigured or +-- hostile cache could return a validly signed narinfo for a different path +-- under this hash's URL. Last come the trusted keys, which upstream parses +-- when it checks the signature, and a signature one of them verifies +-- (@PathSubstitutionGoal::init@). +judgeNarInfo :: CacheConfig -> StorePath -> NarInfo.NarInfo -> NarInfoAnswer +judgeNarInfo cache sp narInfo + | Left err <- validateNarInfoFields narInfo = NarInfoFailed err + | not (narInfoMatchesPath sp narInfo) = NarInfoPassedOver ("narinfo names " <> NarInfo.niStorePath narInfo) + | Left err <- trustedKeys cache = NarInfoFailed err + | otherwise = either NarInfoPassedOver (const (NarInfoUsable narInfo)) (verifySigs cache narInfo) + -- | Validate narinfo field syntax before anything consumes the fields - -- above all before 'verifySigs' builds the signed fingerprint from them. -- The fingerprint is delimited text (semicolons between fields, commas @@ -361,7 +439,7 @@ verifiedNarDigest :: VerifiedNar -> Hash.NixHash verifiedNarDigest (VerifiedNar _ digest) = digest --- | The only constructor of a 'VerifiedNar': the hash check, then the +-- | The only constructor of a t'VerifiedNar': the hash check, then the -- size check, with the decoded declared digest carried out. The NAR -- hash is the content-addressed integrity contract; the signature only -- attests to the narinfo, not the body, so network corruption or a @@ -392,7 +470,7 @@ deriver <- parseDeriver (stDir store) (NarInfo.niDeriver narInfo) pure (verified, refs, deriver) --- | The strict pipeline's unpack sink: deserialize a 'VerifiedNar', +-- | The strict pipeline's unpack sink: deserialize a t'VerifiedNar', -- materialize it at the store path, seal it read-only, and recheck the -- tree on disk against the carried digest before building its -- registration from the references and deriver. Follows the same @@ -548,20 +626,6 @@ then pure Nothing else go (chunk : chunks) newTotal --- | Fetch a narinfo from a cache, each request under the substitution's --- retry policy ('trySubstituteWith'). Returns @Left SubstNotFound@ when --- the cache does not hold it, @Left (SubstError msg)@ on any other --- failure, a transient one once the policy has spent its attempts. -fetchNarInfo :: Retrying -> HTTP.Manager -> CacheConfig -> StorePath -> IO (Either SubstResult NarInfo.NarInfo) -fetchNarInfo retry mgr cache sp = do - fetched <- retrying retry (fetchNarInfoOnce mgr url) - pure $ case fetched of - Left failure -> Left (SubstError (attemptFailureMessage failure)) - Right Nothing -> Left SubstNotFound - Right (Just narInfo) -> Right narInfo - where - url = ccUrl cache <> "/" <> spHash sp <> ".narinfo" - -- | One narinfo request: @Right Nothing@ when the cache does not hold -- it. A 'NotFound' or 'Forbidden' answer (404, 410, 401, 403, 407) is -- the cache saying so, not a failure to retry: upstream's transfer layer @@ -607,7 +671,7 @@ -- transfer that verifies wrong, a body past its signed ceiling, a -- status upstream never retries, a write the disk refused - ends the -- attempt at once: retrying a deterministic failure only delays the --- local-build fallback. Every attempt starts from a clean slate +-- outcome. Every attempt starts from a clean slate -- ('streamNarIntoStore' clears the destination first, and every -- failure path, exceptions included, removes what it wrote), so a retry -- restarts the NAR from its first byte, where upstream resumes from the @@ -615,17 +679,20 @@ -- only a transfer that wrote nothing yet. A NAR the narinfo named and -- the cache answers 'NotFound' or 'Forbidden' for is gone: one request, -- as upstream's @SubstituteGone@ (@BinaryCacheStore::narFromPath@ at --- 2.24.9), and an error the cache scan falls through to the next cache --- and then to a local build, as upstream's substitution goal treats a --- gone substitute like one that never existed. A narinfo the cache does --- not hold is a miss handled earlier in 'fetchNarInfo' and never reaches +-- 2.24.9), reported and then a miss the cache scan passes over, because +-- upstream's substitution goal treats a gone substitute like one that +-- never existed rather than as a failure. A narinfo the cache does not +-- hold is a miss handled earlier in 'queryNarInfo' and never reaches -- here. streamWithRetry :: Retrying -> HTTP.Manager -> Store -> CacheConfig -> StorePath -> NarInfo.NarInfo -> PathLock -> IO SubstResult streamWithRetry retry mgr store cache sp narInfo lock = do outcome <- retrying retry (streamNarIntoStore mgr cache store sp narInfo) - pure $ case outcome of - Right registration -> SubstSuccess registration lock - Left failure -> SubstError (attemptFailureMessage failure) + case outcome of + Right (Just registration) -> pure (SubstSuccess registration lock) + Right Nothing -> do + reportCache cache sp ("file '" <> NarInfo.niUrl narInfo <> "' does not exist in the binary cache") + pure SubstNotFound + Left failure -> pure (SubstError (attemptFailureMessage failure)) -- | Thrown inside the streaming pipeline where a chunk convention has -- no error channel (the capped body source); converted back to the @@ -638,7 +705,7 @@ -- | Convert what one download attempt throws into the pipeline's -- failure channel, so the retry budget governs it and the caller's -- cleanup contract holds on every exit: the transfer layer's --- classification ('transferFailureHandlers'), and a 'StreamAbort'. +-- classification ('transferFailureHandlers'), and a t'StreamAbort'. -- Nothing else is caught, so an interrupt is never spent as retry -- budget. tryAttempt :: Text -> IO (Either AttemptFailure a) -> IO (Either AttemptFailure a) @@ -661,8 +728,9 @@ -- classifies what escapes it). The narinfo metadata registration -- needs (declared hash, references, deriver) still parses BEFORE the -- first byte downloads: a malformed narinfo must not leave an --- unpacked-but-unregistered path behind. -streamNarIntoStore :: HTTP.Manager -> CacheConfig -> Store -> StorePath -> NarInfo.NarInfo -> IO (Either AttemptFailure PathRegistration) +-- unpacked-but-unregistered path behind. 'Nothing' when the cache no +-- longer holds the NAR ('streamWithRetry'). +streamNarIntoStore :: HTTP.Manager -> CacheConfig -> Store -> StorePath -> NarInfo.NarInfo -> IO (Either AttemptFailure (Maybe PathRegistration)) streamNarIntoStore mgr cache store sp narInfo = case preflight of Left err -> pure (Left (FatalFailure err)) Right (declaredDigest, refs, deriver, downloadCap) -> do @@ -674,10 +742,10 @@ withTransfer request mgr $ \response -> do let status = HTTP.responseStatus response if status /= HTTP.status200 - then pure (Left (fetchStatusFailure narUrl status)) + then pure (unservedNar narUrl status) else do source <- cappedBodySource downloadCap (HTTP.responseBody response) - materializeNarFromSource store sp narInfo declaredDigest refs deriver source + fmap Just <$> materializeNarFromSource store sp narInfo declaredDigest refs deriver source where preflight = do declaredDigest <- case Hash.parseNixHash (NarInfo.niNarHash narInfo) of @@ -688,6 +756,17 @@ downloadCap <- downloadCapFor narInfo pure (declaredDigest, refs, deriver, downloadCap) +-- | A NAR response that is not a success. 'NotFound' and 'Forbidden' mean +-- the cache no longer holds the NAR, as upstream's binary cache store +-- reads both (@HttpBinaryCacheStore::getFile@ at 2.24.9); any other status +-- is a failure, retried when upstream retries it. +unservedNar :: Text -> HTTP.Status -> Either AttemptFailure (Maybe PathRegistration) +unservedNar narUrl status = case statusError status of + NotFound -> Right Nothing + Forbidden -> Right Nothing + Misc -> Left (fetchStatusFailure narUrl status) + Transient -> Left (fetchStatusFailure narUrl status) + -- | The byte cap on the compressed NAR body, derived from the SIGNED -- NarSize: the Ed25519 fingerprint covers StorePath, NarHash, NarSize, -- and references - not FileSize - so the unsigned FileSize may only @@ -827,8 +906,8 @@ -- | Stream an HTTP body as a chunk source bounded by the download cap -- 'downloadCapFor' derived from the signed NarSize - --- 'readBodyCapped''s discipline without the buffering. Exceeding the --- cap throws 'StreamAbort'; the attempt boundary converts it back to +-- 'readBodyCapped'\'s discipline without the buffering. Exceeding the +-- cap throws t'StreamAbort'; the attempt boundary converts it back to -- the pipeline's error channel. cappedBodySource :: Int -> HTTP.BodyReader -> IO (IO BS.ByteString) cappedBodySource cap reader = do @@ -889,7 +968,7 @@ where rendered = renderXzError xzErr --- | 'xzFailure''s zstd counterpart, under the same taxonomy. +-- | 'xzFailure'\'s zstd counterpart, under the same taxonomy. zstdFailure :: Zstd.ZstdError -> AttemptFailure zstdFailure zstdErr = case zstdErr of Zstd.ZstdStreamError _ -> TransientFailure rendered @@ -897,7 +976,7 @@ where rendered = renderZstdError zstdErr --- | 'xzFailure''s bzip2 counterpart, under the same taxonomy. +-- | 'xzFailure'\'s bzip2 counterpart, under the same taxonomy. bzip2Failure :: Bzip2.Bzip2Error -> AttemptFailure bzip2Failure bzip2Err = case bzip2Err of Bzip2.Bzip2StreamError _ -> TransientFailure rendered @@ -915,18 +994,22 @@ -- | Verify narinfo signatures against the cache's trusted public keys. -- Accepts when at least one signature verifies under at least one key, --- upstream's any-trusted-key rule. A malformed key is an error rather --- than a silently skipped one: upstream rejects the configuration, so a --- typo cannot quietly narrow the trusted set to the keys that parsed. +-- upstream's any-trusted-key rule. verifySigs :: CacheConfig -> NarInfo.NarInfo -> Either Text () verifySigs cache narInfo = case NarInfo.niSigs narInfo of [] -> Left "narinfo has no signatures" sigs -> do - keys <- traverse parseKey (ccPublicKeys cache) + keys <- trustedKeys cache if any (\key -> any (Signing.verify key narInfo) sigs) keys then Right () else Left "no valid signature found" + +-- | The cache's trusted public keys. A malformed key is an error rather +-- than a silently skipped one: upstream rejects the configuration, so a +-- typo cannot quietly narrow the trusted set to the keys that parsed. +trustedKeys :: CacheConfig -> Either Text [Signing.PublicKey] +trustedKeys = traverse parseKey . ccPublicKeys where parseKey raw = case Signing.parsePublicKey raw of Left err -> Left ("invalid public key: " <> T.pack err) @@ -1049,7 +1132,7 @@ -- | Parse a narinfo Deriver - a store path basename on the wire, or the -- @unknown-deriver@ sentinel - into the full path text the store DB --- records (the form 'Nix.Push' parses back with 'parseStorePath'). +-- records (the form "Nix.Push" parses back with 'Nix.Store.Path.parseStorePath'). parseDeriver :: StoreDir -> Maybe Text -> Either Text (Maybe Text) parseDeriver _ Nothing = Right Nothing parseDeriver storeDir (Just txt) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -9,16552 +9,19226 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as TarEntry -import qualified Codec.Compression.Zstd.Lazy as ZstdL -import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay) -import Control.Concurrent.Async (asyncThreadId, cancel, waitCatch, withAsync) -import Control.Exception (AsyncException (..), ErrorCall (..), IOException, SomeAsyncException (..), SomeException, asyncExceptionToException, bracket, bracket_, catches, displayException, evaluate, finally, fromException, throw, throwIO, throwTo, toException, try) -import Control.Monad (filterM, unless, void, when) -import Data.Bits (shiftR, xor, (.&.)) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Unsafe as BSU -import Data.Char (isDigit) -import Data.Functor.Identity (Identity (..)) -import Data.IORef (atomicModifyIORef', newIORef, readIORef) -import Data.Int (Int64) -import Data.List (intercalate, isPrefixOf, sort) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.IO as TIO -import Data.Word (Word32, Word64, Word8) -import qualified Database.SQLite.Simple as SQL -import Foreign.C.Error (Errno (..), eACCES, eISDIR, eNOENT, eNOTDIR) -import Foreign.C.Types (CChar) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr (Ptr, castPtr, nullPtr) -import Foreign.StablePtr (StablePtr, castPtrToStablePtr, castStablePtrToPtr, deRefStablePtr, freeStablePtr, newStablePtr) -import Foreign.Storable (poke, sizeOf) -import qualified GHC.Foreign as GHCForeign -import GHC.IO.Encoding (getFileSystemEncoding, mkTextEncoding, setFileSystemEncoding) -import GHC.IO.Exception (IOErrorType (..), IOException (..)) -import HttpFixture (Reply (..), httpResponse, withFetchurlServer, withHttpServer) -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Types.Status as HTTP -import Nix.Builder (BuildConfig (..), BuildResult (..), BuilderSpawn (..), buildDerivation, buildPath, buildWithDeps, defaultBuildConfig, execWrapperConfig, execWrapperFor, fetchUrlsFromEnv, rewriteEnv, rewritePlaceholders, scrubAmbient, spawnFor, tryFetchUrlsWith, unionEnvs, verifyFetchHash) -import Nix.Builder.Unpack (UnpackLimits (..), builtinUnpackBuilder, defaultUnpackLimits, entryComponents, envSrcs, resolveLinkTarget, runBuiltinUnpack) -import Nix.Builtins (builtinEnv, isNixPathPseudoUrl, parseNixPath, rootScopeNames, splitNixPath) -import Nix.Config (NixConfig (..)) -import qualified Nix.Config as Config -import qualified Nix.DependencyGraph as DepGraph -import Nix.Derivation (Derivation (..), DerivationOutput (..), Platform (..), currentPlatform, extraPlatforms, fromATerm, platformToText, textToPlatform, toATerm, toATermForHash) -import Nix.Derivation.StructuredAttrs (StructuredAttrs (..), decodeStructuredAttrs, encodeStructuredAttrs, renderAttrsShell, stringsAttr, withOutputPlaceholders) -import Nix.Eval (EvalPolicy (..), FetchCache (..), FetchGitArgs (..), MonadEval (..), NixValue (..), StringContext (..), StringContextElement (..), Thunk (..), attrSetFromMap, attrSetLookup, attrSetNull, attrSetSize, builtinNames, checkGitRef, checkGitRev, checkGitUrl, decodeFetchCache, emptyContext, emptyEnv, encodeFetchCache, eval, evaluated, fetchCacheKey, force, gitInputUrl, mkStr, readThunkValue, runPureEval, typeName, unrestrictedPolicy) -import Nix.Eval.Arena (CStatusError (..), arenaDestroy, arenaInit, arenaLive) -import Nix.Eval.AttrPath (parseAttrPath, selectAttrPath) -import Nix.Eval.CAttrSet (cattrsetFreeze, cattrsetIndex, cattrsetInsert, cattrsetKeys, cattrsetLookup, cattrsetNew, cattrsetSize, cattrsetUnion) -import Nix.Eval.CBytecode (appDeferred, attrkeyStatic, binaryAdd, captureSlots, captureWithScopes, cbcArg1, cbcArg2, cbcArg3, cbcData, cbcDataCount, cbcFlags, cbcOpCount, cbcOpcode, cbcShortArg, formalName, formalNamedSet, formalSet, reservedApply1, reservedApply2, strpartInterp, strpartLit, unaryNegate, pattern OpApp, pattern OpAssert, pattern OpAttrs, pattern OpBinary, pattern OpHasAttr, pattern OpIf, pattern OpIndStr, pattern OpLambda, pattern OpLet, pattern OpList, pattern OpLitBool, pattern OpLitFloat, pattern OpLitInt, pattern OpLitNull, pattern OpLitPath, pattern OpLitUri, pattern OpResolvedVar, pattern OpSelect, pattern OpStr, pattern OpUnary, pattern OpVar, pattern OpWith, pattern OpWithVar) -import Nix.Eval.CEnv (cenvLazyScope) -import Nix.Eval.CList (clistDrop, clistFromThunks, clistIndex, clistLen, clistNew, clistThunks) -import Nix.Eval.CThunk (CThunkPtr, cthunkBool, cthunkCount, cthunkGet, cthunkGetBcIdx, cthunkGetBool, cthunkMarkBlackhole, cthunkNewBc, cthunkNewComputed, cthunkNewComputedInt, cthunkNull, cthunkPayload, cthunkSetComputed, cthunkSetPayload, cthunkState, cthunkValueTag) -import Nix.Eval.CallDepth (topLevelCallDepth) -import Nix.Eval.CanonPath (canonPath, canonPathValue) -import Nix.Eval.Compile (BcBinding (..), BcInheritedName (..), compileExpr, decodeBcBindings) -import qualified Nix.Eval.Context as Context -import Nix.Eval.IO (EvalFailure (..), EvalState (..), allowEvalPath, newEvalState, renderEvalFailure, runEvalIO, runEvalIOTraced) -import Nix.Eval.Policy (allowPathIn, forbiddenPathMessage, isAllowedPath, isAllowedUri, joinComponents, noAllowedPaths, pathComponents, uriAccess) -import Nix.Eval.Print (PrintOptions (..), printAmbiguous, printValue) -import Nix.Eval.SourceError (SourceAccess (..), sourceErrorMessage) -import Nix.Eval.StringInterp (joinCoercedList) -import Nix.Eval.Symbol (Symbol (..), symbolCount, symbolIntern, symbolInternBytes, symbolLen, symbolText) -import Nix.Eval.Types (AttrSet (..), Env (..), allocCSlots, attrSetKeys, buildCSlots, emptyCList, pattern ThunkComputed, pattern ValueBool, pattern ValueNull) -import Nix.Expr.Resolve (impureOnlyGlobalNames, staticGlobalNames, undefinedVariableMessage) -import Nix.Expr.Types -import Nix.Hash (compressHash, hashPlaceholder, makeFixedOutputPath, makeTextPath, sha256Digest) -import qualified Nix.Hash as Hash -import Nix.HostPath (hostPathFromBytes) -import Nix.Http (FetchRetryPolicy (..), RetryEffects (..), TransferError (..), defaultFetchRetryPolicy, fetchExceptionFailure, fetchStatusFailure, retryDelayMs, retryTransient, statusError, transferBodyReader, transferFailureHandlers, userAgent, withUserAgent) -import Nix.Json (Json (..), parseJson, renderJson) -import Nix.Parser (ParseError (..), SourceError (..), parseNix, parseNixWithScope) -import Nix.Parser.Lexer (Located (..), Token (..), tokenize) -import Nix.Push (PushArtifact (..), PushCompression (..), PushConfig (..), checkRecordedNarHash, computeClosure, isDerivationPath, loadApiKeyFile, mkNarInfo, mkPushArtifact, narFileName, narHashMatches, outputPathsOnly, parsePushCompression, planMissing, pushPaths, storePathBasename, stripHashPrefix) -import Nix.Store (DeleteOutcome (..), GcResults (..), GcRoot (..), Store (..), SweepPlan (..), acquirePathLock, addOutLinkRoot, addToStore, autoRootsDir, caseHackDiskNames, closeStore, collectGarbage, copyPathInto, deleteStorePathRaw, findRoots, gcLockFilePath, gcRootsDir, gcSummaryLine, indirectRootRecordName, isValid, materializeEvalSources, materializeEvalStoreWrites, onDiskNameKey, openStore, orderLinks, pathExists, reachableFrom, referencesMap, registrationFor, releasePathLock, resolveDeleteTarget, scanReferences, scanTempReferences, setReadOnly, showFreedBytes, sweepPlan, tryAcquirePathLock, unpackNarEntry, withCollectorLock, writeDrv, writeDrvClosure) -import Nix.Store.CaseSensitive (CaseSensitivity (..), probeCaseSensitivity, processCaseHack, trySetCaseSensitiveDir, volumeCaseHack) -import Nix.Store.DB (PathInfo (..), PathRegistration (..), closeStoreDB, dbFileName, isValidPath, metaDirName, openStoreDB, queryAllValidPaths, queryDeriver, queryPathInfo, queryReferences, registerPath, registerPaths) -import Nix.Store.EntryName (NameRules (..), checkEntryName, checkLinkTarget) -import qualified Nix.Store.ExecBit as ExecBit -import Nix.Store.Path (StoreDir (..), StorePath, StoreWriteMode (..), defaultStoreDir, defaultStoreDirText, isCanonicalStoreText, parseStorePath, parseStorePathPrefix, platformStoreDir, storePathToFilePath, storePathToText, storeTextToFilePath, windowsStoreDir) -import Nix.Store.Path.Internal (StorePath (..)) -import qualified Nix.Substituter as Subst -import qualified NovaCache.Base64 as B64 -import qualified NovaCache.Hash as CHash -import qualified NovaCache.NAR as NAR -import qualified NovaCache.NarInfo as NarInfo -import qualified NovaCache.Signing as Signing -import qualified NovaCache.Zstd as CZstd -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getPermissions, getTemporaryDirectory, removeDirectoryRecursive, writable) -import qualified System.Directory as Dir -import System.Environment (getArgs, getEnvironment, getExecutablePath, lookupEnv, setEnv, unsetEnv) -import qualified System.Environment.Blank as Blank -import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) -import System.FilePath (dropDrive, joinPath, makeRelative, pathSeparator, searchPathSeparator, splitDirectories, takeDirectory, takeDrive, takeFileName, ()) -import System.IO (BufferMode (..), IOMode (..), hPutStrLn, hSetBuffering, stderr, stdout, withBinaryFile) -import System.IO.Error (ioeGetErrorString, mkIOError, resourceVanishedErrorType) -import System.IO.Unsafe (unsafePerformIO) -import qualified System.Info as SI -import System.OsPath (OsPath) -import qualified System.OsPath as OP -import qualified System.Process as Proc -import System.Timeout (timeout) -import qualified Test.QuickCheck as QC - --- --------------------------------------------------------------------------- --- Test harness --- --------------------------------------------------------------------------- - -data TestResult = Pass | Fail !Text - -runTest :: Text -> TestResult -> IO Bool -runTest name result = case result of - Pass -> do - putStrLn $ " PASS " ++ T.unpack name - pure True - Fail msg -> do - putStrLn $ " FAIL " ++ T.unpack name ++ ": " ++ T.unpack msg - pure False - --- | Like 'runTest' but for tests that need IO to produce their result. --- An exception escaping the action becomes one FAIL line instead of --- aborting the whole suite (which would skip every later group and its --- cleanup). -runTestM :: Text -> IO TestResult -> IO Bool -runTestM name action = do - outcome <- try action - runTest name $ case outcome of - Left (e :: SomeException) -> Fail ("uncaught exception: " <> T.pack (show e)) - Right result -> result - -assertEqual :: (Eq a, Show a) => Text -> a -> a -> TestResult -assertEqual label expected actual - | expected == actual = Pass - | otherwise = - Fail $ - label - <> ": expected " - <> T.pack (show expected) - <> " but got " - <> T.pack (show actual) - --- | The first failure of two results, or 'Pass' when both pass. -andThen :: TestResult -> TestResult -> TestResult -andThen first second = case first of - Pass -> second - failed -> failed - --- | Render string-value bytes in a failure message (display-only decode). -bytesText :: BS.ByteString -> Text -bytesText = TE.decodeUtf8With lenientDecode - -assertRight :: (Show e) => Text -> Either e a -> (a -> TestResult) -> TestResult -assertRight label result check = case result of - Left err -> Fail (label <> ": got error: " <> T.pack (show err)) - Right val -> check val - -assertLeft :: (Show a) => Text -> Either e a -> TestResult -assertLeft _ (Left _) = Pass -assertLeft label (Right val) = Fail (label <> ": expected error but got: " <> T.pack (show val)) - --- | What a test expression's relative path literals resolve against. --- Absolute, because that is the invariant the parser now establishes: no --- relative path literal survives parsing, so nothing downstream has to know --- what one would have meant. -testBaseDir :: FilePath -testBaseDir = "/nova-nix-test" - --- | Helper: parse and check result. -assertParse :: Text -> Text -> Expr -> TestResult -assertParse = assertParseIn [] - --- | 'assertParse' for source whose free variables are bound around it, the --- way @scopedImport@ binds its scope: each stays a name-based 'EVar'. -assertParseIn :: [Text] -> Text -> Text -> Expr -> TestResult -assertParseIn names label source expected = - assertRight label (parseNixWithScope (withGlobals names) testBaseDir "" source) $ \actual -> - assertEqual label expected actual - --- | The root environment's names with more bound around them. -withGlobals :: [Text] -> Set.Set Text -withGlobals names = Set.union (Set.fromList names) staticGlobalNames - --- | Helper: extract just token types from Located list (drop positions and EOF). -tokenTypes :: [Located] -> [Token] -tokenTypes = filter (/= TokEOF) . map locToken - --- | Helper: parse Nix source and evaluate with builtinEnv. Parse errors --- are tagged so failure assertions can tell them apart from eval errors. -evalNix :: Text -> Either Text NixValue -evalNix source = case parseNix testBaseDir "" source of - Left err -> Left (sourceFailure err) - Right expr -> runPureEval (eval (builtinEnv unrestrictedPolicy 0 []) expr) - --- | Prefix marking a parse (not eval) failure in 'evalNix' results. -parseErrorTag :: Text -parseErrorTag = "parse error: " - --- | A source failure as an 'evalNix' result: a syntax error carries --- 'parseErrorTag'; an unbound variable reads as the evaluation error --- upstream raises for it, before evaluating anything. -sourceFailure :: SourceError -> Text -sourceFailure (SyntaxError err) = parseErrorTag <> T.pack (show err) -sourceFailure (UndefinedVariable name) = undefinedVariableMessage name - --- | The syntax error a source fails to parse with. -syntaxErrorOf :: Text -> Either Text ParseError -syntaxErrorOf source = case parseNix testBaseDir "" source of - Left (SyntaxError err) -> Right err - Left other -> Left ("expected a syntax error, got " <> T.pack (show other)) - Right _ -> Left "parsed unexpectedly" - --- | Assert that a Nix expression evaluates to the expected value. -assertEval :: Text -> Text -> NixValue -> TestResult -assertEval label source expected = - assertRight label (evalNix source) $ \actual -> - assertEqual label expected actual - --- | Assert that a Nix expression parses but fails to EVALUATE. A parse --- failure fails the assertion: a test documenting a runtime error must --- not keep passing after a regression stops the construct from parsing. --- | The bytes of a string value, and nothing for any other value. -stringBytes :: NixValue -> BS.ByteString -stringBytes (VStr bytes _) = bytes -stringBytes _ = BS.empty - -assertEvalFail :: Text -> Text -> TestResult -assertEvalFail label source = case evalNix source of - Left err - | parseErrorTag `T.isPrefixOf` err -> - Fail (label <> ": expected an eval error but the source did not parse: " <> err) - | otherwise -> Pass - Right val -> Fail (label <> ": expected eval failure but got: " <> T.pack (show val)) - --- | Assert that a Nix expression parses and fails to evaluate with exactly --- the given message, for errors whose wording is upstream's. -assertEvalError :: Text -> Text -> Text -> TestResult -assertEvalError label source expected = case evalNix source of - Left err - | parseErrorTag `T.isPrefixOf` err -> - Fail (label <> ": expected an eval error but the source did not parse: " <> err) - | otherwise -> assertEqual label expected err - Right val -> Fail (label <> ": expected eval failure but got: " <> T.pack (show val)) - --- | 'assertEvalError' under the IO evaluator, which keeps a forced --- thunk's value and marks one while it is being forced, as upstream's --- evaluator does; the pure one does neither. -assertEvalErrorIO :: FilePath -> Text -> Text -> Text -> IO TestResult -assertEvalErrorIO baseDir label source expected = do - result <- evalNixIO baseDir source - pure $ case result of - Left err -> assertEqual label expected err - Right val -> Fail (label <> ": expected eval failure but got: " <> T.pack (show val)) - --- | Assert that a Nix expression fails at PARSE time. -assertParseFail :: Text -> Text -> TestResult -assertParseFail label source = case evalNix source of - Left err - | parseErrorTag `T.isPrefixOf` err -> Pass - | otherwise -> - Fail (label <> ": expected a parse error but evaluation failed instead: " <> err) - Right val -> Fail (label <> ": expected parse failure but got: " <> T.pack (show val)) - --- --------------------------------------------------------------------------- --- Shell discovery for builder tests --- --------------------------------------------------------------------------- - --- | Find a POSIX-compatible shell for builder tests. --- On Unix, always @\/bin\/sh@. On Windows, searches for @bash.exe@ --- at known Git for Windows locations first, then PATH. Checks known --- paths first to avoid picking up the WSL launcher at --- @C:\\Windows\\System32\\bash.exe@ which exits 1 when WSL is not --- configured. Real Nix builders always use bash from the store - --- this bridges the gap until nova-nix bootstraps its own bash --- derivation. -findTestShell :: IO Text -findTestShell = case SI.os of - "mingw32" -> do - let known = - [ "C:\\Program Files\\Git\\bin\\bash.exe", - "C:\\Program Files (x86)\\Git\\bin\\bash.exe" - ] - found <- filterM Dir.doesFileExist known - case found of - (p : _) -> pure (T.pack p) - [] -> do - inPath <- Dir.findExecutable "bash" - case inPath of - Just p -> pure (T.pack p) - Nothing -> - error - "bash not found: install Git for Windows or add bash to PATH" - _ -> pure "/bin/sh" - --- --------------------------------------------------------------------------- --- Tests: Expr types (existing) --- --------------------------------------------------------------------------- - -testExprTypes :: IO [Bool] -testExprTypes = do - putStrLn "expr/types" - sequence - [ runTest "int literal" $ - assertEqual "ELit NixInt" (ELit (NixInt 42)) (ELit (NixInt 42)), - runTest "bool literal" $ - assertEqual "ELit NixBool" (ELit (NixBool True)) (ELit (NixBool True)), - runTest "null literal" $ - assertEqual "ELit NixNull" (ELit NixNull) (ELit NixNull), - runTest "var" $ - assertEqual "EVar" (EVar "x") (EVar "x"), - runTest "string parts" $ - let parts = [StrLit "hello ", StrInterp (EVar "name")] - in assertEqual "EStr" (EStr parts) (EStr parts), - runTest "binary op" $ - let expr = EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2)) - in assertEqual "EBinary" expr expr, - runTest "lambda" $ - let expr = ELambda (FormalName "x") (EVar "x") NoCaptureInfo - in assertEqual "ELambda" expr expr, - runTest "let binding" $ - let expr = ELet [NamedBinding (StaticKey "x") (ELit (NixInt 1))] (EVar "x") NoCaptureInfo - in assertEqual "ELet" expr expr, - runTest "attrs" $ - let expr = EAttrs False [NamedBinding (StaticKey "a") (ELit (NixInt 1))] NoCaptureInfo - in assertEqual "EAttrs" expr expr, - runTest "if-then-else" $ - let expr = EIf (ELit (NixBool True)) (ELit (NixInt 1)) (ELit (NixInt 2)) - in assertEqual "EIf" expr expr - ] - --- --------------------------------------------------------------------------- --- Tests: Store paths (existing) --- --------------------------------------------------------------------------- - -testStorePaths :: IO [Bool] -testStorePaths = do - putStrLn "store/path" - let sp = StorePath {spHash = "s66mzxpvicwk07gjbjfw9izjfa797vsw", spName = "hello-2.12.1"} - sequence - [ runTest "default store dir" $ - assertEqual "defaultStoreDir" "/nix/store" (unStoreDir defaultStoreDir), - runTest "windows store dir" $ - assertEqual "windowsStoreDir" "C:\\nix\\store" (unStoreDir windowsStoreDir), - runTest "store path to text" $ - assertEqual - "storePathToText" - "/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1" - (T.unpack (storePathToText defaultStoreDir sp)), - runTest "store path ordering" $ - let sp2 = StorePath {spHash = "zzz", spName = "later"} - in assertEqual "Ord" True (sp < sp2), - -- The reader-side mapping: canonical store text resolves into the - -- store dir it is given; everything else is the path as written. - runTest "store text maps into the platform store dir" $ - assertEqual - "mapped" - (unStoreDir platformStoreDir <> "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x/sub/f") - (storeTextToFilePath platformStoreDir "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x/sub/f"), - runTest "bare store dir text maps to the platform store root" $ - assertEqual "mapped-root" (unStoreDir platformStoreDir) (storeTextToFilePath platformStoreDir "/nix/store"), - runTest "store text with a backslash subpath maps" $ - assertEqual - "mapped-backslash" - (unStoreDir platformStoreDir <> "\\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-y") - (storeTextToFilePath platformStoreDir "/nix/store\\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-y"), - runTest "non-store text is the path as written" $ - assertEqual "unmapped" "/etc/hosts" (storeTextToFilePath platformStoreDir "/etc/hosts"), - runTest "a store-prefix-like name does not map" $ - assertEqual "unmapped-like" "/nix/storefoo" (storeTextToFilePath platformStoreDir "/nix/storefoo"), - -- The reason this takes a store dir at all: a caller given one must - -- read from it, not from the platform default. - runTest "store text maps into a redirected store dir" $ - assertEqual - "redirected" - "/tmp/scratch-store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x" - (storeTextToFilePath (StoreDir "/tmp/scratch-store") "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x"), - -- Both sides must land in the SAME store dir. Not the same string: - -- storePathToFilePath joins with the native separator while - -- storeTextToFilePath passes the canonical text's tail through, so - -- the two spellings differ on Windows and open the same file. - runTest "a redirected read lands in the same store as the write" $ - let redirected = StoreDir "/tmp/scratch-store" - redirectedPath = StorePath {spHash = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", spName = "x"} - readSide = storeTextToFilePath redirected (storePathToText defaultStoreDir redirectedPath) - writeSide = storePathToFilePath redirected redirectedPath - underRedirected p = unStoreDir redirected `isPrefixOf` p - in assertEqual - "both under the redirected store" - (True, True, False) - (underRedirected readSide, underRedirected writeSide, unStoreDir platformStoreDir `isPrefixOf` readSide), - runTest "isCanonicalStoreText accepts both separators and rejects lookalikes" $ - assertEqual - "predicate" - [True, True, True, False, False] - ( map - isCanonicalStoreText - ["/nix/store", "/nix/store/x", "/nix/store\\x", "/nix/storefoo", "C:\\nix\\store\\x"] - ), - runTestM "compressHash XORs byte i into position i mod the length" $ do - result <- - QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ - QC.forAll genCompressCase $ \(len, bytes) -> - BS.unpack (compressHash len (BS.pack bytes)) QC.=== compressHashModel len bytes - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - ] - where - -- Lengths on both sides of the input's, so the last chunk is short, - -- whole or absent, and below one, where there is nothing to fold into. - genCompressCase = (,) <$> QC.choose (-1, 40) <*> QC.resize 70 (QC.listOf QC.arbitrary) - --- | Upstream's @compressHash@ loop (hash.cc), one byte at a time. -compressHashModel :: Int -> [Word8] -> [Word8] -compressHashModel len bytes = - [foldl' xor 0 [b | (i, b) <- zip [0 :: Int ..] bytes, i `mod` len == j] | j <- [0 .. len - 1]] - --- --------------------------------------------------------------------------- --- Tests: Derivation (existing) --- --------------------------------------------------------------------------- - -testDerivation :: IO [Bool] -testDerivation = do - putStrLn "derivation" - sequence - [ runTest "current platform is known" $ - case currentPlatform of - OtherPlatform _ -> Fail "currentPlatform returned OtherPlatform" - _ -> Pass - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Literals --- --------------------------------------------------------------------------- - -testEvalLiterals :: IO [Bool] -testEvalLiterals = do - putStrLn "eval/literals" - sequence - [ runTest "empty env" $ - assertEqual "emptyEnv" emptyEnv emptyEnv, - runTest "int" $ - assertEval "int" "42" (VInt 42), - runTest "float" $ - assertEval "float" "3.14" (VFloat 3.14), - runTest "bool true" $ - assertEval "true" "true" (VBool True), - runTest "null" $ - assertEval "null" "null" VNull, - runTest "string" $ - assertEval "string" "\"hello\"" (mkStr "hello") - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Variables --- --------------------------------------------------------------------------- - -testEvalVariables :: IO [Bool] -testEvalVariables = do - putStrLn "eval/variables" - sequence - [ runTest "let variable" $ - assertEval "let-var" "let x = 1; in x" (VInt 1), - runTest "undefined variable" $ - assertEvalFail "undef" "x", - runTest "builtin true" $ - assertEval "builtin-true" "true" (VBool True) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Arithmetic --- --------------------------------------------------------------------------- - -testEvalArithmetic :: IO [Bool] -testEvalArithmetic = do - putStrLn "eval/arithmetic" - sequence - [ runTest "int add" $ - assertEval "add" "1 + 2" (VInt 3), - runTest "int sub" $ - assertEval "sub" "10 - 3" (VInt 7), - runTest "int mul" $ - assertEval "mul" "4 * 5" (VInt 20), - runTest "int div" $ - assertEval "div" "10 / 3" (VInt 3), - runTest "float add" $ - assertEval "float-add" "1.5 + 2.5" (VFloat 4.0), - -- Integer overflow is an eval error, never a two's-complement wrap; - -- the boundary itself still computes. The messages are upstream's - -- from 2.25 on, as nix-instantiate 2.33.2 prints them (2.24.9 leaves - -- overflow to undefined C++ signed arithmetic), except division's, - -- which 2.24.9 checks itself and 2.25 rewords. - runTest "add overflow fails" $ - assertEvalError "add-overflow" "9223372036854775807 + 1" "integer overflow in adding 9223372036854775807 + 1", - runTest "sub overflow fails" $ - assertEvalError "sub-overflow" "(-9223372036854775807) - 2" "integer overflow in subtracting -9223372036854775807 - 2", - runTest "mul overflow fails" $ - assertEvalError "mul-overflow" "builtins.mul 9223372036854775807 2" "integer overflow in multiplying 9223372036854775807 * 2", - runTest "div minBound by -1 overflows" $ - assertEvalError "div-overflow" "((-9223372036854775807) - 1) / (-1)" "overflow in integer division", - runTest "builtins.div minBound by -1 overflows" $ - assertEvalError "builtin-div-overflow" "builtins.div ((-9223372036854775807) - 1) (-1)" "overflow in integer division", - runTest "negate minBound overflows as 0 - n" $ - assertEvalError "neg-overflow" "-((-9223372036854775807) - 1)" "integer overflow in subtracting 0 - -9223372036854775808", - -- Unary minus is __sub 0 e upstream (parser.y at 2.24.9). - runTest "negating a float zero gives positive zero" $ - assertEval "neg-zero" "builtins.toJSON [ (-(0.0)) (-(-0.0)) ]" (mkStr "[0.0,0.0]"), - runTest "negating a non-number fails as builtins.sub does" $ - assertEvalError "neg-set" "-{ }" "expected an integer but found a set: { }", - -- -, *, / and the arithmetic builtins are upstream's prim_sub, - -- prim_mul, prim_div and prim_add (primops.cc at 2.24.9): forceInt - -- on both operands, or forceFloat on both once either is a float. - runTest "subtracting a set from an integer fails its forceInt" $ - assertEvalError "sub-set" "1 - {}" "expected an integer but found a set: { }", - runTest "subtracting from a set fails on the left operand" $ - assertEvalError "set-sub" "{} - 1" "expected an integer but found a set: { }", - runTest "subtracting a set from a float fails its forceFloat" $ - assertEvalError "float-sub-set" "1.0 - {}" "expected a float but found a set: { }", - runTest "two non-numbers fail on the left one" $ - assertEvalError "set-sub-str" "{} - \"a\"" "expected an integer but found a set: { }", - runTest "multiplying a float by a string fails its forceFloat" $ - assertEvalError "float-mul-str" "2.5 * \"a\"" "expected a float but found a string: \"a\"", - runTest "dividing by a set fails the divisor's forceFloat" $ - assertEvalError "div-set" "1 / {}" "expected a float but found a set: { }", - runTest "dividing a set by an integer fails its forceInt" $ - assertEvalError "set-div" "{} / 1" "expected an integer but found a set: { }", - runTest "a zero divisor is refused before the dividend is checked" $ - assertEvalError "set-div-zero" "{} / 0" "division by zero", - runTest "a non-number divisor is refused before the dividend" $ - assertEvalError "set-div-str" "{} / \"a\"" "expected a float but found a string: \"a\"", - runTest "dividing by negative zero is a division by zero" $ - assertEvalError "div-neg-zero" "1 / (-0.0)" "division by zero", - runTest "builtins.div by zero says only division by zero" $ - assertEvalError "builtin-div-zero" "builtins.div 1 0" "division by zero", - runTest "builtins.add refuses a string through forceInt" $ - assertEvalError "builtin-add-str" "builtins.add \"a\" 1" "expected an integer but found a string: \"a\"", - runTest "builtins.add with a float refuses a string through forceFloat" $ - assertEvalError "builtin-add-float-str" "builtins.add 1.5 \"a\"" "expected a float but found a string: \"a\"", - runTest "builtins.sub refuses a set" $ - assertEvalError "builtin-sub-set" "builtins.sub 1 {}" "expected an integer but found a set: { }", - runTest "builtins.bitXor refuses a float" $ - assertEvalError "bitxor-float" "builtins.bitXor 1 1.0" "expected an integer but found a float: 1", - runTest "builtins.bitAnd fails on its left operand first" $ - assertEvalError "bitand-set-str" "builtins.bitAnd {} \"a\"" "expected an integer but found a set: { }", - runTest "builtins.bitOr refuses a set" $ - assertEvalError "bitor-set" "builtins.bitOr {} 1" "expected an integer but found a set: { }", - runTest "float division still divides" $ - assertEval "float-div" "1 / 4.0" (VFloat 0.25), - runTest "add at the boundary still works" $ - assertEval "add-boundary" "9223372036854775806 + 1 == 9223372036854775807" (VBool True), - runTest "int-float promotion" $ - assertEval "promote" "1 + 2.0" (VFloat 3.0), - runTest "trailing-dot float" $ - assertEval "trailing-dot" "12. == 12.0" (VBool True), - runTest "trailing-dot float with exponent" $ - assertEval "trailing-dot-exp" "12.e2 == 1200.0" (VBool True), - runTest "trailing-dot float typeOf" $ - assertEval "trailing-dot-type" "builtins.typeOf 12." (mkStr "float"), - runTest "negate int" $ - assertEval "negate" "- 5" (VInt (-5)), - runTest "division by zero" $ - assertEvalFail "div0" "1 / 0", - runTest "absolute path lexes as path, not division" $ - assertEval "path-abs" "builtins.typeOf /abs/path" (mkStr "path"), - runTest "bareword relative path lexes as path" $ - assertEval "path-rel" "builtins.typeOf foo/bar" (mkStr "path"), - runTest "function applied to an absolute path argument" $ - assertEval "app-abs-path" "(p: builtins.typeOf p) /abs/path" (mkStr "path") - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Comparison --- --------------------------------------------------------------------------- - -testEvalComparison :: IO [Bool] -testEvalComparison = do - putStrLn "eval/comparison" - sequence - [ runTest "int eq" $ - assertEval "eq" "1 == 1" (VBool True), - runTest "int neq" $ - assertEval "neq" "1 != 2" (VBool True), - runTest "int lt" $ - assertEval "lt" "1 < 2" (VBool True), - runTest "int gte" $ - assertEval "gte" "3 >= 3" (VBool True), - runTest "string compare" $ - assertEval "str-lt" "\"abc\" < \"def\"" (VBool True), - -- <= and >= are negated swapped <, so NaN compares as upstream: - -- nan <= x and nan >= x are true while nan < x and nan == nan are - -- false ((1.0e308 * 10) * 0.0 is inf * 0.0, i.e. nan). - runTest "nan lte is true" $ - assertEval "nan-lte" "let nan = (1.0e308 * 10) * 0.0; in nan <= 1.0" (VBool True), - runTest "nan gte is true" $ - assertEval "nan-gte" "let nan = (1.0e308 * 10) * 0.0; in nan >= 1.0" (VBool True), - runTest "nan lt is false" $ - assertEval "nan-lt" "let nan = (1.0e308 * 10) * 0.0; in nan < 1.0" (VBool False), - runTest "nan self-equality is false" $ - assertEval "nan-eq" "let nan = (1.0e308 * 10) * 0.0; in nan == nan" (VBool False), - runTest "lte on equal lists" $ - assertEval "list-lte-eq" "[ 1 2 ] <= [ 1 2 ]" (VBool True), - runTest "lte incomparable types fails" $ - assertEvalFail "lte-err" "1 <= \"a\"", - -- Upstream's CompareValues (primops.cc at 2.24.9); > and <= swap - -- the operands as the parser's desugaring to __lessThan does. - runTest "comparing different types names both" $ - assertEvalError "lt-int-set" "1 < {}" "cannot compare an integer with a set", - runTest "gt compares the swapped operands" $ - assertEvalError "gt-int-set" "1 > {}" "cannot compare a set with an integer", - runTest "lte compares the swapped operands" $ - assertEvalError "lte-int-set" "1 <= {}" "cannot compare a set with an integer", - runTest "gte compares the operands in order" $ - assertEvalError "gte-int-set" "1 >= {}" "cannot compare an integer with a set", - runTest "Booleans are incomparable" $ - assertEvalError "lt-bool" "true < false" "cannot compare a Boolean with a Boolean; values of that type are incomparable", - runTest "a lambda and a primop are both functions, so incomparable" $ - assertEvalError "lt-fn" "(x: x) < builtins.map" "cannot compare a function with the built-in function 'map'; values of that type are incomparable", - runTest "builtins.lessThan on nulls is incomparable" $ - assertEvalError "lessthan-null" "builtins.lessThan null null" "cannot compare null with null; values of that type are incomparable", - runTest "list comparison reports the first unequal pair" $ - assertEvalError "lt-list" "[ 1 ] < [ \"a\" ]" "cannot compare an integer with a string", - runTest "equal incomparable elements do not stop a list comparison" $ - assertEval "lt-list-sets" "[ {} ] < [ {} ]" (VBool False) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Logic --- --------------------------------------------------------------------------- - -testEvalLogic :: IO [Bool] -testEvalLogic = do - putStrLn "eval/logic" - sequence - [ runTest "and true" $ - assertEval "and-true" "true && true" (VBool True), - runTest "and short-circuit" $ - assertEval "and-short" "false && true" (VBool False), - runTest "or true" $ - assertEval "or-true" "true || false" (VBool True), - runTest "or short-circuit" $ - assertEval "or-short" "false || true" (VBool True), - runTest "not" $ - assertEval "not" "!false" (VBool True), - runTest "implication false->x" $ - assertEval "impl-false" "false -> false" (VBool True), - runTest "implication true->true" $ - assertEval "impl-true" "true -> true" (VBool True) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Strings --- --------------------------------------------------------------------------- - -testEvalStrings :: IO [Bool] -testEvalStrings = do - putStrLn "eval/strings" - sequence - [ runTest "string concat" $ - assertEval "concat" "\"hello\" + \" world\"" (mkStr "hello world"), - runTest "string interpolation" $ - assertEval "interp" "let x = \"world\"; in \"hello ${x}\"" (mkStr "hello world"), - runTest "interpolation coerce int" $ - assertEval "coerce-int" "\"val=${builtins.toString 42}\"" (mkStr "val=42"), - runTest "empty string" $ - assertEval "empty" "\"\"" (mkStr "") - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - If/Assert --- --------------------------------------------------------------------------- - -testEvalIfAssert :: IO [Bool] -testEvalIfAssert = do - putStrLn "eval/if-assert" - sequence - [ runTest "if true" $ - assertEval "if-true" "if true then 1 else 2" (VInt 1), - runTest "if false" $ - assertEval "if-false" "if false then 1 else 2" (VInt 2), - runTest "assert pass" $ - assertEval "assert-pass" "assert true; 42" (VInt 42), - runTest "assert fail" $ - assertEvalFail "assert-fail" "assert false; 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Let --- --------------------------------------------------------------------------- - -testEvalLet :: IO [Bool] -testEvalLet = do - putStrLn "eval/let" - sequence - [ runTest "simple let" $ - assertEval "let" "let x = 1; in x" (VInt 1), - runTest "multi let" $ - assertEval "multi" "let x = 1; y = 2; in x + y" (VInt 3), - runTest "recursive let" $ - assertEval "rec-let" "let x = 1; y = x + 1; in y" (VInt 2) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Attribute sets --- --------------------------------------------------------------------------- - -testEvalAttrs :: IO [Bool] -testEvalAttrs = do - putStrLn "eval/attrs" - sequence - [ runTest "simple select" $ - assertEval "select" "{ a = 1; }.a" (VInt 1), - runTest "nested select" $ - assertEval "nested" "{ a = { b = 2; }; }.a.b" (VInt 2), - runTest "select or default" $ - assertEval "default" "{ a = 1; }.b or 42" (VInt 42), - runTest "has-attr true" $ - assertEval "has-true" "{ a = 1; } ? a" (VBool True), - runTest "has-attr false" $ - assertEval "has-false" "{ a = 1; } ? b" (VBool False), - runTest "nested attr path" $ - assertEval "dot-path" "{ a.b.c = 1; }.a.b.c" (VInt 1), - -- A non-set operand of // fails with upstream's evalAttrs message - -- (eval.cc at 2.24.9), checked against nix-instantiate 2.33.2's - -- final error line. tryEval does not catch it. - runTest "update with a null left operand" $ - assertEvalError "update-null-left" "null // {}" "expected a set but found null: null", - runTest "update with a null right operand" $ - assertEvalError "update-null-right" "{} // null" "expected a set but found null: null", - runTest "update with an integer left operand" $ - assertEvalError "update-int-left" "1 // {}" "expected a set but found an integer: 1", - runTest "update with a string right operand" $ - assertEvalError "update-string-right" "{} // \"x\"" "expected a set but found a string: \"x\"", - -- 2.24.9's ExprOpUpdate::eval evaluates and checks the left operand - -- before it evaluates the right; 2.33.2 does the right first. - runTest "update with two non-set operands reports the left" $ - assertEvalError "update-both" "1 // \"x\"" "expected a set but found an integer: 1", - runTest "update refuses a non-set left before evaluating the right" $ - assertEvalError "update-left-first" "builtins.tryEval (null // throw \"b\")" "expected a set but found null: null", - runTest "update with a set left evaluates a throwing right" $ - assertEval "update-right-throws" "(builtins.tryEval ({} // throw \"b\")).success" (VBool False), - runTest "update evaluates a throwing left first" $ - assertEvalError "update-left-throws" "throw \"a\" // null" "a", - -- builtins.warn forces its message with forceString (prim_warn, - -- primops.cc at 2.24.9); final lines as nix-instantiate 2.33.2 - -- prints them, and tryEval does not catch the refusal. - runTest "warn refuses an integer message" $ - assertEvalError "warn-int" "builtins.warn 1 2" "expected a string but found an integer: 1", - runTest "warn refuses a Boolean message" $ - assertEvalError "warn-bool" "builtins.warn true 2" "expected a string but found a Boolean: true", - runTest "warn refuses a null message" $ - assertEvalError "warn-null" "builtins.warn null 2" "expected a string but found null: null", - runTest "warn refuses a float message" $ - assertEvalError "warn-float" "builtins.warn 1.5 2" "expected a string but found a float: 1.5", - runTest "warn's refusal is not caught by tryEval" $ - assertEvalError "warn-tryeval" "builtins.tryEval (builtins.warn 1 2)" "expected a string but found an integer: 1", - runTest "warn with a string message returns its value" $ - assertEval "warn-string" "builtins.warn \"m\" 2" (VInt 2), - runTest "tryEval does not catch the update error" $ - assertEvalError "update-tryEval" "builtins.tryEval (null // {})" "expected a set but found null: null" - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Value printer --- --------------------------------------------------------------------------- - -testValuePrinter :: IO [Bool] -testValuePrinter = do - putStrLn "eval/print" - tmpBase <- getTemporaryDirectory - let stringFound body = "expected a set but found a string: " <> body - setFound body = "cannot coerce a set to a string: " <> body - listFound body = "cannot coerce a list to a string: " <> body - runOfA n = "builtins.concatStringsSep \"\" (builtins.genList (x: \"a\") " <> T.pack (show (n :: Int)) <> ")" - elided what = " \x00AB" <> what <> " elided\x00BB" - marker inner = "\x00AB" <> inner <> "\x00BB" - interpolated source = "\"${" <> source <> "}\"" - deeplyForced source = "let x = " <> source <> "; in builtins.seq (builtins.deepSeq x null) \"${x}\"" - ints n = map (T.pack . show) [1 .. n :: Int] - listOfInts n = "[ " <> T.concat (map (<> " ") (ints n)) <> "]" - attrsOfInts n = "{ " <> T.concat [name <> " = " <> value <> "; " | (name, value) <- zip letters (ints n)] <> "}" - letters = map T.singleton ['a' ..] - shownInts = T.unwords [name <> " = " <> value <> ";" | (name, value) <- zip letters (ints 10)] - paddedName i = T.pack ('a' : if i < 10 then '0' : show i else show i) - paddedAttrs n = "{ " <> T.concat [paddedName i <> " = " <> T.pack (show i) <> "; " | i <- [1 .. n]] <> "}" - boundedList n = bounded "[" "]" (ints (min n 10)) (n - 10) "item" "items" - boundedAttrs n = - bounded "{" "}" [paddedName i <> " = " <> T.pack (show i) <> ";" | i <- [1 .. min n 10]] (n - 10) "attribute" "attributes" - bounded open close shown left single plural = - open <> " " <> T.concat (map (<> " ") shown) <> leftOut left single plural <> close - leftOut left single plural - | left <= 0 = "" - | left == 1 = marker ("1 " <> single <> " elided") <> " " - | otherwise = marker (T.pack (show left) <> " " <> plural <> " elided") <> " " - quickCheckPasses property = do - result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - sequence - [ -- Values print as upstream's printValue prints them under - -- errorPrintOptions (print.cc and print-options.hh at 2.24.9), each - -- checked against nix-instantiate 2.33.2's final error line. - runTest "a path prints bare" $ - assertEvalError "print-path" "{} // /foo/bar" "expected a set but found a path: /foo/bar", - runTest "a float prints with six significant digits" $ - assertEvalError "print-float" "{} // 1234567.0" "expected a set but found a float: 1.23457e+06", - runTest "a string prints quoted with the lexer's escapes" $ - assertEvalError - "print-escapes" - "{} // \"a\\nb\\\"c$d\\${e}\\t\\r\"" - (stringFound "\"a\\nb\\\"c$d\\${e}\\t\\r\""), - runTest "a string of 1024 bytes prints whole" $ - assertEvalError - "print-1024" - ("{} // " <> runOfA 1024) - (stringFound ("\"" <> T.replicate 1024 "a" <> "\"")), - runTest "a longer string is cut after 1024 bytes" $ - assertEvalError - "print-1025" - ("{} // " <> runOfA 1025) - (stringFound ("\"" <> T.replicate 1024 "a" <> "\"" <> elided "1 byte")), - runTest "the bytes cut are counted" $ - assertEvalError - "print-1100" - ("{} // " <> runOfA 1100) - (stringFound ("\"" <> T.replicate 1024 "a" <> "\"" <> elided "76 bytes")), - runTest "a dollar shown last is escaped when the brace after it was cut" $ - assertEvalError - "print-cut-dollar" - ("{} // (" <> runOfA 1023 <> " + \"\\${\")") - (stringFound ("\"" <> T.replicate 1023 "a" <> "\\$\"" <> elided "1 byte")), - -- A set or list prints its entries, nothing forced, and is cut - -- once the print has shown ten attributes or ten items in all. - runTest "a set prints its attributes by name" $ - assertEvalError "print-set" "\"${{ b = \"s\"; a = 1; }}\"" (setFound "{ a = 1; b = \"s\"; }"), - runTest "an empty set prints as a pair of braces" $ - assertEvalError "print-empty-set" "\"${{}}\"" (setFound "{ }"), - runTest "_type and type print ahead of the other attributes" $ - assertEvalError - "print-important-first" - "\"${{ z = 1; type = 2; _type = 3; a = 4; }}\"" - (setFound "{ _type = 3; type = 2; a = 4; z = 1; }"), - runTest "an attribute name the lexer cannot read bare prints quoted" $ - assertEvalError - "print-quoted-names" - "\"${{ \"a b\" = 1; \"if\" = 2; \"\" = 3; }}\"" - (setFound "{ \"\" = 3; \"a b\" = 1; \"if\" = 2; }"), - runTest "an attribute never forced prints as upstream's thunk marker" $ - assertEvalError "print-thunk" "\"${{ a = 1 + 1; }}\"" (setFound ("{ a = " <> marker "thunk" <> "; }")), - runTest "an eleventh attribute is counted, not shown" $ - assertEvalError - "print-11-attrs" - (interpolated (attrsOfInts 11)) - (setFound ("{ " <> shownInts <> " " <> marker "1 attribute elided" <> " }")), - runTest "attributes past the tenth are counted together" $ - assertEvalError - "print-12-attrs" - (interpolated (attrsOfInts 12)) - (setFound ("{ " <> shownInts <> " " <> marker "2 attributes elided" <> " }")), - runTest "an empty list prints as a pair of brackets" $ - assertEvalError "print-empty-list" "\"${[ ]}\"" (listFound "[ ]"), - runTest "an eleventh item is counted, not shown" $ - assertEvalError - "print-11-items" - (interpolated (listOfInts 11)) - (listFound ("[ 1 2 3 4 5 6 7 8 9 10 " <> marker "1 item elided" <> " ]")), - runTest "items past the tenth are counted together" $ - assertEvalError - "print-12-items" - (interpolated (listOfInts 12)) - (listFound ("[ 1 2 3 4 5 6 7 8 9 10 " <> marker "2 items elided" <> " ]")), - runTestM "a list shows ten items and counts the rest" $ - quickCheckPasses $ - QC.forAll (QC.chooseInt (0, 25)) $ \n -> - evalNix (interpolated (listOfInts n)) QC.=== Left (listFound (boundedList n)), - runTestM "a set shows ten attributes and counts the rest" $ - quickCheckPasses $ - QC.forAll (QC.chooseInt (0, 25)) $ \n -> - evalNix (interpolated (paddedAttrs n)) QC.=== Left (setFound (boundedAttrs n)), - -- Forced values need the IO evaluator, which keeps them. - runTestM "a nested set's attributes count before the attribute holding it" $ - assertEvalErrorIO - tmpBase - "print-nested-count" - (deeplyForced "{ a = { b = 1; c = 2; d = 3; e = 4; f = 5; g = 6; }; h = 7; i = 8; j = 9; k = 10; l = 11; }") - (setFound ("{ a = { b = 1; c = 2; d = 3; e = 4; f = 5; g = 6; }; h = 7; i = 8; j = 9; " <> marker "2 attributes elided" <> " }")), - runTestM "list items count over the whole print" $ - assertEvalErrorIO - tmpBase - "print-items-across-lists" - (deeplyForced "{ a = [ 1 2 3 4 5 6 7 8 9 ]; b = [ 10 11 12 ]; }") - (setFound ("{ a = [ 1 2 3 4 5 6 7 8 9 ]; b = [ 10 " <> marker "2 items elided" <> " ]; }")), - runTestM "a set nested ten deep prints as an ellipsis" $ - assertEvalErrorIO - tmpBase - "print-deep-set" - (deeplyForced (T.replicate 12 "{ a = " <> "1" <> T.replicate 12 "; }")) - (setFound (T.replicate 10 "{ a = " <> "{ ... }" <> T.replicate 10 "; }")), - runTestM "a list nested ten deep prints as an ellipsis" $ - assertEvalErrorIO - tmpBase - "print-deep-list" - (deeplyForced (T.replicate 12 "[ " <> "1" <> T.replicate 12 " ]")) - (listFound (T.replicate 10 "[ " <> "[ ... ]" <> T.replicate 10 " ]")), - runTestM "an attribute being forced prints as upstream's recursion marker" $ - assertEvalErrorIO - tmpBase - "print-blackhole" - "let x = { a = \"${x}\"; }; in x.a" - (setFound ("{ a = " <> marker "potential infinite recursion" <> "; }")), - runTest "a primop prints as upstream's primop marker" $ - assertEvalError - "print-primop" - "{} // builtins.map" - ("expected a set but found the built-in function 'map': " <> marker "primop map"), - runTest "a partially applied primop prints as upstream's marker" $ - assertEvalError - "print-primop-app" - "{} // builtins.map (x: x)" - ("expected a set but found the partially applied built-in function 'map': " <> marker "partially applied primop map"), - -- builtins.trace's defaults bound nothing and sort only by name. - runTest "a set prints in full by name as trace prints it" - $ assertRight "print-full-set" (evalNix "{ type = 1; a = 2; }") - $ assertEqual "print-full-set" "{ a = 2; type = 1; }" . printValue PrintInFull, - runTest "a long list prints in full as trace prints it" - $ assertRight "print-full-list" (evalNix (listOfInts 12)) - $ assertEqual "print-full-list" "[ 1 2 3 4 5 6 7 8 9 10 11 12 ]" . printValue PrintInFull, - -- builtins.trace prints a non-string through the same printer with - -- upstream's default options. - runTest "a float prints in full as trace prints it" $ - assertEqual "print-full-float" "1.23457e+06" (printValue PrintInFull (VFloat 1234567.0)), - runTestM "a string printed in full reads back as itself" $ do - result <- - QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ - QC.forAll genEscapable $ \text -> - evalNix (printValue PrintInFull (mkStr text)) QC.=== Right (mkStr text) - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - ] - --- | Text built from what the string printer escapes (quotes, backslashes, --- the escaped control characters, a dollar before a brace) among plain and --- multi-byte characters. @${@ is a piece of its own so the escape that --- needs lookahead comes up often. -genEscapable :: QC.Gen Text -genEscapable = - T.concat <$> QC.listOf (QC.elements ["\"", "\\", "\n", "\r", "\t", "$", "{", "}", "${", "a", " ", "\233", "\128512"]) - --- --------------------------------------------------------------------------- --- Tests: Eval - + and string coercion errors --- --------------------------------------------------------------------------- - --- | @+@ and string coercion fail with upstream's messages, those of --- @ExprConcatStrings::eval@ and @coerceToString@ (eval.cc at 2.24.9): the --- type as @showType@ names it, and after a failed coercion the value as --- @errorPrintOptions@ prints it. Each expected message is nix-instantiate --- 2.33.2's final error line for the same expression. -testCoercionErrors :: IO [Bool] -testCoercionErrors = do - putStrLn "eval/coercion" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-coercion" - setup = createDirectoryIfMissing True (testDir "d") - cleanup = do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - withContext = "\"${builtins.toFile \"a\" \"b\"}\"" - primopMarker = "\x00ABprimop map\x00BB" - failsIO label source expected = runTestM label (assertEvalErrorIO testDir label source expected) - bracket_ setup cleanup . sequence $ - [ -- An integer or float on the left makes + arithmetic, and a right - -- operand that is no number is named. - runTest "an integer plus a string cannot be added" $ - assertEvalError "add-int-string" "1 + \"a\"" "cannot add a string to an integer", - runTest "a float plus a string cannot be added" $ - assertEvalError "add-float-string" "1.0 + \"a\"" "cannot add a string to a float", - runTest "an integer plus null cannot be added" $ - assertEvalError "add-int-null" "1 + null" "cannot add null to an integer", - failsIO "an integer plus a string with context names the context" ("1 + " <> withContext) "cannot add a string with context to an integer", - runTest "an integer plus a primop names the primop" $ - assertEvalError "add-int-primop" "1 + builtins.map" "cannot add the built-in function 'map' to an integer", - runTest "an integer plus a partial application names its primop" $ - assertEvalError - "add-int-primop-app" - "1 + builtins.map (x: x)" - "cannot add the partially applied built-in function 'map' to an integer", - -- Anything else on the left makes + concatenation, each operand - -- coerced as interpolation coerces it. - runTest "a primop on the left does not coerce" $ - assertEvalError "add-primop-int" "builtins.map + 1" ("cannot coerce the built-in function 'map' to a string: " <> primopMarker), - failsIO "a string with context plus an integer refuses the integer" (withContext <> " + 1") "cannot coerce an integer to a string: 1", - runTest "a Boolean on the left fails to coerce rather than to add" $ - assertEvalError "add-bool-int" "true + 1" "cannot coerce a Boolean to a string: true", - runTest "a string plus a float refuses the float" $ - assertEvalError "add-string-float" "\"a\" + 1.5" "cannot coerce a float to a string: 1.5", - runTest "a string plus a list refuses the list" $ - assertEvalError "add-string-list" "\"a\" + [ ]" "cannot coerce a list to a string: [ ]", - runTest "a path plus an integer refuses the integer" $ - assertEvalError "add-path-int" "./d + 1" "cannot coerce an integer to a string: 1", - failsIO - "a path plus a string with context is refused" - ("./d + " <> withContext) - "a string that refers to a store path cannot be appended to a path", - -- The left operand is dealt with before the right is evaluated. - runTest "a set on the left fails before the right is evaluated" $ - assertEvalError "add-left-first" "{} + throw \"b\"" "cannot coerce a set to a string: { }", - runTest "tryEval does not catch a failed coercion" $ - assertEvalError "add-tryEval" "builtins.tryEval ({} + throw \"b\")" "cannot coerce a set to a string: { }", - -- Upstream copies a path into the store only when the left operand - -- is a string, so a set's outPath on the left is its own text. - runTestM "a set on the left contributes its path without a store copy" $ do - result <- evalNixIO testDir "let s = { outPath = ./d; } + \"x\"; in builtins.getContext s == {} && s == toString ./d + \"x\"" - pure (assertRight "add-set-path" result (assertEqual "add-set-path" (VBool True))), - -- Interpolation, toString and concatStringsSep coerce the same way. - runTest "an interpolated set without outPath prints the set" $ - assertEvalError "interp-set" "\"${{ a = 1; b = \"s\"; }}\"" "cannot coerce a set to a string: { a = 1; b = \"s\"; }", - runTest "an interpolated integer is refused" $ - assertEvalError "interp-int" "\"v${1}\"" "cannot coerce an integer to a string: 1", - runTest "toString of a primop is refused" $ - assertEvalError "tostring-primop" "builtins.toString builtins.map" ("cannot coerce the built-in function 'map' to a string: " <> primopMarker), - runTest "toString of a partial application is refused" $ - assertEvalError - "tostring-primop-app" - "builtins.toString (builtins.map (x: x))" - "cannot coerce the partially applied built-in function 'map' to a string: \x00ABpartially applied primop map\x00BB", - -- Upstream prints a lambda's source position after the word, which - -- a nova-nix function value does not carry. - runTest "toString of a lambda is refused" $ - assertEvalError "tostring-lambda" "builtins.toString (x: x)" "cannot coerce a function to a string: \x00ABlambda\x00BB", - runTest "toString of a set without outPath is refused" $ - assertEvalError "tostring-set" "builtins.toString { }" "cannot coerce a set to a string: { }", - runTest "concatStringsSep refuses an integer element" $ - assertEvalError "concatsep-int" "builtins.concatStringsSep \",\" [ 1 ]" "cannot coerce an integer to a string: 1", - -- An interpolated path literal concatenates as + does with a path - -- first, and refuses a context only after every piece coerced. - runTest "a path segment refuses a set" $ - assertEvalError "path-segment-set" "./a${{}}" "cannot coerce a set to a string: { }", - failsIO - "a later path segment that fails to coerce is reported over an earlier one's context" - ("./a${" <> withContext <> "}${1}") - "cannot coerce an integer to a string: 1", - -- A selection path names the type it cannot index as showType does - -- (attr-path.cc at 2.24.9). - runTest "a selection path through a function names it" $ - assertRight "attrpath-functions" (evalNix "{ a = builtins.map; b = builtins.map (x: x); c = x: x; }") $ \root -> - assertEqual - "attrpath-functions" - ( Right - [ Left "the expression selected by the selection path 'a.x' should be a set but is the built-in function 'map'", - Left "the expression selected by the selection path 'b.x' should be a set but is the partially applied built-in function 'map'", - Left "the expression selected by the selection path 'c.x' should be a set but is a function" - ] - ) - (runPureEval (mapM (`selectAttrPath` root) ["a.x", "b.x", "c.x"])) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Result printer --- --------------------------------------------------------------------------- - --- | What @nova-nix eval@ prints for a value. Each expected value is the --- output of @nix-instantiate --eval --readonly-mode -E@ (Nix 2.33.2) for --- the same expression, less the newline the command writes after it. -testResultPrinter :: IO [Bool] -testResultPrinter = do - putStrLn "eval/print-result" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-print-result" - notUtf8 = "a" <> BS.singleton 0xfc <> "b" - setup = do - createDirectoryIfMissing True testDir - BS.writeFile (testDir "latin1") notUtf8 - cleanup = do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - printsIO label source expected = runTestM label $ do - result <- evalNixIO testDir source - pure (assertRight label result (assertEqual label expected . renderResult)) - prints label source expected = - runTest label (assertRight label (evalNix source) (assertEqual label expected . renderResult)) - floatPrints (source, expected) = - prints ("a float prints in ostream form: " <> source) source expected - bracket_ setup cleanup . sequence $ - [ printsIO - "a string prints its bytes, not U+FFFD for one that is not UTF-8" - "builtins.readFile ./latin1" - ("\"" <> notUtf8 <> "\""), - prints - "a string escapes each of upstream's characters and a dollar before a brace" - "\"\\\" \\\\ \\n \\r \\t \\${ $\"" - "\"\\\" \\\\ \\n \\r \\t \\${ $\"", - prints "a lone dollar prints as it is" "\"$\"" "\"$\"", - prints - "an attribute name past ASCII prints quoted, as its bytes" - "{ \"\233\" = 1; }" - ("{ \"" <> BS.pack [0xc3, 0xa9] <> "\" = 1; }"), - prints - "an attribute name the lexer cannot read bare prints quoted" - "{ \"a b\" = 1; \"if\" = 2; \"\" = 3; \"1x\" = 4; or = 5; \"a-b'\" = 6; _x = 7; \"-a\" = 8; \"'a\" = 9; \"x\\\"y\" = 10; }" - "{ \"\" = 3; \"'a\" = 9; \"-a\" = 8; \"1x\" = 4; _x = 7; \"a b\" = 1; a-b' = 6; \"if\" = 2; or = 5; \"x\\\"y\" = 10; }", - printsIO - "nested lists and sets print their strings and names the same way" - "let v = [ (builtins.readFile ./latin1) { \"b c\" = [ \"$\" \"\\${\" ]; } ]; in builtins.deepSeq v v" - ("[ \"" <> notUtf8 <> "\" { \"b c\" = [ \"$\" \"\\${\" ]; } ]"), - prints "an element never forced prints as upstream's thunk marker" "[ (1 + 1) ]" "[ ]", - prints "a lambda prints as upstream's marker" "x: x" "", - prints "a primop prints as upstream's marker" "builtins.map" "", - prints "a partially applied primop prints as upstream's marker" "builtins.map (x: x)" "", - prints "a regex builtin given its pattern is a partial application" "builtins.match \"a\"" "", - runTestM "a printed string reads back as itself" $ - quickCheckPasses $ - QC.forAll genEscapable $ \text -> - readsBack (renderResult (mkStr text)) (mkStr text), - runTestM "a printed attribute name reads back as itself" $ - quickCheckPasses $ - QC.forAll genAttrName $ \name -> - let attrs = VAttrs (attrSetFromMap (Map.singleton name (evaluated (VInt 1)))) - in readsBack ("builtins.head (builtins.attrNames " <> renderResult attrs <> ")") (mkStr name) - ] - <> map floatPrints floatCases - where - renderResult = BL.toStrict . BB.toLazyByteString . printAmbiguous - readsBack printed expected = case TE.decodeUtf8' printed of - Left _ -> QC.counterexample "the printed bytes are not UTF-8" False - Right source -> evalNix source QC.=== Right expected - quickCheckPasses property = do - result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - -- Upstream unary minus is 0 - x, so -0.0 written as a literal is - -- positive zero there; fromJSON yields a negative one. - floatCases = - [ ("1.0", "1"), - ("1.5", "1.5"), - ("0.1", "0.1"), - ("1.0e20", "1e+20"), - ("1.23456789", "1.23457"), - ("builtins.fromJSON \"-0.0\"", "-0"), - ("1234567.0", "1.23457e+06") - ] - --- | Attribute names built from what decides whether one prints bare: the --- identifier characters in and out of first place, the reserved keywords --- and @or@, which is not one, and characters only a quoted name holds. -genAttrName :: QC.Gen Text -genAttrName = - T.concat <$> QC.listOf (QC.elements ["a", "Z", "_", "0", "'", "-", " ", "\"", "\\", "${", ".", "\233", "if", "in", "inherit", "rec", "or"]) - --- --------------------------------------------------------------------------- --- Tests: Eval - Recursive attribute sets --- --------------------------------------------------------------------------- - -testEvalRecAttrs :: IO [Bool] -testEvalRecAttrs = do - putStrLn "eval/rec-attrs" - sequence - [ runTest "rec self-reference" $ - assertEval "rec-self" "rec { a = 1; b = a + 1; }.b" (VInt 2), - runTest "rec mutual reference" $ - assertEval "rec-mutual" "rec { a = 1; b = a; }.b" (VInt 1), - -- A plain inherit inside a fallback (nested-path) rec/let must reference - -- the OUTER binding, not self-reference into infinite recursion. - runTest "inherit in fallback rec set references outer" $ - assertEval "inherit-fallback-rec" "let n = 7; in (rec { inherit n; a.b = 1; }).n" (VInt 7), - runTest "inherit in fallback let references outer" $ - assertEval "inherit-fallback-let" "let x = 5; in let a.b = 1; inherit x; in x" (VInt 5), - -- Guard the fix: a genuine sibling reference in a fallback rec still resolves. - runTest "sibling reference survives in fallback rec" $ - assertEval "sibling-fallback-rec" "(rec { a = 1; b = a + 10; c.d = 2; }).b" (VInt 11), - -- Dynamic rec-set keys evaluate in the rec env (C++ Nix env2): a key may - -- reference an enclosing var or a static sibling, and must not abort. - runTest "dynamic key references enclosing var" $ - assertEval "dyn-key-enclosing" "let k = \"x\"; in (rec { p.q = 1; ${k} = 2; }).x" (VInt 2), - runTest "dynamic key resolves the correct enclosing slot" $ - assertEval "dyn-key-slot" "let a = \"A\"; b = \"B\"; in let c = \"C\"; in (rec { p.q = 1; ${b} = 2; }).B" (VInt 2), - runTest "dynamic key references a static rec sibling" $ - assertEval "dyn-key-sibling" "(rec { a = \"b\"; ${a} = 1; }).b" (VInt 1) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Lists --- --------------------------------------------------------------------------- - -testEvalLists :: IO [Bool] -testEvalLists = do - putStrLn "eval/lists" - sequence - [ runTest "list head" $ - assertEval "head" "builtins.head [ 1 2 3 ]" (VInt 1), - runTest "list length" $ - assertEval "length" "builtins.length [ 1 2 3 ]" (VInt 3), - runTest "list concat" $ - assertEval "concat" "builtins.length ([ 1 ] ++ [ 2 3 ])" (VInt 3), - runTest "head forces only the first element" $ - assertEval "head-lazy" "builtins.head [ 1 (throw \"x\") ]" (VInt 1), - runTest "tail keeps every element after the first" $ - assertEval "tail" "builtins.tail [ 1 2 3 ] == [ 2 3 ]" (VBool True), - runTest "tail of a tail" $ - assertEval "tail-tail" "builtins.tail (builtins.tail [ 1 2 3 ]) == [ 3 ]" (VBool True), - runTest "tail of a one-element list is empty" $ - assertEval "tail-one" "builtins.tail [ 1 ] == [ ]" (VBool True), - runTest "tail forces none of the elements" $ - assertEval "tail-lazy" "builtins.length (builtins.tail [ (throw \"a\") (throw \"b\") ])" (VInt 1), - runTest "head of a tail" $ - assertEval "head-tail" "builtins.head (builtins.tail [ 1 2 3 ])" (VInt 2), - -- The messages 2.24.9 raises: head is its elemAt at index 0 and - -- tail has its own (primops.cc), a non-list fails in forceList - -- (eval-inline.hh), and tryEval catches neither. 2.26.0 reworded - -- both empty-list messages, so nix-instantiate 2.33.2 prints - -- "'builtins.head' called on an empty list" and the same for tail. - runTest "head of an empty list" $ - assertEvalError "head-empty" "builtins.head [ ]" "list index 0 is out of bounds", - runTest "tail of an empty list" $ - assertEvalError "tail-empty" "builtins.tail [ ]" "'tail' called on an empty list", - runTest "head of the empty list tail returns" $ - assertEvalError "head-tail-empty" "builtins.head (builtins.tail [ 1 ])" "list index 0 is out of bounds", - runTest "tail of the empty list tail returns" $ - assertEvalError "tail-tail-empty" "builtins.tail (builtins.tail [ 1 ])" "'tail' called on an empty list", - runTest "head of an integer" $ - assertEvalError "head-int" "builtins.head 1" "expected a list but found an integer: 1", - runTest "head of a string" $ - assertEvalError "head-string" "builtins.head \"x\"" "expected a list but found a string: \"x\"", - runTest "tail of null" $ - assertEvalError "tail-null" "builtins.tail null" "expected a list but found null: null", - runTest "tail of a Boolean" $ - assertEvalError "tail-bool" "builtins.tail true" "expected a list but found a Boolean: true", - runTest "tryEval does not catch head of an empty list" $ - assertEvalError "head-empty-tryeval" "builtins.tryEval (builtins.head [ ])" "list index 0 is out of bounds", - runTest "tryEval does not catch tail of a non-list" $ - assertEvalError "tail-int-tryeval" "builtins.tryEval (builtins.tail 1)" "expected a list but found an integer: 1", - runTest "length of an integer" $ - assertEvalError "length-int" "builtins.length 1" "expected a list but found an integer: 1", - runTest "length of null" $ - assertEvalError "length-null" "builtins.length null" "expected a list but found null: null", - runTestM "drop and index on a C list agree with the materialized list" $ do - result <- - QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ - QC.forAll genCase $ \(values, drops, index) -> - QC.ioProperty $ do - ptrs <- mapM cthunkNewComputedInt values - let dropped = foldl' (flip clistDrop) (clistFromThunks ptrs) drops - model = foldl' (flip drop) ptrs drops - modelAt i - | i < 0 = Nothing - | otherwise = listToMaybe (drop i model) - pure $ - (clistThunks dropped, clistLen dropped, clistIndex dropped index) - QC.=== (model, length model, modelAt index) - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - ] - where - -- Short lists and a few drops, so the drops and the index land on - -- both sides of the bounds, negatives included. - genCount = QC.choose (-2, 12) - genCase = (,,) <$> QC.resize 10 (QC.listOf QC.arbitrary) <*> QC.resize 4 (QC.listOf genCount) <*> genCount - --- --------------------------------------------------------------------------- --- Tests: Eval - Lambda --- --------------------------------------------------------------------------- - -testEvalLambda :: IO [Bool] -testEvalLambda = do - putStrLn "eval/lambda" - sequence - [ runTest "identity" $ - assertEval "id" "(x: x) 42" (VInt 42), - runTest "closure" $ - assertEval "closure" "let f = x: x + 1; in f 5" (VInt 6), - runTest "set pattern" $ - assertEval "set-pat" "({ a, b }: a + b) { a = 1; b = 2; }" (VInt 3), - runTest "default param" $ - assertEval "default" "({ a ? 10 }: a) { }" (VInt 10), - -- Zero-formal set patterns marshal count 0 / entries NULL; the - -- second force of the same lambda thunk re-reads the entries and - -- must not underflow the unsigned count. - runTest "empty formals forced twice" $ - assertEval "empty-formals" "let f = {}: 1; in f {} + f {}" (VInt 2), - runTest "ellipsis-only formals forced twice" $ - assertEval "ellipsis-only" "let f = { ... }: 1; in f {} + f {}" (VInt 2), - runTest "named empty formals forced twice" $ - assertEval "named-empty" "let f = args@{ ... }: 1; in f {} + f {}" (VInt 2) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - With --- --------------------------------------------------------------------------- - -testEvalWith :: IO [Bool] -testEvalWith = do - putStrLn "eval/with" - sequence - [ runTest "with basic" $ - assertEval "with" "with { a = 1; }; a" (VInt 1), - runTest "with lexical wins" $ - assertEval "lexical" "let a = 1; in with { a = 2; }; a" (VInt 1), - -- EWithVar: with-scoped variable inside lambda (closure trimming must preserve with-scopes) - runTest "with inside lambda" $ - assertEval - "with-lambda" - "with { a = 1; }; let f = x: a + x; in f 2" - (VInt 3), - -- Nested with: inner with wins - runTest "nested with inner wins" $ - assertEval - "nested-with" - "with { a = 1; }; with { a = 2; }; a" - (VInt 2), - -- Let shadows with - runTest "let shadows with" $ - assertEval - "let-shadows-with" - "with { a = 1; }; let a = 2; in a" - (VInt 2), - -- A fallback (nested-path) let/rec binding shadows with too: the - -- NameBarrier must not be upgraded to a with-variable. - runTest "barrier let shadows with" $ - assertEval - "barrier-shadows-with" - "let a.b = 1; x = 42; in with { x = 99; }; x" - (VInt 42), - runTest "barrier rec binding shadows with" $ - assertEval - "barrier-rec-shadows-with" - "with { q = 99; }; (rec { c.d = 1; q = 5; b = q; }).b" - (VInt 5), - -- Static globals bind at parse time; with never shadows them. - runTest "with cannot shadow global map" $ - assertEval - "with-global-map" - "builtins.typeOf (with { map = 42; }; map)" - (mkStr "lambda"), - -- fetchurl is NOT an upstream global: the with-scope must win, or - -- nixpkgs-style 'with pkgs; fetchurl' would bind the builtin. - runTest "with shadows non-global fetchurl" $ - assertEval - "with-fetchurl" - "with { fetchurl = 42; }; fetchurl" - (VInt 42), - -- Builtin fallback: builtins still accessible inside with - runTest "with builtin fallback" $ - assertEval - "with-builtin" - "with { a = 1; }; true" - (VBool True), - -- Builtin attr fallback: builtins.length still works inside with - runTest "with builtin attr fallback" $ - assertEval - "with-builtin-attr" - "with { a = 1; }; builtins.length [1 2 3]" - (VInt 3), - -- With in rec attrs - runTest "with in rec attrs" $ - assertEval - "with-rec" - "with { a = 1; }; rec { b = a + 1; c = b + 1; }.c" - (VInt 3), - -- AST test: parse "with a; b" produces EWithVar - runTest "parse with produces EWithVar" $ - assertRight "with-ast" (parseNixWithScope (withGlobals ["a"]) testBaseDir "" "with a; b") $ \case - EWith (EVar "a") (EWithVar "b") -> Pass - other -> Fail ("expected EWith (EVar a) (EWithVar b), got: " <> T.pack (show other)), - -- AST test: formal wins over with - runTest "parse lambda formal wins over with" $ - assertRight "formal-wins" (parseNixWithScope (withGlobals ["a"]) testBaseDir "" "x: with a; x") $ \case - ELambda _ (EWith _ (EResolvedVar 0 0)) _ -> Pass - other -> Fail ("expected formal to win, got: " <> T.pack (show other)), - -- Trimming test: lambda inside with gets CapturesWithScopes - runTest "with lambda trimmed with CapturesWithScopes" $ - assertRight "with-trim" (parseNixWithScope (withGlobals ["a"]) testBaseDir "" "with a; x: b + x") $ \case - EWith _ (ELambda _ _ (CapturesWithScopes _)) -> Pass - other -> Fail ("expected CapturesWithScopes, got: " <> T.pack (show other)) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Builtins --- --------------------------------------------------------------------------- - -testEvalBuiltins :: IO [Bool] -testEvalBuiltins = do - putStrLn "eval/builtins" - sequence - [ runTest "typeOf int" $ - assertEval "typeOf-int" "builtins.typeOf 42" (mkStr "int"), - runTest "typeOf string" $ - assertEval "typeOf-str" "builtins.typeOf \"hi\"" (mkStr "string"), - runTest "isNull true" $ - assertEval "isNull-t" "builtins.isNull null" (VBool True), - runTest "isNull false" $ - assertEval "isNull-f" "builtins.isNull 1" (VBool False), - runTest "stringLength" $ - assertEval "strlen" "builtins.stringLength \"hello\"" (VInt 5), - runTest "a builtin taking a string coerces a set as upstream's coerceToString" $ - assertEval "strlen-outpath" "builtins.stringLength { outPath = \"abc\"; }" (VInt 3) - `andThen` assertEval "strlen-tostring" "builtins.stringLength { __toString = s: \"ab\"; }" (VInt 2) - `andThen` assertEval "substring-outpath" "builtins.substring 1 1 { outPath = \"abc\"; }" (mkStr "b") - `andThen` assertEval "discard-outpath" "builtins.unsafeDiscardStringContext { outPath = \"abc\"; }" (mkStr "abc") - `andThen` assertEval "discard-output-outpath" "builtins.unsafeDiscardOutputDependency { outPath = \"abc\"; }" (mkStr "abc"), - runTest "a builtin taking a string refuses what coerceToString refuses" $ - assertEvalError "strlen-int" "builtins.stringLength 1" "cannot coerce an integer to a string: 1" - `andThen` assertEvalError "substring-int" "builtins.substring 0 1 1" "cannot coerce an integer to a string: 1" - `andThen` assertEvalError "discard-int" "builtins.unsafeDiscardStringContext 1" "cannot coerce an integer to a string: 1" - `andThen` assertEvalError "discard-output-int" "builtins.unsafeDiscardOutputDependency 1" "cannot coerce an integer to a string: 1" - `andThen` assertEvalError "add-output-int" "builtins.addDrvOutputDependencies 1" "cannot coerce an integer to a string: 1", - -- Lexer edge cases pinned to upstream: $${ is literal, ''' escapes to '', \q -> q. - runTest "$${ does not interpolate (double dollar is literal)" $ - assertEval "dollar-dollar-str" "builtins.stringLength \"a$${b}c\"" (VInt 7), - runTest "$${ literal in indented string" $ - assertEval "dollar-dollar-ind" "builtins.stringLength ''a$${b}c''" (VInt 7), - runTest "''' escapes two quotes in indented string" $ - assertEval "triple-quote" "''a'''b'' == \"a''b\"" (VBool True), - runTest "unknown escape drops backslash (regular string)" $ - assertEval "esc-drop-str" "\"a\\qb\" == \"aqb\"" (VBool True), - runTest "unknown escape drops backslash (indented string)" $ - assertEval "esc-drop-ind" "''a''\\qb'' == \"aqb\"" (VBool True), - -- Indentation stripping is upstream's stripIndentation rule for - -- rule (parser-state.hh at 2.24.9), every case checked against - -- nix-instantiate 2.33.2. The scan skips an escape, so the spaces - -- after an escaped newline are never measured; the strip runs over - -- escapes like any literal, so those spaces are stripped by the - -- minimum measured elsewhere. An interpolation is opaque to both. - runTest "escaped newline: following spaces are stripped, not measured" $ - assertEval "ind-esc-nl-strip" "'' a''\\n b''" (mkStr "a\nb"), - runTest "escaped newline: a shallower line after it is not the minimum" $ - assertEval "ind-esc-nl-indent" "''\n x''\\n y\n z''" (mkStr "x\ny\nz"), - runTest "escaped newline at line start keeps the next line stripped" $ - assertEval "ind-esc-nl-start" "''\n ''\\n b''" (mkStr "\nb"), - runTest "interpolated newline leaves the next chunk mid-line" $ - assertEval "ind-interp-nl" "''\n ${\"\\n\"} b''" (mkStr "\n b"), - -- The minimum starts at a sentinel, so a string with no measured - -- line loses every leading space (#220). - runTest "blank line then a spaces-only line strips to the newline" $ - assertEval "ind-blank-spaces" "''\n\n ''" (mkStr "\n"), - runTest "spaces-only line strips to nothing" $ - assertEval "ind-spaces-only" "''\n ''" (mkStr ""), - runTest "spaces between opener and closer strip to nothing" $ - assertEval "ind-spaces-same-line" "'' ''" (mkStr ""), - -- Only a space is indentation: a tab fixes the minimum at its - -- column and survives. - runTest "tabs are content, not indentation" $ - assertEval "ind-tabs" "''\n\t\ta\n\t\tb\n''" (mkStr "\t\ta\n\t\tb\n"), - runTest "a tab after the opener is content" $ - assertEval "ind-opener-tab" "''\t\n a\n''" (mkStr "\t\n a\n"), - -- The last part sheds a final line of spaces after stripping; the - -- rule runs on that part alone. - runTest "closing indentation after a blank line is dropped" $ - assertEval "ind-closer-spaces" "''\n a\n\n ''" (mkStr "a\n\n"), - runTest "closing indentation after an interpolation is dropped" $ - assertEval "ind-closer-after-interp" "''\n ${\"v\"}\n ''" (mkStr "v\n"), - runTest "spaces after an interpolation on the last line survive" $ - assertEval "ind-interp-last-line" "''\n ${\"v\"} ''" (mkStr "v "), - -- The opener consumes its own line's trailing spaces and newline. - runTest "spaces before the opener's newline are not a line" $ - assertEval "ind-opener-spaces" "'' \n a\n''" (mkStr "a\n"), - runTest "an opener line of spaces then the closer is empty" $ - assertEval "ind-opener-only" "'' \n''" (mkStr ""), - runTest "toString int" $ - assertEval "toStr" "builtins.toString 42" (mkStr "42") - ] - --- | A list coerced to a string, as upstream's @coerceToString@ joins one --- under @coerceMore@ (eval.cc at 2.24.9). Each expected string is --- nix-instantiate 2.24.9's. -testListCoercion :: IO [Bool] -testListCoercion = do - putStrLn "eval/list-coercion" - let joins label source expected = runTest label (assertEval label ("builtins.toString " <> source) (mkStr expected)) - bytes = BS.pack <$> QC.listOf QC.arbitrary - quickCheckPasses property = do - result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - sequence - [ joins "elements are joined with spaces" "[ 1 \"a\" 2 ]" "1 a 2", - joins "an empty list element takes no space after it" "[ [ ] 1 ]" "1", - joins "an empty list between two elements leaves one space" "[ 1 [ ] 2 ]" "1 2", - joins "an element before an empty list keeps its space" "[ 1 [ ] ]" "1 ", - joins "a list holding an empty list is not empty" "[ [ [ ] ] 1 ]" " 1", - joins "an empty string element keeps its space" "[ \"\" 1 ]" " 1", - joins "nested lists flatten through the same join" "[ [ 1 [ 2 3 ] ] 4 ]" "1 2 3 4", - joins "a __toString may return a list" "{ __toString = s: [ 1 2 ]; }" "1 2", - joins "an outPath may be a list" "{ outPath = [ 1 2 ]; }" "1 2", - joins "an element whose __toString is an empty list keeps its space" "[ { __toString = s: [ ]; } 1 ]" " 1", - runTest "interpolation still refuses a list" $ - assertEvalError "interp-list" "\"${[ 1 2 ]}\"" "cannot coerce a list to a string: [ 1 2 ]", - runTestM "without empty lists the join is intercalate" $ - quickCheckPasses $ - QC.forAll (QC.listOf bytes) $ \parts -> - joinCoercedList [(part, False) | part <- parts] QC.=== BS.intercalate " " parts, - runTestM "an empty list before any element changes nothing" $ - quickCheckPasses $ - QC.forAll (QC.listOf bytes) $ \before -> - QC.forAll (QC.listOf1 bytes) $ \after -> - let marked = map (,False) - in joinCoercedList (marked before <> [("", True)] <> marked after) QC.=== joinCoercedList (marked (before <> after)) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Errors --- --------------------------------------------------------------------------- - -testEvalErrors :: IO [Bool] -testEvalErrors = do - putStrLn "eval/errors" - sequence - [ runTest "type error in add (set + list)" $ - assertEvalFail "type-add" "{} + []", - runTest "call non-function" $ - assertEvalFail "call-non" "42 1", - runTest "builtins.throw" $ - assertEvalFail "throw" "builtins.throw \"boom\"" - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Higher-order builtins --- --------------------------------------------------------------------------- - -testEvalHigherOrder :: IO [Bool] -testEvalHigherOrder = do - putStrLn "eval/higher-order" - sequence - [ -- map - runTest "map basic" $ - assertEval "map" "builtins.map (x: x + 1) [ 1 2 3 ] == [ 2 3 4 ]" (VBool True), - runTest "map identity" $ - assertEval "map-id" "builtins.map (x: x) [ 1 2 ] == [ 1 2 ]" (VBool True), - runTest "map empty" $ - assertEval "map-empty" "builtins.map (x: x) [ ]" (VList emptyCList), - runTest "map lazy" $ - assertEval "map-lazy" "let xs = builtins.map (x: x * 2) [ 1 (throw \"boom\") 3 ]; in builtins.elemAt xs 0" (VInt 2), - -- filter - runTest "filter match" $ - assertEval "filter" "builtins.filter (x: x == 2) [ 1 2 3 ] == [ 2 ]" (VBool True), - runTest "filter none" $ - assertEval "filter-none" "builtins.filter (x: false) [ 1 2 ] == [ ]" (VBool True), - -- foldl' - runTest "foldl' sum" $ - assertEval "foldl-sum" "builtins.foldl' (a: b: a + b) 0 [ 1 2 3 ]" (VInt 6), - runTest "foldl' string concat" $ - assertEval "foldl-str" "builtins.foldl' (a: b: a + b) \"\" [ \"x\" \"y\" \"z\" ]" (mkStr "xyz"), - runTest "foldl' empty" $ - assertEval "foldl-empty" "builtins.foldl' (a: b: a + b) 0 [ ]" (VInt 0), - -- genList - runTest "genList basic" $ - assertEval "genList" "builtins.genList (i: i * 2) 4 == [ 0 2 4 6 ]" (VBool True), - runTest "genList zero" $ - assertEval "genList-0" "builtins.genList (i: i) 0" (VList emptyCList), - runTest "genList lazy" $ - assertEval "genList-lazy" "let xs = builtins.genList (i: if i == 0 then 42 else throw \"boom\") 5; in builtins.elemAt xs 0" (VInt 42), - -- sort - runTest "sort ints" $ - assertEval "sort" "builtins.sort (a: b: a < b) [ 3 1 2 ] == [ 1 2 3 ]" (VBool True), - runTest "sort already sorted" $ - assertEval "sort-sorted" "builtins.sort (a: b: a < b) [ 1 2 3 ] == [ 1 2 3 ]" (VBool True), - -- Stable: comparator-equal elements keep their input order (std::stable_sort). - runTest "sort is stable across ties" $ - assertEval - "sort-stable" - "builtins.sort (a: b: a.k < b.k) [ { k = 1; v = 1; } { k = 0; v = 2; } { k = 1; v = 3; } { k = 0; v = 4; } ] == [ { k = 0; v = 2; } { k = 0; v = 4; } { k = 1; v = 1; } { k = 1; v = 3; } ]" - (VBool True), - runTest "sort preserves order of all-equal elements" $ - assertEval - "sort-stable-all" - "builtins.sort (a: b: a.k < b.k) [ { k = 0; v = 1; } { k = 0; v = 2; } { k = 0; v = 3; } ] == [ { k = 0; v = 1; } { k = 0; v = 2; } { k = 0; v = 3; } ]" - (VBool True), - -- concatMap - runTest "concatMap" $ - assertEval "concatMap" "builtins.concatMap (x: [ x (x * 2) ]) [ 1 2 ] == [ 1 2 2 4 ]" (VBool True), - -- any - runTest "any true" $ - assertEval "any-t" "builtins.any (x: x == 2) [ 1 2 3 ]" (VBool True), - runTest "any false" $ - assertEval "any-f" "builtins.any (x: x == 5) [ 1 2 3 ]" (VBool False), - -- all - runTest "all true" $ - assertEval "all-t" "builtins.all (x: x > 0) [ 1 2 3 ]" (VBool True), - runTest "all false" $ - assertEval "all-f" "builtins.all (x: x > 1) [ 1 2 3 ]" (VBool False), - -- elem - runTest "elem found" $ - assertEval "elem-t" "builtins.elem 2 [ 1 2 3 ]" (VBool True), - runTest "elem not found" $ - assertEval "elem-f" "builtins.elem 5 [ 1 2 3 ]" (VBool False), - -- elemAt - runTest "elemAt valid" $ - assertEval "elemAt" "builtins.elemAt [ 10 20 30 ] 1" (VInt 20), - -- The messages 2.24.9 raises (elemAt in primops.cc, forceInt in - -- eval.cc, forceList in eval-inline.hh). The index is forced and - -- checked before the list. 2.26.0 reworded the bounds message; - -- 2.33.2 prints "'builtins.elemAt' called with index 5 on a list of - -- size 2". - runTest "elemAt past the end" $ - assertEvalError "elemAt-oob" "builtins.elemAt [ 1 2 ] 5" "list index 5 is out of bounds", - runTest "elemAt at the length" $ - assertEvalError "elemAt-length" "builtins.elemAt [ 1 2 ] 2" "list index 2 is out of bounds", - runTest "elemAt negative index" $ - assertEvalError "elemAt-negative" "builtins.elemAt [ 1 2 ] (-1)" "list index -1 is out of bounds", - runTest "elemAt on an empty list" $ - assertEvalError "elemAt-empty" "builtins.elemAt [ ] 0" "list index 0 is out of bounds", - runTest "elemAt of a non-list" $ - assertEvalError "elemAt-int" "builtins.elemAt 1 0" "expected a list but found an integer: 1", - runTest "elemAt with a string index" $ - assertEvalError "elemAt-string-index" "builtins.elemAt [ 1 2 ] \"x\"" "expected an integer but found a string: \"x\"", - runTest "elemAt checks the index before the list" $ - assertEvalError "elemAt-index-first" "builtins.elemAt 1 \"x\"" "expected an integer but found a string: \"x\"", - -- partition - runTest "partition right" $ - assertEval "partition-right" "(builtins.partition (x: x > 2) [ 1 2 3 4 ]).right == [ 3 4 ]" (VBool True), - runTest "partition wrong" $ - assertEval "partition-wrong" "(builtins.partition (x: x > 2) [ 1 2 3 4 ]).wrong == [ 1 2 ]" (VBool True), - -- groupBy - runTest "groupBy pos" $ - assertEval "groupBy-pos" "(builtins.groupBy (x: if x > 0 then \"pos\" else \"neg\") [ 1 (- 2) 3 ]).pos == [ 1 3 ]" (VBool True), - runTest "groupBy neg" $ - assertEval "groupBy-neg" "(builtins.groupBy (x: if x > 0 then \"pos\" else \"neg\") [ 1 (- 2) 3 ]).neg == [ (- 2) ]" (VBool True), - -- attrNames - runTest "attrNames sorted" $ - assertEval "attrNames" "builtins.attrNames { b = 2; a = 1; c = 3; } == [ \"a\" \"b\" \"c\" ]" (VBool True), - -- attrValues - runTest "attrValues count" $ - assertEval "attrValues" "builtins.length (builtins.attrValues { a = 1; b = 2; })" (VInt 2), - -- hasAttr - runTest "hasAttr true" $ - assertEval "hasAttr-t" "builtins.hasAttr \"a\" { a = 1; }" (VBool True), - runTest "hasAttr false" $ - assertEval "hasAttr-f" "builtins.hasAttr \"z\" { a = 1; }" (VBool False), - -- getAttr - runTest "getAttr" $ - assertEval "getAttr" "builtins.getAttr \"a\" { a = 42; }" (VInt 42), - runTest "getAttr missing" $ - assertEvalFail "getAttr-miss" "builtins.getAttr \"z\" { a = 1; }", - -- removeAttrs - runTest "removeAttrs" $ - assertEval "removeAttrs" "builtins.attrNames (builtins.removeAttrs { a = 1; b = 2; c = 3; } [ \"b\" ]) == [ \"a\" \"c\" ]" (VBool True), - -- intersectAttrs - runTest "intersectAttrs" $ - assertEval "intersectAttrs" "(builtins.intersectAttrs { a = 1; b = 2; } { b = 20; c = 30; }).b" (VInt 20), - runTest "intersectAttrs keys" $ - assertEval "intersectAttrs-keys" "builtins.attrNames (builtins.intersectAttrs { a = 1; b = 2; } { b = 20; c = 30; }) == [ \"b\" ]" (VBool True), - -- catAttrs - runTest "catAttrs" $ - assertEval "catAttrs" "builtins.catAttrs \"a\" [ { a = 1; } { b = 2; } { a = 3; } ] == [ 1 3 ]" (VBool True), - -- listToAttrs - runTest "listToAttrs" $ - assertEval "listToAttrs" "(builtins.listToAttrs [ { name = \"x\"; value = 1; } { name = \"y\"; value = 2; } ]).x" (VInt 1), - -- substring - runTest "substring basic" $ - assertEval "substr" "builtins.substring 1 2 \"hello\"" (mkStr "el"), - runTest "substring clamped" $ - assertEval "substr-clamp" "builtins.substring 3 100 \"hello\"" (mkStr "lo"), - -- concatStringsSep - runTest "concatStringsSep" $ - assertEval "concatSep" "builtins.concatStringsSep \", \" [ \"a\" \"b\" \"c\" ]" (mkStr "a, b, c"), - -- Partial application - runTest "partial application" $ - assertEval "partial" "let f = builtins.map (x: x + 1); in f [ 1 2 3 ] == [ 2 3 4 ]" (VBool True) - ] - --- --------------------------------------------------------------------------- --- Tests: Lexer --- --------------------------------------------------------------------------- - -testLexer :: IO [Bool] -testLexer = do - putStrLn "parser/lexer" - sequence - [ runTest "integer" $ - assertRight "lex int" (tokenize "" "42") $ \toks -> - assertEqual "tokens" [TokInt 42] (tokenTypes toks), - runTest "float" $ - assertRight "lex float" (tokenize "" "3.14") $ \toks -> - assertEqual "tokens" [TokFloat 3.14] (tokenTypes toks), - runTest "trailing-dot float lexes as one float token" $ - assertRight "lex trailing-dot" (tokenize "" "12.") $ \toks -> - assertEqual "tokens" [TokFloat 12.0] (tokenTypes toks), - -- Maximal munch: a dot-led run with a /-segment is one PATH token - -- (upstream's PATH regex), while a slashless dot-run is not. - runTest "dot-relative path lexes as one token" $ - assertRight "lex dot-path" (tokenize "" ".github/x") $ \toks -> - assertEqual "tokens" [TokPath ".github/x"] (tokenTypes toks), - runTest "leading-dot float still lexes as float" $ - assertRight "lex dot-float" (tokenize "" ".5") $ \toks -> - assertEqual "tokens" [TokFloat 0.5] (tokenTypes toks), - runTest "trailing-dot float with exponent lexes as one float token" $ - assertRight "lex trailing-dot-exp" (tokenize "" "12.e2") $ \toks -> - assertEqual "tokens" [TokFloat 1200.0] (tokenTypes toks), - -- Float literals convert with a single rounding (strtod semantics). - -- The exact value here sits between representable ..992 and ..994, - -- nearer ..994; rounding whole and fraction separately lands on ..992. - runTest "float literal rounds once at the 2^53 boundary" $ - assertRight "lex float-tie" (tokenize "" "9007199254740993.5") $ \toks -> - assertEqual "tokens" [TokFloat 9007199254740994.0] (tokenTypes toks), - -- A float 10 ^^ exponent overflows on subnormals and flushes to 0. - runTest "subnormal float literal survives" $ - assertRight "lex float-subnormal" (tokenize "" "1.0e-320") $ \toks -> - assertEqual "tokens" [TokFloat 1.0e-320] (tokenTypes toks), - -- Bounded number lexing: a literal's cost must follow its length, - -- never its exponent's magnitude, and megadigit literals must - -- resolve promptly. The watchdog turns a cost regression into a - -- FAIL instead of a stuck suite; the checks force full values. - runTestM "huge positive exponent saturates to Infinity" $ do - let saturated = case tokenize "" "1.0e999999999" of - Right toks | [TokFloat f] <- tokenTypes toks -> isInfinite f && f > 0 - _ -> False - outcome <- timeout walkWatchdogMicros (evaluate saturated) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong tokens for a huge positive exponent" - Nothing -> Fail "lexing did not return promptly", - runTestM "huge negative exponent saturates to zero" $ do - let flushed = case tokenize "" "1.0e-999999999" of - Right toks -> tokenTypes toks == [TokFloat 0.0] - Left _ -> False - outcome <- timeout walkWatchdogMicros (evaluate flushed) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong tokens for a huge negative exponent" - Nothing -> Fail "lexing did not return promptly", - runTestM "zero mantissa ignores a huge exponent" $ do - let zeroed = case tokenize "" "0.0e999999999" of - Right toks -> tokenTypes toks == [TokFloat 0.0] - Left _ -> False - outcome <- timeout walkWatchdogMicros (evaluate zeroed) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong tokens for a zero mantissa" - Nothing -> Fail "lexing did not return promptly", - runTestM "megadigit integer literal rejects promptly" $ do - let rejected = case tokenize "" (T.replicate 1000000 "9") of - Left _ -> True - Right _ -> False - outcome <- timeout walkWatchdogMicros (evaluate rejected) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "megadigit literal was not rejected" - Nothing -> Fail "range rejection did not return promptly", - runTestM "megadigit mantissa still rounds correctly" $ do - -- 1.999...9e5 sits within half an ulp of 200000.0; the kept-768 - -- digits plus the sticky digit must round it there. - let rounded = case tokenize "" ("1." <> T.replicate 1000000 "9" <> "e5") of - Right toks -> tokenTypes toks == [TokFloat 200000.0] - Left _ -> False - outcome <- timeout walkWatchdogMicros (evaluate rounded) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong rounding for a megadigit mantissa" - Nothing -> Fail "lexing did not return promptly", - runTest "true" $ - assertRight "lex true" (tokenize "" "true") $ \toks -> - assertEqual "tokens" [TokTrue] (tokenTypes toks), - runTest "false" $ - assertRight "lex false" (tokenize "" "false") $ \toks -> - assertEqual "tokens" [TokFalse] (tokenTypes toks), - runTest "null" $ - assertRight "lex null" (tokenize "" "null") $ \toks -> - assertEqual "tokens" [TokNull] (tokenTypes toks), - runTest "identifier" $ - assertRight "lex ident" (tokenize "" "foo") $ \toks -> - assertEqual "tokens" [TokIdent "foo"] (tokenTypes toks), - runTest "hyphened identifier" $ - assertRight "lex hyphened" (tokenize "" "hello-world") $ \toks -> - assertEqual "tokens" [TokIdent "hello-world"] (tokenTypes toks), - runTest "path ./foo" $ - assertRight "lex path" (tokenize "" "./foo") $ \toks -> - assertEqual "tokens" [TokPath "./foo"] (tokenTypes toks), - runTest "path ~/foo" $ - assertRight "lex path home" (tokenize "" "~/foo") $ \toks -> - assertEqual "tokens" [TokPath "~/foo"] (tokenTypes toks), - runTest "search path" $ - assertRight "lex search path" (tokenize "" "") $ \toks -> - assertEqual "tokens" [TokSearchPath "nixpkgs"] (tokenTypes toks), - runTest "URI" $ - assertRight "lex uri" (tokenize "" "https://example.com") $ \toks -> - assertEqual "tokens" [TokUri "https://example.com"] (tokenTypes toks), - -- Upstream URI = [a-zA-Z][a-zA-Z0-9+.-]*:[uri-char]+ with flex - -- maximal munch: no // required, and the URI beats identifiers, - -- keywords, and the lambda colon when it matches more characters. - runTest "scheme-only URI x:y" $ - assertRight "lex uri x:y" (tokenize "" "x:y") $ \toks -> - assertEqual "tokens" [TokUri "x:y"] (tokenTypes toks), - runTest "scheme-only URI mailto" $ - assertRight "lex uri mailto" (tokenize "" "mailto:foo@example.com") $ \toks -> - assertEqual "tokens" [TokUri "mailto:foo@example.com"] (tokenTypes toks), - runTest "URI scheme allows + . -" $ - assertRight "lex uri scheme" (tokenize "" "a+b.c:d") $ \toks -> - assertEqual "tokens" [TokUri "a+b.c:d"] (tokenTypes toks), - runTest "URI beats keyword by maximal munch" $ - assertRight "lex uri keyword" (tokenize "" "then:x") $ \toks -> - assertEqual "tokens" [TokUri "then:x"] (tokenTypes toks), - runTest "hash is not a URI char (starts a comment)" $ - assertRight "lex uri hash" (tokenize "" "http://a#frag") $ \toks -> - assertEqual "tokens" [TokUri "http://a"] (tokenTypes toks), - runTest "apostrophe and star are URI chars" $ - assertRight "lex uri quote star" (tokenize "" "http://e.com/a'b*c") $ \toks -> - assertEqual "tokens" [TokUri "http://e.com/a'b*c"] (tokenTypes toks), - runTest "lambda colon needs the space" $ - assertRight "lex lambda colon" (tokenize "" "x: y") $ \toks -> - assertEqual "tokens" [TokIdent "x", TokColon, TokIdent "y"] (tokenTypes toks), - runTest "underscore cannot start a URI scheme" $ - assertRight "lex underscore colon" (tokenize "" "_a:b") $ \toks -> - assertEqual "tokens" [TokIdent "_a", TokColon, TokIdent "b"] (tokenTypes toks), - -- Raw CR/CRLF normalizes to LF in double-quoted strings (upstream - -- unescapeStr); an escaped CR survives; indented strings keep CR - -- verbatim because upstream's IND_STRING chunks skip unescapeStr. - runTest "CRLF in double-quoted string normalizes to LF" $ - assertRight "lex crlf string" (tokenize "" "\"a\r\nb\"") $ \toks -> - assertEqual "tokens" [TokStringOpen, TokStringLit "a\nb", TokStringClose] (tokenTypes toks), - runTest "lone CR in double-quoted string normalizes to LF" $ - assertRight "lex cr string" (tokenize "" "\"a\rb\"") $ \toks -> - assertEqual "tokens" [TokStringOpen, TokStringLit "a\nb", TokStringClose] (tokenTypes toks), - runTest "escaped CR stays a literal CR" $ - assertRight "lex escaped cr" (tokenize "" "\"a\\\rb\"") $ \toks -> - assertEqual "tokens" [TokStringOpen, TokStringLit "a\rb", TokStringClose] (tokenTypes toks), - runTest "indented string keeps CRLF verbatim" $ - assertRight "lex ind crlf" (tokenize "" "''a\r\nb''") $ \toks -> - assertEqual "tokens" [TokIndStringOpen, TokStringLit "a\r\nb", TokIndStringClose] (tokenTypes toks), - -- The opener is '' with an optional run of spaces and one newline - -- (upstream lexer.l); a tab is not part of it. - runTest "indented string opener consumes trailing spaces and newline" $ - assertRight "lex ind opener" (tokenize "" "'' \n a''") $ \toks -> - assertEqual "tokens" [TokIndStringOpen, TokStringLit " a", TokIndStringClose] (tokenTypes toks), - runTest "indented string opener stops at a tab" $ - assertRight "lex ind opener tab" (tokenize "" "''\t\na''") $ \toks -> - assertEqual "tokens" [TokIndStringOpen, TokStringLit "\t\na", TokIndStringClose] (tokenTypes toks), - runTest "multi-char operators" $ - assertRight "lex ops" (tokenize "" "++ // -> == != && || <= >=") $ \toks -> - assertEqual - "tokens" - [TokConcat, TokUpdate, TokImpl, TokEq, TokNeq, TokAnd, TokOr, TokLte, TokGte] - (tokenTypes toks), - runTest "single-char operators" $ - assertRight "lex single ops" (tokenize "" "+ - * ! ? < >") $ \toks -> - assertEqual - "tokens" - [TokPlus, TokMinus, TokStar, TokNot, TokQuestion, TokLt, TokGt] - (tokenTypes toks), - runTest "division vs path" $ - assertRight "lex div" (tokenize "" "6 / 3") $ \toks -> - assertEqual "tokens" [TokInt 6, TokSlash, TokInt 3] (tokenTypes toks), - runTest "string tokens" $ - assertRight "lex string" (tokenize "" "\"hello\"") $ \toks -> - assertEqual - "tokens" - [TokStringOpen, TokStringLit "hello", TokStringClose] - (tokenTypes toks), - runTest "empty string" $ - assertRight "lex empty string" (tokenize "" "\"\"") $ \toks -> - assertEqual - "tokens" - [TokStringOpen, TokStringClose] - (tokenTypes toks), - runTest "string interpolation tokens" $ - assertRight "lex interp" (tokenize "" "\"a${x}b\"") $ \toks -> - assertEqual - "tokens" - [ TokStringOpen, - TokStringLit "a", - TokInterpOpen, - TokIdent "x", - TokInterpClose, - TokStringLit "b", - TokStringClose - ] - (tokenTypes toks), - runTest "line comment" $ - assertRight "lex comment" (tokenize "" "# comment\n42") $ \toks -> - assertEqual "tokens" [TokInt 42] (tokenTypes toks), - runTest "block comment" $ - assertRight "lex block comment" (tokenize "" "/* comment */ 42") $ \toks -> - assertEqual "tokens" [TokInt 42] (tokenTypes toks), - runTest "ellipsis" $ - assertRight "lex ellipsis" (tokenize "" "...") $ \toks -> - assertEqual "tokens" [TokEllipsis] (tokenTypes toks), - runTest "punctuation" $ - assertRight "lex punct" (tokenize "" ". @ : ; = ,") $ \toks -> - assertEqual - "tokens" - [TokDot, TokAt, TokColon, TokSemicolon, TokAssign, TokComma] - (tokenTypes toks), - runTest "delimiters" $ - assertRight "lex delimiters" (tokenize "" "( ) { } [ ]") $ \toks -> - assertEqual - "tokens" - [TokLParen, TokRParen, TokLBrace, TokRBrace, TokLBracket, TokRBracket] - (tokenTypes toks), - runTest "keywords" $ - assertRight "lex keywords" (tokenize "" "if then else let in with assert rec inherit") $ \toks -> - assertEqual - "tokens" - [TokIf, TokThen, TokElse, TokLet, TokIn, TokWith, TokAssert, TokRec, TokInherit] - (tokenTypes toks), - runTest "or is identifier" $ - assertRight "lex or" (tokenize "" "or") $ \toks -> - assertEqual "tokens" [TokIdent "or"] (tokenTypes toks), - runTest "string escape sequences" $ - assertRight "lex escapes" (tokenize "" "\"\\n\\t\\\\\\\"\"") $ \toks -> - assertEqual - "tokens" - [TokStringOpen, TokStringLit "\n\t\\\"", TokStringClose] - (tokenTypes toks) - ] - --- --------------------------------------------------------------------------- --- Tests: Parser expressions --- --------------------------------------------------------------------------- - -testParserExprs :: IO [Bool] -testParserExprs = do - putStrLn "parser/exprs" - sequence - [ -- Atoms - runTest "parse int" $ - assertParse "int" "42" (ELit (NixInt 42)), - runTest "parse float" $ - assertParse "float" "3.14" (ELit (NixFloat 3.14)), - runTest "parse true" $ - assertParse "true" "true" (ELit (NixBool True)), - runTest "parse false" $ - assertParse "false" "false" (ELit (NixBool False)), - runTest "parse null" $ - assertParse "null" "null" (ELit NixNull), - runTest "parse var" $ - assertParseIn ["x"] "var" "x" (EVar "x"), - runTest "parse empty string" $ - assertParse "empty string" "\"\"" (EStr []), - runTest "parse string literal" $ - assertParse "string" "\"hello\"" (EStr [StrLit "hello"]), - runTest "parse string interpolation" $ - assertParseIn - ["name"] - "interp" - "\"hello ${name}\"" - (EStr [StrLit "hello ", StrInterp (EVar "name")]), - runTest "parse nested string interpolation" $ - assertParse - "nested interp" - "\"${\"inner\"}\"" - (EStr [StrInterp (EStr [StrLit "inner"])]), - -- Arithmetic - runTest "parse add" $ - assertParse "add" "1 + 2" (EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2))), - runTest "parse sub" $ - assertParse "sub" "3 - 1" (EBinary OpSub (ELit (NixInt 3)) (ELit (NixInt 1))), - runTest "parse mul" $ - assertParse "mul" "2 * 3" (EBinary OpMul (ELit (NixInt 2)) (ELit (NixInt 3))), - runTest "parse left-assoc add" $ - assertParse - "left-assoc" - "1 + 2 + 3" - (EBinary OpAdd (EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2))) (ELit (NixInt 3))), - runTest "parse precedence mul over add" $ - assertParse - "precedence" - "1 + 2 * 3" - (EBinary OpAdd (ELit (NixInt 1)) (EBinary OpMul (ELit (NixInt 2)) (ELit (NixInt 3)))), - -- Unary - runTest "parse negation" $ - assertParse "negate" "-1" (EUnary OpNegate (ELit (NixInt 1))), - runTest "parse logical not" $ - assertParse "not" "!true" (EUnary OpNot (ELit (NixBool True))), - -- Non-associative - runTest "parse eq" $ - assertParse "eq" "1 == 2" (EBinary OpEq (ELit (NixInt 1)) (ELit (NixInt 2))), - runTest "parse lt" $ - assertParse "lt" "1 < 2" (EBinary OpLt (ELit (NixInt 1)) (ELit (NixInt 2))), - -- Right-associative - runTest "parse implication" $ - assertParseIn - ["a", "b", "c"] - "impl" - "a -> b -> c" - (EBinary OpImpl (EVar "a") (EBinary OpImpl (EVar "b") (EVar "c"))), - runTest "parse concat right" $ - assertParseIn - ["a", "b", "c"] - "concat" - "a ++ b ++ c" - (EBinary OpConcat (EVar "a") (EBinary OpConcat (EVar "b") (EVar "c"))), - runTest "parse update right" $ - assertParseIn - ["a", "b", "c"] - "update" - "a // b // c" - (EBinary OpUpdate (EVar "a") (EBinary OpUpdate (EVar "b") (EVar "c"))), - -- Lambda - -- After variable resolution, lambda-bound vars become EResolvedVar. - -- FormalName "x" maps to slot 0; FormalSet [a,b] maps to a=0, b=1; - -- FormalNamedSet "args" [a] maps to args=0, a=1. - runTest "parse simple lambda" $ - assertParse "lambda" "x: x" (ELambda (FormalName "x") (EResolvedVar 0 0) NoCaptureInfo), - runTest "parse set pattern lambda" $ - assertParse - "set pattern" - "{ a, b }: a" - ( ELambda - (FormalSet [Formal "a" Nothing, Formal "b" Nothing] False) - (EResolvedVar 0 0) - NoCaptureInfo - ), - runTest "parse set pattern with defaults" $ - assertParse - "defaults" - "{ a ? 1 }: a" - ( ELambda - (FormalSet [Formal "a" (Just (ELit (NixInt 1)))] False) - (EResolvedVar 0 0) - NoCaptureInfo - ), - runTest "parse set pattern with ellipsis" $ - assertParse - "ellipsis" - "{ a, ... }: a" - ( ELambda - (FormalSet [Formal "a" Nothing] True) - (EResolvedVar 0 0) - NoCaptureInfo - ), - runTest "parse named set pattern (name@{...})" $ - assertParse - "named set" - "args@{ a }: a" - ( ELambda - (FormalNamedSet "args" [Formal "a" Nothing] False) - (EResolvedVar 0 1) - NoCaptureInfo - ), - runTest "parse named set pattern ({...}@name)" $ - assertParse - "set@name" - "{ a }@args: a" - ( ELambda - (FormalNamedSet "args" [Formal "a" Nothing] False) - (EResolvedVar 0 1) - NoCaptureInfo - ), - -- Application - runTest "parse application" $ - assertParseIn ["f", "x"] "app" "f x" (EApp (EVar "f") (EVar "x")), - runTest "parse left-assoc application" $ - assertParseIn ["f", "x", "y"] "app left" "f x y" (EApp (EApp (EVar "f") (EVar "x")) (EVar "y")), - runTest "parse application with parens" $ - assertParseIn - ["f"] - "app parens" - "f (1 + 2)" - (EApp (EVar "f") (EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2)))), - -- Select - runTest "parse select" $ - assertParseIn ["a"] "select" "a.b" (ESelect (EVar "a") [StaticKey "b"] Nothing), - runTest "parse nested select" $ - assertParseIn - ["a"] - "nested select" - "a.b.c" - (ESelect (EVar "a") [StaticKey "b", StaticKey "c"] Nothing), - runTest "parse select or default" $ - assertParseIn - ["a"] - "select or" - "a.b or 1" - (ESelect (EVar "a") [StaticKey "b"] (Just (ELit (NixInt 1)))), - runTest "parse has-attr" $ - assertParseIn ["a"] "has-attr" "a ? b" (EHasAttr (EVar "a") [StaticKey "b"]), - -- Attr sets - runTest "parse empty attrs" $ - assertParse "empty attrs" "{ }" (EAttrs False [] NoCaptureInfo), - runTest "parse attrs with binding" $ - assertParse - "attrs" - "{ a = 1; }" - (EAttrs False [NamedBinding (StaticKey "a") (ELit (NixInt 1))] NoCaptureInfo), - runTest "parse rec attrs" $ - assertParse - "rec attrs" - "rec { a = 1; }" - (EAttrs True [NamedBinding (StaticKey "a") (ELit (NixInt 1))] NoCaptureInfo), - -- inherit x y; is one binding per name, each holding the variable it - -- copies, which resolution binds like any other variable. - runTest "parse inherit" $ - assertParseIn - ["x", "y"] - "inherit" - "{ inherit x y; }" - (EAttrs False [Inherit "x" (EVar "x"), Inherit "y" (EVar "y")] NoCaptureInfo), - runTest "parse inherit from" $ - assertParseIn - ["a"] - "inherit from" - "{ inherit (a) x; }" - (EAttrs False [InheritFrom (EVar "a") ["x"]] NoCaptureInfo), - -- Let/if/with/assert - runTest "parse let" $ - assertParse - "let" - "let x = 1; in x" - (ELet [NamedBinding (StaticKey "x") (ELit (NixInt 1))] (EResolvedVar 0 0) NoCaptureInfo), - runTest "parse if-then-else" $ - assertParse - "if" - "if true then 1 else 2" - (EIf (ELit (NixBool True)) (ELit (NixInt 1)) (ELit (NixInt 2))), - runTest "parse with" $ - assertParseIn - ["a"] - "with" - "with a; b" - (EWith (EVar "a") (EWithVar "b")), - runTest "parse assert" $ - assertParse - "assert" - "assert true; 1" - (EAssert (ELit (NixBool True)) (ELit (NixInt 1))), - -- Lists - runTest "parse empty list" $ - assertParse "empty list" "[ ]" (EList []), - runTest "parse list elements" $ - assertParse - "list" - "[ 1 2 3 ]" - (EList [ELit (NixInt 1), ELit (NixInt 2), ELit (NixInt 3)]), - -- Parens - runTest "parse parens" $ - assertParse "parens" "(42)" (ELit (NixInt 42)), - -- 'or' as identifier - runTest "or as identifier" $ - assertParseIn ["or"] "or ident" "or" (EVar "or"), - -- 'or' as attr key - runTest "or as attr key" $ - assertParse - "or attr key" - "{ or = 1; }" - (EAttrs False [NamedBinding (StaticKey "or") (ELit (NixInt 1))] NoCaptureInfo) - ] - --- --------------------------------------------------------------------------- --- Tests: Parser errors --- --------------------------------------------------------------------------- - -testParserErrors :: IO [Bool] -testParserErrors = do - putStrLn "parser/errors" - sequence - [ runTest "empty input" $ - assertLeft "empty" (parseNix testBaseDir "" ""), - runTest "unclosed paren" $ - assertLeft "unclosed paren" (parseNix testBaseDir "" "(1"), - runTest "unclosed string" $ - assertLeft "unclosed string" (parseNix testBaseDir "" "\"hello"), - runTest "unclosed brace" $ - assertLeft "unclosed brace" (parseNix testBaseDir "" "{ a = 1;"), - runTest "missing semicolon" $ - assertLeft "missing semi" (parseNix testBaseDir "" "{ a = 1 }"), - runTest "unclosed bracket" $ - assertLeft "unclosed bracket" (parseNix testBaseDir "" "[ 1 2"), - runTest "unexpected token" $ - assertLeft "unexpected" (parseNix testBaseDir "" ")"), - -- A failure deep in a lambda body is reported where it happened: - -- a parsed lambda header commits, instead of backtracking into - -- the attr-set reading and reporting its early stumble (a real - -- error at line 410 of a nixpkgs file used to surface at line 2). - runTest "deep formals-lambda body error reports its own line" $ - assertRight "deep body" (syntaxErrorOf "{ a, b }:\n{\n x = 1;\n y = (;\n}") $ \err -> - assertEqual "error line" 4 (peLine err), - runTest "simple-lambda body error reports its own line" $ - assertRight "simple body" (syntaxErrorOf "x:\n(;") $ \err -> - assertEqual "error line" 2 (peLine err), - -- The empty attr set is a successful PREFIX parse of "{ }: body", - -- so without commitment the outer parser complained at the colon. - runTest "empty-formals lambda body error reports its own line" $ - assertRight "empty formals body" (syntaxErrorOf "{ }:\n(;") $ \err -> - assertEqual "error line" 2 (peLine err), - -- When neither reading parses, the deeper failure wins: the - -- malformed formal at column 7, not the attr-set branch's - -- stumble over the first comma at column 4. - runTest "a malformed formal beats the attr-set branch's earlier error" $ - assertRight "malformed formal" (syntaxErrorOf "{ a, b.c }: x") $ \err -> - assertEqual "deeper than the attr-set stumble" True ((peLine err, peCol err) > (1, 4)), - -- End-of-input failures carry no position and must rank as the - -- furthest a branch can get. - runTest "truncated lambda reports end of input" $ - assertRight "truncated lambda" (syntaxErrorOf "{ a, b }:") $ \err -> - assertEqual "end of input" True ("end of input" `T.isInfixOf` peMessage err) - ] - --- --------------------------------------------------------------------------- --- Tests: Parser integration --- --------------------------------------------------------------------------- - -testParserIntegration :: IO [Bool] -testParserIntegration = do - putStrLn "parser/integration" - sequence - [ runTest "shell.nix pattern" $ - assertRight "shell.nix" (parseNix testBaseDir "" "{ pkgs ? import {} }: pkgs.mkShell { buildInputs = [ pkgs.ghc ]; }") $ \case - ELambda {} -> Pass - other -> Fail ("expected ELambda, got: " <> T.pack (show other)), - runTest "let with multiple bindings" $ - assertParse - "multi-let" - "let x = 1; y = 2; in x + y" - ( ELet - [ NamedBinding (StaticKey "x") (ELit (NixInt 1)), - NamedBinding (StaticKey "y") (ELit (NixInt 2)) - ] - (EBinary OpAdd (EResolvedVar 0 0) (EResolvedVar 0 1)) - NoCaptureInfo - ), - runTest "nested attr set" $ - -- Normalization hoists a nested attrpath into nested literal sets - -- (upstream parser.y addAttr), so a.b.c = 1 parses like - -- a = { b = { c = 1; }; }. - assertParse - "nested attrs" - "{ a.b.c = 1; d = { e = 2; }; }" - ( EAttrs - False - [ NamedBinding - (StaticKey "a") - ( EAttrs - False - [ NamedBinding - (StaticKey "b") - (EAttrs False [NamedBinding (StaticKey "c") (ELit (NixInt 1))] NoCaptureInfo) - ] - NoCaptureInfo - ), - NamedBinding (StaticKey "d") (EAttrs False [NamedBinding (StaticKey "e") (ELit (NixInt 2))] NoCaptureInfo) - ] - NoCaptureInfo - ), - runTest "indented string" $ - assertRight "ind string" (parseNix testBaseDir "" "''hello''") $ \case - EIndStr _ -> Pass - other -> Fail ("expected EIndStr, got: " <> T.pack (show other)), - runTest "indented string escape is its own part" $ - assertRight "ind string esc" (parseNix testBaseDir "" "''a'''b''") $ \case - EIndStr [StrLit "a", StrEsc "''", StrLit "b"] -> Pass - other -> Fail ("expected literal, escape, literal, got: " <> T.pack (show other)), - -- Positional let/rec resolution tests - runTest "let inherit from outer lambda" $ - assertRight "let-inherit-lambda" (parseNix testBaseDir "" "x: let inherit x; in x") $ \case - -- x: let inherit x; in x - -- The lambda formal x is at level 0, index 0. - -- The let scope is level 0 (for the let body). - -- The inherited variable resolves against the outer (lambda) - -- scope, one level up from the let it is evaluated in. - -- The body x resolves to level 0, index 0 (the let scope). - ELambda _ (ELet [Inherit "x" _rhsExpr] (EResolvedVar 0 0) _) _ -> Pass - other -> Fail ("expected ELambda with let-inherit, got: " <> T.pack (show other)), - runTest "nested lambda in let" $ - assertEval - "let-nested-lambda" - "let f = x: x + 1; g = y: f y; in g 5" - (VInt 6), - runTest "rec attrs positional resolution" $ - assertEval - "rec-positional" - "let s = rec { a = 1; b = a + 1; }; in s.b" - (VInt 2) - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 1 - Trivial pure builtins + constants --- --------------------------------------------------------------------------- - -testBatch1 :: IO [Bool] -testBatch1 = do - putStrLn "eval/builtins-batch1" - sequence - [ -- isPath - runTest "isPath true" $ - assertEval "isPath-t" "builtins.isPath ./foo" (VBool True), - runTest "isPath false" $ - assertEval "isPath-f" "builtins.isPath \"foo\"" (VBool False), - -- ceil - runTest "ceil float" $ - assertEval "ceil" "builtins.ceil 1.2" (VInt 2), - runTest "ceil int passthrough" $ - assertEval "ceil-int" "builtins.ceil 5" (VInt 5), - runTest "ceil negative" $ - assertEval "ceil-neg" "builtins.ceil (- 1.7)" (VInt (-1)), - runTest "ceil type error" $ - assertEvalFail "ceil-err" "builtins.ceil \"hi\"", - -- floor - runTest "floor float" $ - assertEval "floor" "builtins.floor 1.7" (VInt 1), - runTest "floor int passthrough" $ - assertEval "floor-int" "builtins.floor 5" (VInt 5), - runTest "floor negative" $ - assertEval "floor-neg" "builtins.floor (- 1.2)" (VInt (-2)), - -- NaN, infinity, and out-of-range floats are eval errors (Nix 2.24), - -- not whatever Int64 Haskell's unchecked conversion produces. - runTest "ceil NaN fails" $ - assertEvalFail "ceil-nan" "builtins.ceil ((1.0e308 * 10) * 0.0)", - runTest "floor infinity fails" $ - assertEvalFail "floor-inf" "builtins.floor (1.0e308 * 10)", - runTest "ceil out of integer range fails" $ - assertEvalFail "ceil-range" "builtins.ceil 1.0e300", - -- seq - runTest "seq returns second" $ - assertEval "seq" "builtins.seq 1 42" (VInt 42), - -- trace - runTest "trace returns second" $ - assertEval "trace" "builtins.trace \"msg\" 42" (VInt 42), - -- unsafeDiscardStringContext - runTest "discardContext" $ - assertEval "discard" "builtins.unsafeDiscardStringContext \"hello\"" (mkStr "hello"), - -- unsafeDiscardOutputDependency - runTest "discardOutputDep" $ - assertEval "discardOut" "builtins.unsafeDiscardOutputDependency \"hello\"" (mkStr "hello"), - -- baseNameOf - runTest "baseNameOf string" $ - assertEval "baseName-str" "builtins.baseNameOf \"/foo/bar/baz\"" (mkStr "baz"), - runTest "baseNameOf path" $ - assertEval "baseName-path" "builtins.baseNameOf ./foo/bar" (mkStr "bar"), - runTest "baseNameOf no slash" $ - assertEval "baseName-flat" "builtins.baseNameOf \"filename\"" (mkStr "filename"), - runTest "baseNameOf type error" $ - assertEvalFail "baseName-err" "builtins.baseNameOf 42", - -- dirOf - runTest "dirOf string" $ - assertEval "dirOf-str" "builtins.dirOf \"/foo/bar/baz\"" (mkStr "/foo/bar"), - runTest "dirOf no slash" $ - assertEval "dirOf-flat" "builtins.dirOf \"filename\"" (mkStr "."), - runTest "dirOf root-level path" $ - assertEval "dirOf-root" "builtins.dirOf \"/foo\"" (mkStr "/"), - -- Path VALUES arrive native-spelled when eval's base dir is a - -- native path (the CLI case); the path-operand splits must be - -- separator-aware. The forward-slash tests above use a '/' - -- base and cannot see this. - runTestM "baseNameOf on a native-based path value" $ do - cwd <- Dir.getCurrentDirectory - result <- evalNixIO cwd "builtins.baseNameOf ./regression-name.nix" - pure $ case result of - Right v - | v == mkStr "regression-name.nix" -> Pass - | otherwise -> Fail ("wrong basename: " <> T.pack (show v)) - Left err -> Fail ("eval failed: " <> T.pack (show err)), - -- The path-value spec: absolute, lexically canonical, and - -- slash-spelled regardless of the base dir's native spelling. - runTestM "path values are slash-canonical from a native base" $ do - cwd <- Dir.getCurrentDirectory - result <- evalNixIO cwd "toString ./spec-name.nix" - let expected = mkStr (T.replace "\\" "/" (T.pack cwd) <> "/spec-name.nix") - pure $ case result of - Right v - | v == expected -> Pass - | otherwise -> Fail ("wrong spelling: " <> T.pack (show v)) - Left err -> Fail ("eval failed: " <> T.pack (show err)), - runTest "canonPathValue folds platform separators only" $ - let folded = canonPathValue "C:\\a\\.\\b" - expectedByPlatform = - if SI.os == "mingw32" - then "C:/a/b" -- '\\' is a separator here and folds - else "C:\\a\\.\\b" -- '\\' is a file-name character, preserved - in assertEqual "platform fold" expectedByPlatform folded, - runTestM "dirOf on a native-based path value" $ do - cwd <- Dir.getCurrentDirectory - dirResult <- evalNixIO cwd "builtins.dirOf ./sub/regression-name.nix" - parentResult <- evalNixIO cwd "./sub" - pure $ - if dirResult == parentResult - then Pass - else - Fail - ( "dirOf mismatch: " - <> T.pack (show dirResult) - <> " vs " - <> T.pack (show parentResult) - ), - -- appendContext: a key that is not a store path must refuse, as - -- upstream does - a fabricated identity would flow into - -- derivation inputs. - runTest "appendContext rejects a non-store-path key" $ - assertEvalFail - "appendContext-badkey" - "builtins.appendContext \"x\" { \"not-a-store-path\" = { path = true; }; }", - runTest "appendContext accepts a store-path key" $ - assertEval - "appendContext-ok" - "if (builtins.appendContext \"x\" { \"/nix/store/00000000000000000000000000000000-y\" = { path = true; }; }) == \"x\" then \"ok\" else \"no\"" - (mkStr "ok"), - -- storePath: the hash component is charset-validated like every - -- other store-path parse boundary ('E' is outside nix-base32), and - -- refused with upstream's StorePath constructor text (path.cc at - -- 2.24.9). - runTest "storePath rejects a non-base32 hash" $ - assertEvalError - "storePath-badhash" - "builtins.storePath \"/nix/store/EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE-x\"" - "store path 'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE-x' contains illegal base-32 character 'E'", - runTest "storePath refuses a path outside the store" $ - assertEvalError "storePath-outside" "builtins.storePath \"/x\"" "path '/x' is not in the Nix store", - runTest "storePath refuses the store directory itself" $ - assertEvalError "storePath-storedir" "builtins.storePath \"/nix/store/\"" "path '/nix/store' is not in the Nix store", - runTest "storePath refuses a component too short for a hash" $ - assertEvalError "storePath-short" "builtins.storePath \"/nix/store/x\"" "'x' is too short to be a valid store path", - runTest "storePath refuses an empty name" $ - assertEvalError "storePath-empty-name" "builtins.storePath \"/nix/store/00000000000000000000000000000000-\"" "path '00000000000000000000000000000000-' is not a valid store path: name must not be empty", - runTest "storePath refuses an illegal name" $ - assertEvalError "storePath-bad-name" "builtins.storePath \"/nix/store/00000000000000000000000000000000-a b\"" "path '00000000000000000000000000000000-a b' is not a valid store path: name 'a b' contains illegal character ' '", - runTest "storePath accepts a valid store path" $ - assertEval - "storePath-ok" - "if (builtins.storePath \"/nix/store/00000000000000000000000000000000-x\") == \"/nix/store/00000000000000000000000000000000-x\" then \"ok\" else \"no\"" - (mkStr "ok"), - runTest "dirOf root" $ - assertEval "dirOf-slash" "builtins.dirOf \"/\"" (mkStr "/"), - -- concatLists - runTest "concatLists basic" $ - assertEval "concatLists" "builtins.concatLists [ [ 1 2 ] [ 3 ] [ 4 5 ] ] == [ 1 2 3 4 5 ]" (VBool True), - runTest "concatLists empty" $ - assertEval "concatLists-empty" "builtins.concatLists [ ]" (VList emptyCList), - runTest "concatLists type error" $ - assertEvalFail "concatLists-err" "builtins.concatLists [ 1 2 ]", - -- lessThan - runTest "lessThan true" $ - assertEval "lt-t" "builtins.lessThan 1 2" (VBool True), - runTest "lessThan false" $ - assertEval "lt-f" "builtins.lessThan 2 1" (VBool False), - runTest "lessThan strings" $ - assertEval "lt-str" "builtins.lessThan \"a\" \"b\"" (VBool True), - -- List < decides at the first UNEQUAL pair, as upstream: a pair - -- where < holds in neither direction (NaN) decides False rather - -- than being skipped as equal. - -- Distinct NaN values: a shared binding would be skipped as equal - -- via reference identity, which upstream's eqValues also does. - runTest "list compare decides at the first unequal pair" $ - assertEval "lt-list-nan" "let inf = 1.0e308 * 10; in [ (inf - inf) 1 ] < [ (inf - inf) 2 ]" (VBool False), - runTest "list compare skips equal prefixes" $ - assertEval "lt-list-prefix" "[ 1 2 ] < [ 1 3 ]" (VBool True), - -- Constants - runTest "storeDir" $ - assertEval "storeDir" "builtins.storeDir" (mkStr defaultStoreDirText), - runTest "nixVersion" $ - assertEval "nixVersion" "builtins.nixVersion" (mkStr "2.24.0"), - runTest "langVersion" $ - assertEval "langVersion" "builtins.langVersion" (VInt 6), - runTest "nixPath" $ - assertEval "nixPath" "builtins.nixPath" (VList emptyCList) - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 2 - Arithmetic + bitwise builtins --- --------------------------------------------------------------------------- - -testBatch2 :: IO [Bool] -testBatch2 = do - putStrLn "eval/builtins-batch2" - sequence - [ -- add - runTest "add ints" $ - assertEval "add-int" "builtins.add 3 4" (VInt 7), - runTest "add int+float" $ - assertEval "add-mixed" "builtins.add 1 2.5" (VFloat 3.5), - runTest "add type error" $ - assertEvalFail "add-err" "builtins.add \"a\" 1", - -- sub - runTest "sub ints" $ - assertEval "sub-int" "builtins.sub 10 3" (VInt 7), - runTest "sub float" $ - assertEval "sub-float" "builtins.sub 5.5 2.0" (VFloat 3.5), - -- mul - runTest "mul ints" $ - assertEval "mul-int" "builtins.mul 3 4" (VInt 12), - runTest "mul float" $ - assertEval "mul-float" "builtins.mul 2 3.0" (VFloat 6.0), - -- div - runTest "div ints" $ - assertEval "div-int" "builtins.div 10 3" (VInt 3), - runTest "div float" $ - assertEval "div-float" "builtins.div 7.0 2.0" (VFloat 3.5), - runTest "div by zero" $ - assertEvalFail "div-zero" "builtins.div 1 0", - -- bitAnd - runTest "bitAnd" $ - assertEval "bitAnd" "builtins.bitAnd 12 10" (VInt 8), - runTest "bitAnd type error" $ - assertEvalFail "bitAnd-err" "builtins.bitAnd 1.0 2", - -- bitOr - runTest "bitOr" $ - assertEval "bitOr" "builtins.bitOr 12 10" (VInt 14), - -- bitXor - runTest "bitXor" $ - assertEval "bitXor" "builtins.bitXor 12 10" (VInt 6) - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 3 - Attrset higher-order builtins --- --------------------------------------------------------------------------- - -testBatch3 :: IO [Bool] -testBatch3 = do - putStrLn "eval/builtins-batch3" - let functionArgsError = "'functionArgs' requires a function" - sequence - [ -- mapAttrs - runTest "mapAttrs basic" $ - assertEval "mapAttrs" "(builtins.mapAttrs (name: val: val + 1) { a = 1; b = 2; }).a" (VInt 2), - runTest "mapAttrs name usage" $ - assertEval "mapAttrs-name" "(builtins.mapAttrs (name: val: name) { a = 1; }).a" (mkStr "a"), - runTest "mapAttrs type error" $ - assertEvalFail "mapAttrs-err" "builtins.mapAttrs (n: v: v) [ 1 ]", - runTest "mapAttrs lazy" $ - assertEval "mapAttrs-lazy" "let s = builtins.mapAttrs (k: v: if k == \"a\" then v else throw \"boom\") { a = 1; b = 2; }; in s.a" (VInt 1), - -- functionArgs - runTest "functionArgs set pattern" $ - assertEval "funcArgs" "(builtins.functionArgs ({ a, b ? 1 }: a)).b" (VBool True), - runTest "functionArgs no default" $ - assertEval "funcArgs-nodef" "(builtins.functionArgs ({ a, b ? 1 }: a)).a" (VBool False), - runTest "functionArgs simple lambda" $ - assertEval "funcArgs-simple" "builtins.functionArgs (x: x)" (VAttrs (attrSetFromMap Map.empty)), - -- Upstream's prim_functionArgs message (primops.cc at 2.24.9), the - -- same whatever the argument, and tryEval does not catch it. - runTest "functionArgs of a set is upstream's error" $ - assertEvalError "funcArgs-set" "builtins.functionArgs {}" functionArgsError, - runTest "functionArgs of a path is upstream's error" $ - assertEvalError "funcArgs-path" "builtins.functionArgs ./foo" functionArgsError, - runTest "functionArgs of an integer is upstream's error" $ - assertEvalError "funcArgs-int" "builtins.functionArgs 42" functionArgsError, - runTest "functionArgs of a string is upstream's error" $ - assertEvalError "funcArgs-string" "builtins.functionArgs \"s\"" functionArgsError, - runTest "tryEval does not catch the functionArgs error" $ - assertEvalError "funcArgs-tryEval" "builtins.tryEval (builtins.functionArgs {})" functionArgsError, - -- The builtins set is observable (hasAttr/attrNames), so it must - -- match upstream's primop set exactly: no mod/min/max/ - -- setFunctionArgs extensions (nixpkgs lib defines those in Nix), - -- and functionArgs never consults __functionArgs - a functor set - -- is an error, as upstream throws (lib.functionArgs unwraps - -- functor sets itself before reaching the builtin). - runTest "no invented arithmetic builtins" $ - assertEval - "no-fake-builtins" - "!(builtins ? mod) && !(builtins ? min) && !(builtins ? max) && !(builtins ? setFunctionArgs)" - (VBool True), - runTest "functionArgs rejects functor sets" $ - assertEvalFail - "funcArgs-functor-err" - "builtins.functionArgs { __functor = self: x: x; __functionArgs = { a = false; }; }", - -- zipAttrsWith - runTest "zipAttrsWith basic" $ - assertEval - "zipAttrs" - "(builtins.zipAttrsWith (name: vals: builtins.head vals) [ { a = 1; } { a = 2; b = 3; } ]).b" - (VInt 3), - runTest "zipAttrsWith collect" $ - assertEval - "zipAttrs-collect" - "builtins.length (builtins.zipAttrsWith (name: vals: vals) [ { a = 1; } { a = 2; } ]).a" - (VInt 2) - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 4 - String operations --- --------------------------------------------------------------------------- - -testBatch4 :: IO [Bool] -testBatch4 = do - putStrLn "eval/builtins-batch4" - sequence - [ -- replaceStrings - runTest "replaceStrings basic" $ - assertEval "replace" "builtins.replaceStrings [ \"o\" ] [ \"0\" ] \"foobar\"" (mkStr "f00bar"), - runTest "replaceStrings multi" $ - assertEval "replace-multi" "builtins.replaceStrings [ \"a\" \"b\" ] [ \"A\" \"B\" ] \"abc\"" (mkStr "ABc"), - runTest "replaceStrings empty from" $ - assertEval "replace-empty" "builtins.replaceStrings [ \"\" ] [ \"x\" ] \"ab\"" (mkStr "xaxbx"), - runTest "replaceStrings no match" $ - assertEval "replace-nomatch" "builtins.replaceStrings [ \"z\" ] [ \"Z\" ] \"abc\"" (mkStr "abc"), - -- Match-gated forcing: an unmatched replacement is never evaluated. - runTest "replaceStrings never forces an unmatched replacement" $ - assertEval "replace-lazy" "builtins.replaceStrings [ \"z\" ] [ (builtins.throw \"unused\") ] \"abc\"" (mkStr "abc"), - -- compareVersions - runTest "compareVersions equal" $ - assertEval "cmpVer-eq" "builtins.compareVersions \"1.2.3\" \"1.2.3\"" (VInt 0), - runTest "compareVersions less" $ - assertEval "cmpVer-lt" "builtins.compareVersions \"1.2\" \"1.3\"" (VInt (-1)), - runTest "compareVersions greater" $ - assertEval "cmpVer-gt" "builtins.compareVersions \"2.0\" \"1.9\"" (VInt 1), - runTest "compareVersions type error" $ - assertEvalFail "cmpVer-err" "builtins.compareVersions 1 2", - runTest "compareVersions treats - as a separator" $ - assertEval "cmpVer-dash" "builtins.compareVersions \"1.0-2\" \"1.0.2\"" (VInt 0), - -- splitVersion - runTest "splitVersion basic" $ - assertEval "splitVer" "builtins.splitVersion \"1.2.3\" == [ \"1\" \"2\" \"3\" ]" (VBool True), - runTest "splitVersion pre" $ - assertEval "splitVer-pre" "builtins.splitVersion \"1.2pre\" == [ \"1\" \"2\" \"pre\" ]" (VBool True), - runTest "splitVersion type error" $ - assertEvalFail "splitVer-err" "builtins.splitVersion 42", - -- parseDrvName - runTest "parseDrvName basic" $ - assertEval "parseDrv" "(builtins.parseDrvName \"hello-1.2.3\").name" (mkStr "hello"), - runTest "parseDrvName version" $ - assertEval "parseDrv-ver" "(builtins.parseDrvName \"hello-1.2.3\").version" (mkStr "1.2.3"), - runTest "parseDrvName no version" $ - assertEval "parseDrv-nover" "(builtins.parseDrvName \"hello\").version" (mkStr ""), - runTest "parseDrvName type error" $ - assertEvalFail "parseDrv-err" "builtins.parseDrvName 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 5 - Serialization + hashing --- --------------------------------------------------------------------------- - -testBatch5 :: IO [Bool] -testBatch5 = do - putStrLn "eval/builtins-batch5" - sequence - [ -- toJSON - runTest "toJSON int" $ - assertEval "toJSON-int" "builtins.toJSON 42" (mkStr "42"), - runTest "toJSON string" $ - assertEval "toJSON-str" "builtins.toJSON \"hello\"" (mkStr "\"hello\""), - runTest "toJSON null" $ - assertEval "toJSON-null" "builtins.toJSON null" (mkStr "null"), - runTest "toJSON bool" $ - assertEval "toJSON-bool" "builtins.toJSON true" (mkStr "true"), - runTest "toJSON list" $ - assertEval "toJSON-list" "builtins.toJSON [ 1 2 3 ]" (mkStr "[1,2,3]"), - runTest "toJSON attrs" $ - assertEval "toJSON-attrs" "builtins.toJSON { a = 1; }" (mkStr "{\"a\":1}"), - runTest "toJSON lambda error" $ - assertEvalFail "toJSON-fn" "builtins.toJSON (x: x)", - -- fromJSON - runTest "fromJSON int" $ - assertEval "fromJSON-int" "builtins.fromJSON \"42\"" (VInt 42), - runTest "fromJSON string" $ - assertEval "fromJSON-str" "builtins.fromJSON \"\\\"hello\\\"\"" (mkStr "hello"), - runTest "fromJSON null" $ - assertEval "fromJSON-null" "builtins.fromJSON \"null\"" VNull, - runTest "fromJSON bool" $ - assertEval "fromJSON-bool" "builtins.fromJSON \"true\"" (VBool True), - runTest "fromJSON array" $ - assertEval "fromJSON-arr" "builtins.length (builtins.fromJSON \"[1,2,3]\")" (VInt 3), - runTest "fromJSON object" $ - assertEval "fromJSON-obj" "(builtins.fromJSON \"{\\\"a\\\": 1}\").a" (VInt 1), - runTest "fromJSON roundtrip" $ - assertEval "fromJSON-rt" "let x = builtins.fromJSON (builtins.toJSON { a = 1; b = [ 2 3 ]; }); in x.a == 1 && x.b == [ 2 3 ]" (VBool True), - runTest "fromJSON invalid" $ - assertEvalFail "fromJSON-bad" "builtins.fromJSON \"not json\"", - -- The integer range as json-to-value.cc has it at 2.25 and after. - runTest "fromJSON reads the largest int" $ - assertEval "fromJSON-int-max" "builtins.fromJSON \"9223372036854775807\"" (VInt 9223372036854775807), - runTest "fromJSON reads the smallest int" $ - assertEval "fromJSON-int-min" "builtins.fromJSON \"-9223372036854775808\"" (VInt (-9223372036854775808)), - runTest "fromJSON refuses one past the largest int" $ - assertEvalError "fromJSON-past-int" "builtins.fromJSON \"9223372036854775808\"" "unsigned json number 9223372036854775808 outside of Nix integer range", - runTest "fromJSON refuses the largest unsigned" $ - assertEvalError "fromJSON-uint-max" "builtins.fromJSON \"18446744073709551615\"" "unsigned json number 18446744073709551615 outside of Nix integer range", - runTest "fromJSON refuses an unsigned number inside a list" $ - assertEvalError "fromJSON-uint-list" "builtins.fromJSON \"[1,[18446744073709551615]]\"" "unsigned json number 18446744073709551615 outside of Nix integer range", - runTest "fromJSON refuses an unsigned number inside a set" $ - assertEvalError "fromJSON-uint-set" "builtins.fromJSON ''{\"a\":18446744073709551615}''" "unsigned json number 18446744073709551615 outside of Nix integer range", - runTest "fromJSON names the first such number in the document, not in key order" $ - assertEvalError "fromJSON-uint-order" "builtins.fromJSON ''{\"b\":18446744073709551615,\"a\":9223372036854775808}''" "unsigned json number 18446744073709551615 outside of Nix integer range", - runTest "fromJSON refuses such a number ahead of a later syntax error" $ - assertEvalError "fromJSON-uint-syntax" "builtins.fromJSON \"[18446744073709551615,nonsense\"" "unsigned json number 18446744073709551615 outside of Nix integer range", - -- nlohmann's grammar (json-to-value.cc at 2.24.9), strict RFC 8259: - -- each case below is refused or read as nix-instantiate reads it. - runTest "fromJSON reads the backspace and form feed escapes" $ - assertEval "fromJSON-bf" "builtins.fromJSON ''\"a\\bb\\fc\"''" (mkStr "a\bb\fc"), - runTest "fromJSON reads a surrogate pair" $ - assertEval "fromJSON-pair" "builtins.fromJSON ''\"\\ud83d\\ude00\"''" (mkStr "\128512"), - runTest "fromJSON skips a leading byte order mark" $ - assertEval "fromJSON-bom" "builtins.fromJSON \"\65279 1\"" (VInt 1), - runTest "fromJSON refuses an unterminated string" $ - assertEvalError "fromJSON-unterminated" "builtins.fromJSON ''\"abc''" "unterminated string", - runTest "fromJSON refuses a trailing comma in an array" $ - assertEvalError "fromJSON-array-comma" "builtins.fromJSON \"[1,]\"" "unexpected ']', expected a JSON value", - runTest "fromJSON refuses a trailing comma in an object" $ - assertEvalError "fromJSON-object-comma" "builtins.fromJSON ''{\"a\":1,}''" "unexpected '}' in an object, expected a member name", - runTest "fromJSON refuses a leading zero" $ - assertEvalError "fromJSON-leading-zero" "builtins.fromJSON \"01\"" "unexpected content after the JSON value: '1'", - runTest "fromJSON refuses a raw control character in a string" $ - assertEvalError "fromJSON-raw-tab" "builtins.fromJSON \"\\\"a\\tb\\\"\"" "control character U+0009 must be escaped", - runTest "fromJSON refuses a \\u escape short of four hex digits" $ - assertEvalError "fromJSON-short-u" "builtins.fromJSON ''\"\\u12\"''" "invalid \\u escape '12\"'", - runTest "fromJSON refuses a lone high surrogate" $ - assertEvalError "fromJSON-lone-high" "builtins.fromJSON ''\"\\ud800\"''" "a high surrogate must be followed by a low surrogate", - runTest "fromJSON refuses a lone low surrogate" $ - assertEvalError "fromJSON-lone-low" "builtins.fromJSON ''\"\\udc00\"''" "a low surrogate must follow a high surrogate", - runTest "fromJSON refuses an unknown escape" $ - assertEvalError "fromJSON-bad-escape" "builtins.fromJSON ''\"a\\x\"''" "invalid escape \\x", - runTest "fromJSON refuses a number past the double range" $ - assertEvalError "fromJSON-overflow" "builtins.fromJSON \"1e400\"" "number overflow parsing '1e400'", - runTest "fromJSON refuses whitespace JSON does not define" $ - assertEvalError "fromJSON-nbsp" "builtins.fromJSON \"\160 1\"" "unexpected '\160 1', expected a JSON value", - runTest "fromJSON refuses a vertical tab around a value" $ - assertEvalError "fromJSON-vt" "builtins.fromJSON \"\v1\"" "unexpected '\v1', expected a JSON value", - -- hashString - runTest "hashString sha256" $ - assertEval "hash-sha256" "builtins.hashString \"sha256\" \"hello\"" (mkStr "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824"), - runTest "hashString md5" $ - assertEval "hash-md5" "builtins.hashString \"md5\" \"hello\"" (mkStr "5d41402abc4b2a76b9719d911017c592"), - runTest "hashString sha1" $ - assertEval "hash-sha1" "builtins.hashString \"sha1\" \"hello\"" (mkStr "aaf4c61ddcc5e8a2dabede0f3b482cd9aea9434d"), - runTest "hashString unknown algo" $ - assertEvalFail "hash-bad" "builtins.hashString \"sha999\" \"hello\"", - runTest "hashString type error" $ - assertEvalFail "hash-err" "builtins.hashString \"sha256\" 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 6 - tryEval + deepSeq --- --------------------------------------------------------------------------- - -testBatch6 :: IO [Bool] -testBatch6 = do - putStrLn "eval/builtins-batch6" - sequence - [ -- tryEval success - runTest "tryEval success" $ - assertEval "tryEval-ok" "(builtins.tryEval 42).value" (VInt 42), - runTest "tryEval success flag" $ - assertEval "tryEval-flag" "(builtins.tryEval 42).success" (VBool True), - -- tryEval failure - runTest "tryEval catches throw" $ - assertEval "tryEval-throw" "(builtins.tryEval (builtins.throw \"boom\")).success" (VBool False), - runTest "tryEval failure value" $ - assertEval "tryEval-fval" "(builtins.tryEval (builtins.throw \"boom\")).value" (VBool False), - -- tryEval catches ONLY throw/assert (upstream ThrownError/ - -- AssertionError); type errors and missing attrs escape it. - runTest "tryEval catches failed assert" $ - assertEval "tryEval-assert" "(builtins.tryEval (assert false; 1)).success" (VBool False), - runTest "tryEval does not catch a type error" $ - assertEvalFail "tryEval-tyerr" "(builtins.tryEval ({} + [])).success", - runTest "tryEval does not catch a missing attribute" $ - assertEvalFail "tryEval-noattr" "(builtins.tryEval ({ a = 1; }.b)).success", - runTest "tryEval catches a throw nested under forcing" $ - assertEval "tryEval-deep-throw" "(builtins.tryEval (builtins.deepSeq [ (builtins.throw \"x\") ] 1)).success" (VBool False), - -- tryEval passed as a VALUE (comparator/element positions) instead - -- of applied syntactically: every application path must keep the - -- catch around the argument's evaluation, and none may leak the - -- old internal 'unreachable' dispatch error. - runTest "tryEval as sort comparator fails like upstream" $ - case evalNix "builtins.sort builtins.tryEval [ 1 2 ]" of - Left err - | "unreachable" `T.isInfixOf` err -> Fail ("internal error leaked: " <> err) - | otherwise -> Pass - Right v -> Fail ("expected a boolean-coercion failure, got " <> T.pack (show v)), - runTest "tryEval via map catches a throwing element" $ - assertEval - "tryEval-map" - "(builtins.elemAt (builtins.map builtins.tryEval [ (builtins.throw \"m\") ]) 0).success" - (VBool False), - runTest "tryEval via map success-wraps a clean element" $ - assertEval - "tryEval-map-ok" - "(builtins.elemAt (builtins.map builtins.tryEval [ 7 ]) 0).value" - (VInt 7), - runTest "tryEval through filter catches the element throw" $ - case evalNix "builtins.filter builtins.tryEval [ (builtins.throw \"leaked\") ]" of - Left err - | "leaked" `T.isInfixOf` err -> Fail ("throw escaped tryEval: " <> err) - | otherwise -> Pass - Right v -> Fail ("expected a boolean-coercion failure, got " <> T.pack (show v)), - runTest "functor returning tryEval keeps the catch" $ - assertEval - "tryEval-functor" - "(({ __functor = self: builtins.tryEval; }) (builtins.throw \"f\")).success" - (VBool False), - -- deepSeq - runTest "deepSeq returns second" $ - assertEval "deepSeq" "builtins.deepSeq [ 1 2 3 ] 42" (VInt 42), - runTest "deepSeq forces nested" $ - assertEvalFail "deepSeq-err" "builtins.deepSeq [ (builtins.throw \"boom\") ] 42", - runTest "deepSeq forces attrs" $ - assertEvalFail "deepSeq-attr" "builtins.deepSeq { a = builtins.throw \"boom\"; } 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Batch 7 - genericClosure --- --------------------------------------------------------------------------- - -testBatch7 :: IO [Bool] -testBatch7 = do - putStrLn "eval/builtins-batch7" - sequence - [ runTest "genericClosure basic" $ - assertEval - "closure-basic" - "builtins.length (builtins.genericClosure { startSet = [ { key = 1; } ]; operator = item: [ ]; })" - (VInt 1), - runTest "genericClosure expansion" $ - assertEval - "closure-expand" - "builtins.length (builtins.genericClosure { startSet = [ { key = 1; next = 2; } ]; operator = item: if item.next == 0 then [ ] else [ { key = item.next; next = 0; } ]; })" - (VInt 2), - runTest "genericClosure dedup" $ - assertEval - "closure-dedup" - "builtins.length (builtins.genericClosure { startSet = [ { key = 1; } { key = 1; } ]; operator = item: [ ]; })" - (VInt 1), - runTest "genericClosure missing startSet" $ - assertEvalFail "closure-nostart" "builtins.genericClosure { operator = x: [ ]; }", - runTest "genericClosure type error" $ - assertEvalFail "closure-tyerr" "builtins.genericClosure 42" - ] - --- --------------------------------------------------------------------------- --- Tests: import and IO builtins (pure) --- --------------------------------------------------------------------------- - -testImportPure :: IO [Bool] -testImportPure = do - putStrLn "eval/import-pure" - sequence - [ runTest "import errors in pure mode" $ - assertEvalFail "import-pure" "import ./foo.nix", - runTest "builtins.typeOf import is lambda" $ - assertEval "typeof-import" "builtins.typeOf import" (mkStr "lambda"), - runTest "pathExists returns false in pure mode" $ - assertEval "pathExists-pure" "builtins.pathExists ./nonexistent" (VBool False), - runTest "readFile errors in pure mode" $ - assertEvalFail "readFile-pure" "builtins.readFile ./foo.nix", - runTest "readDir errors in pure mode" $ - assertEvalFail "readDir-pure" "builtins.readDir ./some-dir" - ] - --- --------------------------------------------------------------------------- --- Tests: import and IO builtins (IO) --- --------------------------------------------------------------------------- - --- | Parse and evaluate Nix source using the IO evaluator. --- | The per-suite temp store 'evalNixIO' evaluates against, exposed so --- a test inspecting materialized trees resolves the same directory. -evalNixIOStoreDir :: IO StoreDir -evalNixIOStoreDir = do - tmpBase <- getTemporaryDirectory - pure (StoreDir (tmpBase "nova-nix-test-eval-store")) - --- | IO eval against a per-suite temp store, so no test needs a real, --- writable platform store root: eval-time store writes land under the --- temp directory, and the suite runs everywhere without provisioning. -evalNixIO :: FilePath -> Text -> IO (Either Text NixValue) -evalNixIO baseDir source = do - storeDir <- evalNixIOStoreDir - evalNixIOStore storeDir baseDir source - --- | 'evalNixIO' keeping a failure whole, its lines of context included. -evalNixIOTraced :: FilePath -> Text -> IO (Either EvalFailure NixValue) -evalNixIOTraced baseDir source = case parseNix baseDir "" source of - Left err -> pure (Left (EvalFailure [] (T.pack (show err)))) - Right expr -> do - storeDir <- evalNixIOStoreDir - st <- newEvalState storeDir baseDir - runEvalIOTraced st (eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr) - --- | IO eval of a derivation expression to the 'Derivation' the session --- recorded for it: forcing the expression's @drvPath@ runs derivationStrict, --- which records the @.drv@ under that path, and the recipe is read back the --- way the build driver reads it. Only the IO evaluator keeps the record. -evalDerivationIO :: FilePath -> Text -> IO (Either Text Derivation) -evalDerivationIO baseDir source = case parseNix baseDir "" ("(" <> source <> ").drvPath") of - Left err -> pure (Left (T.pack (show err))) - Right expr -> do - storeDir <- evalNixIOStoreDir - st <- newEvalState storeDir baseDir - runEvalIO st $ do - pathVal <- eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr - case pathVal of - VStr pathBytes _ -> do - recorded <- lookupSessionDrv (bytesText pathBytes) - maybe (throwEvalError ("no .drv was recorded for " <> bytesText pathBytes)) pure recorded - other -> throwEvalError ("expected a drvPath string, got " <> typeName other) - --- | Run a named IO eval test - single label, no double-wrapping. -runTestIO :: Text -> FilePath -> Text -> NixValue -> IO Bool -runTestIO label baseDir source expected = do - result <- evalNixIO baseDir source - runTest label $ assertRight label result $ \actual -> - assertEqual label expected actual - --- | Run a named IO eval test that should fail. -runTestIOFail :: Text -> FilePath -> Text -> IO Bool -runTestIOFail label baseDir source = do - result <- evalNixIO baseDir source - runTest label $ assertLeft label result - --- | Quoted path literal for embedding absolute paths in Nix source. -nixQuotedPath :: FilePath -> Text -nixQuotedPath p = T.pack (show p) - --- | The name, builder and system of a derivation, read as upstream's --- derivationStrict reads them (primops.cc at 2.24.9): the name with --- forceStringNoCtx, the builder and system as their environment entries --- coerce, each checked for presence once all are read. Every expected --- message is nix-instantiate 2.24.9's final error line. -testDerivationFields :: IO [Bool] -testDerivationFields = do - putStrLn "eval/derivation-fields" - let drvWith fields = "(derivation { " <> fields <> " }).drvPath" - plain = "system = \"x\"; builder = \"/bin/sh\";" - withDep body = "let d = derivation { name = \"d\"; " <> plain <> " }; in " <> body - fails label source expected = runTest label (assertEvalError label source expected) - depOut = "/nix/store/simq0c07kvm2wyvasl0k1f619wishj4y-d" - depDrv = "wwk71dy0w17kn5spjd8hbsrk6520xs11-d.drv" - sequence - [ fails "a name that is not a string is refused" (drvWith ("name = 1; " <> plain)) "expected a string but found an integer: 1", - fails "a name with an output's context names it" (withDep (drvWith ("name = \"x${d}\"; " <> plain))) ("the string 'x" <> depOut <> "' is not allowed to refer to a store path (such as '!out!" <> depDrv <> "')"), - fails "a name with a drvPath's context names it" (withDep (drvWith ("name = \"x${d.drvPath}\"; " <> plain))) ("the string 'x/nix/store/" <> depDrv <> "' is not allowed to refer to a store path (such as '=" <> depDrv <> "')"), - fails "a plain path comes first among a name's context" (withDep (drvWith ("name = builtins.appendContext \"x${d}\" { \"/nix/store/00000000000000000000000000000000-a\" = { path = true; }; }; " <> plain))) ("the string 'x" <> depOut <> "' is not allowed to refer to a store path (such as '00000000000000000000000000000000-a')"), - fails "all outputs come before one among a name's context" (withDep (drvWith ("name = \"x${d}${d.drvPath}\"; " <> plain))) ("the string 'x" <> depOut <> "/nix/store/" <> depDrv <> "' is not allowed to refer to a store path (such as '=" <> depDrv <> "')"), - fails "an absent name is getAttr's error" (drvWith plain) "attribute 'name' missing", - fails "an absent builder is refused" (drvWith "name = \"a\"; system = \"x\";") "required attribute 'builder' missing", - fails "an empty builder is refused as absent" (drvWith "name = \"a\"; system = \"x\"; builder = \"\";") "required attribute 'builder' missing", - fails "an empty system is refused as absent" (drvWith "name = \"a\"; system = \"\"; builder = \"/bin/sh\";") "required attribute 'system' missing", - fails "the builder is checked before the system" (drvWith "name = \"a\";") "required attribute 'builder' missing", - fails "an empty name is invalid" (drvWith ("name = \"\"; " <> plain)) "invalid derivation name: name must not be empty. Please pass a different 'name'.", - fails "a dot name is invalid" (drvWith ("name = \".\"; " <> plain)) "invalid derivation name: name '.' is not valid. Please pass a different 'name'.", - fails "a dot component is invalid" (drvWith ("name = \".-a\"; " <> plain)) "invalid derivation name: name '.-a' is not valid: first dash-separated component must not be '.'. Please pass a different 'name'.", - fails "an illegal character is named" (drvWith ("name = \"a b\"; " <> plain)) "invalid derivation name: name 'a b' contains illegal character ' '. Please pass a different 'name'." - ] - --- | A path as a derivation's builder or system is copied to the store, as --- its environment entry is, so the .drv's builder and platform fields hold --- the store path. Each drvPath is nix-instantiate 2.24.9's. -testDerivationPathFieldsIO :: IO [Bool] -testDerivationPathFieldsIO = do - putStrLn "eval/derivation-path-fields-io" - tmpBase <- getTemporaryDirectory - let dir = tmpBase "nova-nix-test-derivation-path-fields" - drvPathOf fields = "builtins.unsafeDiscardStringContext (derivation { name = \"a\"; " <> fields <> " }).drvPath" - script = "/. + " <> nixQuotedPath (dir "b.sh") - Dir.removePathForcibly dir - createDirectoryIfMissing True dir - BS.writeFile (dir "b.sh") "echo hi\n" - results <- - sequence - [ runTestIO "a path builder is copied to the store" dir (drvPathOf ("system = \"x\"; builder = " <> script <> ";")) (mkStr "/nix/store/gz23n4381jlqwn1gvjqgs3411vr3w4nx-a.drv"), - runTestIO "a path system is copied to the store" dir (drvPathOf ("system = " <> script <> "; builder = \"/bin/sh\";")) (mkStr "/nix/store/382y120pp033h5kx5zfw02q0pglf297l-a.drv") - ] - Dir.removePathForcibly dir - pure results - --- | A builtin taking a path coerces its argument as upstream's --- coerceToPath does (eval.cc at 2.24.9), and baseNameOf and dirOf as --- their coerceToString does. Each expected value or message is --- nix-instantiate 2.24.9's. -testPathArguments :: IO [Bool] -testPathArguments = do - putStrLn "eval/path-arguments" - let refuses label source = runTest label (assertEvalError label source "cannot coerce an integer to a string: 1") - fails label source expected = runTest label (assertEvalError label source expected) - gives label source expected = runTest label (assertEval label source expected) - sequence - [ refuses "readFile coerces its argument" "builtins.readFile 1", - refuses "readDir coerces its argument" "builtins.readDir 1", - refuses "pathExists coerces its argument" "builtins.pathExists 1", - refuses "hashFile coerces its path" "builtins.hashFile \"sha256\" 1", - refuses "readFileType coerces its argument" "builtins.readFileType 1", - refuses "import coerces its argument" "import 1", - refuses "scopedImport coerces its path" "builtins.scopedImport { } 1", - refuses "builtins.path coerces its path" "builtins.path { path = 1; }", - refuses "filterSource coerces its path" "builtins.filterSource (p: t: true) 1", - refuses "toPath coerces its argument" "builtins.toPath 1", - fails "a coerced path must be absolute" "builtins.toPath \"a\"" "string 'a' doesn't represent an absolute path", - fails "builtins.path needs a path" "builtins.path { name = \"x\"; }" "missing required 'path' attribute in the first argument to builtins.path", - fails "baseNameOf refuses null as coerceToString does" "builtins.baseNameOf null" "cannot coerce null to a string: null", - fails "dirOf refuses a Boolean as coerceToString does" "builtins.dirOf true" "cannot coerce a Boolean to a string: true", - gives "toPath gives a string" "builtins.typeOf (builtins.toPath \"/a/b\")" (mkStr "string"), - gives "toPath canonicalizes an outPath" "builtins.toPath { outPath = \"/a//b/\"; }" (mkStr "/a/b"), - gives "toPath keeps the context it coerced" "let d = derivation { name = \"d\"; system = \"x\"; builder = \"/bin/sh\"; }; in builtins.concatStringsSep \",\" (builtins.attrNames (builtins.getContext (builtins.toPath \"${d}/bin\")))" (mkStr "/nix/store/wwk71dy0w17kn5spjd8hbsrk6520xs11-d.drv"), - gives "baseNameOf takes a __toString" "builtins.baseNameOf { __toString = s: \"/a/b\"; }" (mkStr "b"), - gives "dirOf takes an outPath, giving a string" "builtins.dirOf { outPath = /a/b; }" (mkStr "/a"), - gives "dirOf of a path stays a path" "builtins.typeOf (builtins.dirOf /a/b)" (mkStr "path") - ] - --- | The same coercion reaching the filesystem: an outPath or a __toString --- names the file read. -testPathArgumentsIO :: IO [Bool] -testPathArgumentsIO = do - putStrLn "eval/path-arguments-io" - -- readFileType refuses a symlink above its path, as upstream's does, and - -- macOS keeps the temporary directory under /var, a link. - tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory - let dir = tmpBase "nova-nix-test-path-arguments" - file = nixQuotedPath (dir "f") - Dir.removePathForcibly dir - createDirectoryIfMissing True dir - BS.writeFile (dir "f") "contents" - results <- - sequence - [ runTestIO "readFile reads an outPath" dir ("builtins.readFile { outPath = " <> file <> "; }") (mkStr "contents"), - runTestIO "pathExists follows an outPath" dir ("builtins.pathExists { outPath = " <> file <> "; }") (VBool True), - runTestIO "readFileType follows a __toString" dir ("builtins.readFileType { __toString = s: " <> file <> "; }") (mkStr "regular"), - runTestIO "hashFile hashes an outPath" dir ("builtins.hashFile \"sha256\" { outPath = " <> file <> "; }") (mkStr "d1b2a59fbea7e20077af9f91b27e95e865061b270be03ff539ab3b73587882e8") - ] - Dir.removePathForcibly dir - pure results - --- | The lines of context a failure gathers on its way out of --- derivationStrict, and how the CLI reports them (#221). Only the IO --- evaluator keeps them. -testDerivationTraceIO :: IO [Bool] -testDerivationTraceIO = do - putStrLn "eval/derivation-trace" - let derivationFailure attrs expected = do - tmpBase <- getTemporaryDirectory - result <- evalNixIOTraced tmpBase ("(derivation { builder = \"b\"; " <> attrs <> " }).drvPath") - pure $ case result of - Left failure -> assertEqual "derivation-failure" expected failure - Right val -> Fail ("expected a failure, got " <> T.pack (show val)) - sequence - [ -- A failure processing one attribute carries upstream's line naming - -- it and its derivation (derivationStrictInternal, primops.cc at - -- 2.24.9); the message itself is unchanged. - runTestM - "a failing derivation attribute is named in the failure's trace" - ( derivationFailure - "system = \"s\"; name = \"x\"; foo = { };" - (EvalFailure ["while evaluating attribute 'foo' of derivation 'x'"] "cannot coerce a set to a string: { }") - ), - runTestM - "a structured attribute with no JSON form is named in the failure's trace" - ( derivationFailure - "system = \"s\"; name = \"x\"; __structuredAttrs = true; foo = x: x;" - (EvalFailure ["while evaluating attribute 'foo' of derivation 'x'"] "builtins.toJSON: cannot convert a function to JSON") - ), - -- prim_derivationStrict adds its own line outside forceStringNoCtx's. - runTestM - "a failing name carries both of upstream's lines" - ( derivationFailure - "system = \"s\"; name = throw \"n\";" - ( EvalFailure - [ "while evaluating the derivation attribute 'name'", - "while evaluating the `name` attribute passed to builtins.derivationStrict" - ] - "n" - ) - ), - runTestM - "a switch that is not a Boolean is named in the failure's trace" - ( derivationFailure - "system = \"s\"; name = \"x\"; __ignoreNulls = 1;" - (EvalFailure ["while evaluating the `__ignoreNulls` attribute passed to builtins.derivationStrict"] "expected a Boolean but found an integer: 1") - ), - runTestM - "a structured-attributes switch that is not a Boolean is named in the failure's trace" - ( derivationFailure - "system = \"s\"; name = \"x\"; __structuredAttrs = 1;" - (EvalFailure ["while evaluating the `__structuredAttrs` attribute passed to builtins.derivationStrict"] "expected a Boolean but found an integer: 1") - ), - runTestM - "a structured string field that is not a string is named in the failure's trace" - ( derivationFailure - "system = \"s\"; name = \"x\"; __structuredAttrs = true; outputHash = 1;" - (EvalFailure ["while evaluating attribute 'outputHash' of derivation 'x'"] "expected a string but found an integer: 1") - ), - runTestM - "a missing attribute is refused without a line naming it" - (derivationFailure "name = \"x\";" (EvalFailure [] "required attribute 'system' missing")), - runTestM "a failure in a dependency is traced through each derivation, outermost first" $ do - tmpBase <- getTemporaryDirectory - result <- - evalNixIOTraced tmpBase $ - "let inner = derivation { name = \"inner\"; system = \"s\"; builder = \"b\"; bad = { }; };" - <> " in (derivation { name = \"outer\"; system = \"s\"; builder = \"b\"; dep = inner; }).drvPath" - pure $ case result of - Left failure -> - assertEqual - "nested-trace" - ["while evaluating attribute 'dep' of derivation 'outer'", "while evaluating attribute 'bad' of derivation 'inner'"] - (failureTrace failure) - Right val -> Fail ("expected a failure, got " <> T.pack (show val)), - runTestM "a throw in a derivation attribute stays catchable" $ do - tmpBase <- getTemporaryDirectory - result <- evalNixIO tmpBase "(builtins.tryEval (derivation { name = \"x\"; system = \"s\"; builder = \"b\"; foo = throw \"t\"; }).drvPath).success" - pure $ assertRight "trace-catchable" result (assertEqual "trace-catchable" (VBool False)), - -- upstream's showErrorInfo and indent (error.cc at 2.24.9), checked - -- against nix-instantiate 2.24.9's report for the same failure with - -- its positioned lines left out. - runTest "a failure renders as upstream reports it" $ - assertEqual - "render-traced" - "error:\n \x2026 while evaluating attribute 'foo' of derivation 'x'\n\n error: a\n b" - (renderEvalFailure (EvalFailure ["while evaluating attribute 'foo' of derivation 'x'"] "a\nb")), - runTest "a failure with no trace renders on the error line" $ - assertEqual "render-untraced" "error: a\n b" (renderEvalFailure (EvalFailure [] "a\nb")) - ] - --- | Regression: a thunk whose force throws a catchable error (builtins.throw, --- a type error) must be restored to PENDING, not left BLACKHOLE - otherwise a --- later force of the same shared thunk aborts with a bogus "infinite recursion" --- that escapes tryEval. Genuine self-recursion must still escape tryEval. --- EvalIO-only: PureEval never blackholes. -testBlackholeRecoveryIO :: IO [Bool] -testBlackholeRecoveryIO = do - putStrLn "eval/blackhole-recovery-io" - sequence - [ runTestIO - "tryEval twice on a shared throwing thunk recovers (no bogus recursion)" - "." - "let x = builtins.throw \"boom\"; in (if (builtins.tryEval x).success then 1 else 0) + (if (builtins.tryEval x).success then 1 else 0)" - (VInt 0), - runTestIOFail - "genuine infinite recursion still escapes tryEval" - "." - "builtins.tryEval (let y = y; in y)" - ] - --- | builtins.path/filterSource with a filter: the tree is serialized with --- rejected entries removed (a rejected directory prunes its subtree), --- content-addressed over the FILTERED NAR, and materialized to the store. -testPathFilterIO :: IO [Bool] -testPathFilterIO = do - putStrLn "eval/path-filter-io" - testPathFilterBody - -testPathFilterBody :: IO [Bool] -testPathFilterBody = do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-path-filter" - setup = do - removeIfExists srcDir - createDirectoryIfMissing True (srcDir "sub") - createDirectoryIfMissing True (srcDir "dropdir") - BS.writeFile (srcDir "keep.txt") "keep" - BS.writeFile (srcDir "drop.log") "drop" - BS.writeFile (srcDir "sub" "inner.txt") "inner" - BS.writeFile (srcDir "dropdir" "x.txt") "gone" - quoted = nixQuotedPath srcDir - filterExpr = "(p: t: builtins.match \".*[.]log\" p == null && baseNameOf p != \"dropdir\")" - filteredPath = "(builtins.path { path = " <> quoted <> "; name = \"src\"; filter = " <> filterExpr <> "; })" - unfilteredPath = "(builtins.path { path = " <> quoted <> "; name = \"src\"; })" - -- bracket_: cleanup runs even if tests throw - bracket_ setup (removeIfExists srcDir) $ - sequence - [ runTestIO - "kept file survives with its content" - "." - ("builtins.readFile (" <> filteredPath <> " + \"/keep.txt\")") - (mkStr "keep"), - runTestIO - "kept subtree survives" - "." - ("builtins.readFile (" <> filteredPath <> " + \"/sub/inner.txt\")") - (mkStr "inner"), - runTestIO - "rejected file is dropped" - "." - ("builtins.pathExists (" <> filteredPath <> " + \"/drop.log\")") - (VBool False), - runTestIO - "rejected directory prunes its subtree" - "." - ("builtins.pathExists (" <> filteredPath <> " + \"/dropdir\")") - (VBool False), - runTestIO - "filtered and unfiltered store paths differ" - "." - (filteredPath <> " == " <> unfilteredPath) - (VBool False), - runTestIO - "same filter yields the same store path" - "." - (filteredPath <> " == " <> filteredPath) - (VBool True), - runTestIO - "filterSource is path-with-filter under the source basename" - "." - ( "builtins.filterSource (p: t: true) " - <> quoted - <> " == builtins.path { path = " - <> quoted - <> "; filter = (p: t: true); }" - ) - (VBool True) - ] - --- | Whether this host can create symlinks (Windows needs Developer Mode --- or elevation). The symlink-walk fixtures cannot be built without it, --- so their groups skip loudly rather than fail. -symlinksAvailable :: IO Bool -symlinksAvailable = do - tmpBase <- getTemporaryDirectory - let probeDir = tmpBase "nova-nix-test-link-probe" - Dir.removePathForcibly probeDir - createDirectoryIfMissing True probeDir - BS.writeFile (probeDir "target.txt") "t" - outcome <- try (Dir.createFileLink "target.txt" (probeDir "link")) - Dir.removePathForcibly probeDir - pure $ case (outcome :: Either SomeException ()) of - Left _ -> False - Right () -> True - --- | Interpolating a path that is a symlink copies what it points to, --- under the link's own name: upstream's copyPathToStore stores --- path.resolveSymlinks() under path.baseName() (eval.cc at 2.24.9). -testInterpolatedSymlinkIO :: IO [Bool] -testInterpolatedSymlinkIO = do - putStrLn "eval/interpolated-symlink-io" - canLink <- symlinksAvailable - if not canLink - then do - putStrLn " SKIP needs symlink privilege" - pure [] - else testInterpolatedSymlinkBody - -testInterpolatedSymlinkBody :: IO [Bool] -testInterpolatedSymlinkBody = do - tmpBase <- getTemporaryDirectory - let dir = tmpBase "nova-nix-test-interpolated-symlink" - Dir.removePathForcibly dir - createDirectoryIfMissing True (dir "sub") - BS.writeFile (dir "data.txt") "linked bytes" - BS.writeFile (dir "sub" "inner.txt") "inner" - Dir.createFileLink "data.txt" (dir "filelink") - Dir.createDirectoryLink "sub" (dir "dirlink") - fileEntry <- NAR.serialiseFromPath (dir "data.txt") - dirEntry <- NAR.serialiseFromPath (dir "sub") - let interpolated name = evalNixIO "." ("\"${/. + " <> nixQuotedPath (dir name) <> "}\"") - copiedAs name entry = - either (const Nothing) (Just . storePathToText defaultStoreDir) (makeFixedOutputPath (T.pack name) "sha256" "recursive" (sha256Digest (NAR.serialise entry))) - copies name entry = runTestM ("interpolating " <> T.pack name <> " copies its target") $ do - result <- interpolated name - pure $ case (result, copiedAs name entry) of - (_, Nothing) -> Fail "fixture store path rejected" - (Right (VStr got _), Just expected) -> assertEqual (T.pack name) (TE.encodeUtf8 expected) got - (Right other, _) -> Fail ("expected a string, got " <> T.pack (show other)) - (Left err, _) -> Fail ("eval failed: " <> err) - results <- - sequence - [ copies "filelink" fileEntry, - copies "dirlink" dirEntry - ] - Dir.removePathForcibly dir - pure results - --- | A failed source-path access reworded as upstream's PosixSourceAccessor --- words it (2.24.9), from IOExceptions shaped as GHC raises them. -testSourceErrorMessage :: IO [Bool] -testSourceErrorMessage = do - putStrLn "eval/source-error-message" - let errnoFailure kind (Errno code) description = - IOError Nothing kind "test" description (Just code) (Just "/d/x") - absent = errnoFailure NoSuchThing eNOENT "No such file or directory" - notDirectory = errnoFailure InappropriateType eNOTDIR "Not a directory" - denied = errnoFailure PermissionDenied eACCES "Permission denied" - isDirectory = errnoFailure InappropriateType eISDIR "Is a directory" - -- GHC's openFile refuses a directory itself, with no errno. - ghcDirectory = IOError Nothing InappropriateType "openFile" "is a directory" Nothing (Just "/d/dir") - says label access path err expected = - runTest label (assertEqual label expected (sourceErrorMessage access path err)) - sequence - [ says "a stat of an absent path" StatPath "/d/nope" absent "path '/d/nope' does not exist", - says "a stat through a file is absent too" StatPath "/d/file/x" notDirectory "path '/d/file/x' does not exist", - says "a stat refused otherwise names the stat" StatPath "/d/x" denied "getting status of '/d/x': Permission denied", - says "opening an absent file" ReadFile "/d/nope" absent "opening file '/d/nope': No such file or directory", - says "opening a file refused" ReadFile "/d/x" denied "opening file '/d/x': Permission denied", - says "reading a directory as a file" ReadFile "/d/dir" isDirectory "reading from file '/d/dir': Is a directory", - says "GHC's own directory refusal reads as upstream's" ReadFile "/d/dir" ghcDirectory "reading from file '/d/dir': Is a directory", - says "listing a file" ReadDirectory "/d/file" notDirectory "reading directory /d/file: Not a directory" - ] - --- | The same failures through the IO evaluator, against a real tree. --- POSIX only: Windows reports its own error text, and a path there is --- spelled with a drive. -testSourceReadErrorsIO :: IO [Bool] -testSourceReadErrorsIO = do - putStrLn "eval/source-read-errors-io" - if SI.os == "mingw32" - then do - putStrLn " SKIP POSIX error text" - pure [] - else testSourceReadErrorsBody - -testSourceReadErrorsBody :: IO [Bool] -testSourceReadErrorsBody = do - -- The temporary directory's own symlinks resolved (macOS keeps it under - -- /var, a link), so the only link in play is the one made below. - tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory - let dir = tmpBase "nova-nix-test-source-read-errors" - Dir.removePathForcibly dir - createDirectoryIfMissing True (dir "sub") - createDirectoryIfMissing True (dir "real") - BS.writeFile (dir "file") "f" - Dir.createDirectoryLink "real" (dir "link") - let resolved = T.pack dir - given = T.pack dir - at name = "/. + " <> nixQuotedPath (dir name) - fails label source expected = runTestM label (assertEvalErrorIO dir label source expected) - results <- - sequence - [ fails "readFile of an absent file" ("builtins.readFile (" <> at "nope" <> ")") ("opening file '" <> resolved <> "/nope': No such file or directory"), - fails "hashFile of an absent file" ("builtins.hashFile \"sha256\" (" <> at "nope" <> ")") ("opening file '" <> resolved <> "/nope': No such file or directory"), - fails "readFile through a file" ("builtins.readFile (" <> at "file/x" <> ")") ("opening file '" <> resolved <> "/file/x': Not a directory"), - fails "readFile of a directory" ("builtins.readFile (" <> at "sub" <> ")") ("reading from file '" <> resolved <> "/sub': Is a directory"), - fails "readDir of an absent directory" ("builtins.readDir (" <> at "nope" <> ")") ("reading directory " <> resolved <> "/nope: No such file or directory"), - fails "readDir of a file" ("builtins.readDir (" <> at "file" <> ")") ("reading directory " <> resolved <> "/file: Not a directory"), - fails "readFileType of an absent path" ("builtins.readFileType (" <> at "nope" <> ")") ("path '" <> given <> "/nope' does not exist"), - fails "interpolating an absent path" ("\"${" <> at "nope" <> "}\"") ("path '" <> resolved <> "/nope' does not exist"), - fails "builtins.path of an absent path" ("builtins.path { path = " <> at "nope" <> "; }") ("path '" <> resolved <> "/nope' does not exist"), - fails "importing an absent path" ("import (" <> at "nope" <> ")") ("path '" <> resolved <> "/nope' does not exist"), - fails "importing a directory without default.nix" ("import (" <> at "sub" <> ")") ("opening file '" <> resolved <> "/sub/default.nix': No such file or directory"), - -- Through a symlinked directory a read names the resolved path, as - -- realisePath resolves it, and readFileType refuses the link. - fails "readFile through a link names the resolved path" ("builtins.readFile (" <> at "link/nope" <> ")") ("opening file '" <> resolved <> "/real/nope': No such file or directory"), - fails "readDir through a link names the resolved path" ("builtins.readDir (" <> at "link/nope" <> ")") ("reading directory " <> resolved <> "/real/nope: No such file or directory"), - fails "import through a link names the resolved path" ("import (" <> at "link/nope" <> ")") ("path '" <> resolved <> "/real/nope' does not exist"), - fails "readFileType through a link refuses the link" ("builtins.readFileType (" <> at "link/nope" <> ")") ("path '" <> given <> "/link' is a symlink") - ] - Dir.removePathForcibly dir - pure results - --- | Watchdog for cycle-termination tests: with symlinks as leaves every --- walk returns promptly, while a regression to link-following recurses --- forever - and a hung suite is worse than a failed one. -walkWatchdogMicros :: Int -walkWatchdogMicros = 30 * 1000 * 1000 - --- | @builtins.path@ with no filter over a tree that contains a symlink. --- The store-path name comes from the NAR serialization, which records --- the link as a leaf entry - so the copy must replicate the link for --- the stored bytes to still match the recorded content address. -testPathSymlinkIO :: IO [Bool] -testPathSymlinkIO = do - putStrLn "eval/path-symlink-io" - canLink <- symlinksAvailable - if not canLink - then do - putStrLn " SKIP needs symlink privilege" - pure [] - else testPathSymlinkBody - -testPathSymlinkBody :: IO [Bool] -testPathSymlinkBody = do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-path-symlink" - cycleDir = tmpBase "nova-nix-test-path-cycle" - Dir.removePathForcibly srcDir - Dir.removePathForcibly cycleDir - createDirectoryIfMissing True srcDir - BS.writeFile (srcDir "data.txt") "linked bytes" - Dir.createFileLink "data.txt" (srcDir "link") - createDirectoryIfMissing True cycleDir - BS.writeFile (cycleDir "f.txt") "f" - Dir.createDirectoryLink "." (cycleDir "loop") - linkEntry <- NAR.serialiseFromPath srcDir - cycleEntry <- NAR.serialiseFromPath cycleDir - let pathExprFor dir name = - "builtins.path { path = " <> nixQuotedPath dir <> "; name = \"" <> name <> "\"; }" - spFor name entry = - makeFixedOutputPath name "sha256" "recursive" (sha256Digest (NAR.serialise entry)) - results <- case (spFor "path-symlink-src" linkEntry, spFor "path-symlink-cycle" cycleEntry) of - (Right linkSp, Right cycleSp) -> do - -- The same mapping the evaluator's copy uses for its destination. - evalStore <- evalNixIOStoreDir - let linkDest = storePathToFilePath evalStore linkSp - cycleDest = storePathToFilePath evalStore cycleSp - -- A leftover materialization from an earlier (possibly pre-fix) run - -- would short-circuit the copy under test. - Dir.removePathForcibly linkDest - Dir.removePathForcibly cycleDest - linkEval <- evalNixIO "." (pathExprFor srcDir "path-symlink-src") - cycleEval <- timeout walkWatchdogMicros (evalNixIO "." (pathExprFor cycleDir "path-symlink-cycle")) - sequence - [ runTestM "unfiltered builtins.path replicates a symlink" $ - case linkEval of - Left err -> pure (Fail ("eval failed: " <> err)) - Right _ -> do - isLink <- Dir.pathIsSymbolicLink (linkDest "link") - if isLink - then do - target <- Dir.getSymbolicLinkTarget (linkDest "link") - pure (assertEqual "link target" "data.txt" target) - else pure (Fail "materialized 'link' is not a symlink"), - runTestM "materialized bytes reproduce the recorded content address" $ - case linkEval of - Left err -> pure (Fail ("eval failed: " <> err)) - Right _ -> do - onDisk <- NAR.serialiseFromPath linkDest - pure $ case spFor "path-symlink-src" onDisk of - Left err -> Fail ("on-disk tree's name rejected: " <> T.pack (show err)) - Right recomputed -> assertEqual "recomputed path" linkSp recomputed, - runTestM "builtins.path terminates on a link cycle" $ - case cycleEval of - Nothing -> pure (Fail "copy did not terminate on a link cycle") - Just (Left err) -> pure (Fail ("eval failed: " <> err)) - Just (Right _) -> do - isLink <- Dir.pathIsSymbolicLink (cycleDest "loop") - pure (if isLink then Pass else Fail "cycle link not replicated as a link") - ] - (badLink, badCycle) -> - sequence - [ runTest "path-symlink fixture store paths accepted" $ - Fail ("test store path rejected: " <> T.pack (show (badLink, badCycle))) - ] - Dir.removePathForcibly srcDir - Dir.removePathForcibly cycleDir - pure results - -testImportIO :: IO [Bool] -testImportIO = do - putStrLn "eval/import-io" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-import" - subDir = testDir "sub" - setup = do - createDirectoryIfMissing True subDir - TIO.writeFile (testDir "literal.nix") "42" - TIO.writeFile (testDir "expr.nix") "1 + 2" - TIO.writeFile (testDir "nested-inner.nix") "99" - TIO.writeFile (testDir "nested-outer.nix") "import ./nested-inner.nix" - TIO.writeFile (testDir "attrset.nix") "{ x = 1; y = 2; }" - TIO.writeFile (testDir "uses-arg.nix") "let f = x: x + 10; in f 5" - TIO.writeFile (subDir "from-sub.nix") "7" - cleanup = do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - -- bracket_: cleanup runs even if tests throw - bracket_ setup cleanup $ - sequence - [ -- import - runTestIO "import literal" testDir "import ./literal.nix" (VInt 42), - runTestIO "import expression" testDir "import ./expr.nix" (VInt 3), - runTestIO "import nested (A imports B)" testDir "import ./nested-outer.nix" (VInt 99), - runTestIO - "import cache (same file twice)" - testDir - "(import ./literal.nix) + (import ./literal.nix)" - (VInt 84), - runTestIOFail "import nonexistent -> error" testDir "import ./nonexistent.nix", - runTestIO "import attrset + select" testDir "(import ./attrset.nix).x" (VInt 1), - runTestIO "import let/lambda" testDir "import ./uses-arg.nix" (VInt 15), - -- A string is coerced to a path only when it spells an absolute - -- one; upstream refuses a relative string outright. - runTestIOFail "import refuses a relative string" testDir "import \"./literal.nix\"", - -- pathExists - runTestIO - "pathExists true" - testDir - ("builtins.pathExists " <> nixQuotedPath (testDir "literal.nix")) - (VBool True), - runTestIO - "pathExists false" - testDir - ("builtins.pathExists " <> nixQuotedPath (testDir "nope.nix")) - (VBool False), - -- readFile - runTestIO - "readFile contents" - testDir - ("builtins.readFile " <> nixQuotedPath (testDir "literal.nix")) - (mkStr "42"), - runTestIOFail - "readFile missing -> error" - testDir - ("builtins.readFile " <> nixQuotedPath (testDir "ghost.nix")), - -- readDir: entries have correct file types - runTestIO - "readDir classifies directory" - testDir - ("(builtins.readDir " <> nixQuotedPath testDir <> ").sub") - (mkStr "directory"), - runTestIO - "readDir classifies regular file" - testDir - ("builtins.getAttr \"literal.nix\" (builtins.readDir " <> nixQuotedPath testDir <> ")") - (mkStr "regular") - ] - --- --------------------------------------------------------------------------- --- Tests: Batch A - getEnv, currentTime, toPath --- --------------------------------------------------------------------------- - -testBatchA :: IO [Bool] -testBatchA = do - putStrLn "eval/builtins-batchA" - sequence - [ -- getEnv - runTest "getEnv pure returns empty" $ - assertEval "getEnv-pure" "builtins.getEnv \"HOME\"" (mkStr ""), - runTest "getEnv type error" $ - assertEvalFail "getEnv-err" "builtins.getEnv 42", - -- toPath - runTest "toPath absolute" $ - assertEval "toPath-abs" "builtins.toPath \"/foo/bar\"" (mkStr "/foo/bar"), - runTest "toPath rejects relative" $ - assertEvalFail "toPath-rel" "builtins.toPath \"foo/bar\"", - runTest "toPath of a path gives its string" $ - assertEval "toPath-vpath" "builtins.toPath /foo/bar" (mkStr "/foo/bar"), - runTest "toPath type error" $ - assertEvalFail "toPath-err" "builtins.toPath 42", - runTest "toPath rejects empty" $ - assertEvalFail "toPath-empty" "builtins.toPath \"\"", - -- currentTime - runTest "currentTime is int" $ - assertEval "currentTime" "builtins.typeOf builtins.currentTime" (mkStr "int"), - runTest "currentTime is 0 in pure" $ - assertEval "currentTime-pure" "builtins.currentTime" (VInt 0), - runTest "currentTime >= 0" $ - assertEval "currentTime-pos" "builtins.currentTime >= 0" (VBool True) - ] - --- --------------------------------------------------------------------------- --- Tests: Batch A - IO tests (getEnv) --- --------------------------------------------------------------------------- - -testBatchAIO :: IO [Bool] -testBatchAIO = do - putStrLn "eval/builtins-batchA-io" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-batchA" - bracket_ - (createDirectoryIfMissing True testDir) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ -- getEnv HOME should be non-empty in IO mode - do - result <- evalNixIO testDir "builtins.getEnv \"PATH\"" - runTest "getEnv PATH non-empty (IO)" $ assertRight "getEnv-io" result $ \val -> - case val of - VStr s _ -> if BS.null s then Fail "PATH was empty" else Pass - _ -> Fail ("expected VStr, got " <> T.pack (show val)), - -- currentTime in IO should be > 0 - do - result <- evalNixIO testDir "builtins.currentTime" - runTest "currentTime > 0 (IO)" $ assertRight "currentTime-io" result $ \val -> - case val of - VInt n -> if n > 0 then Pass else Fail ("expected > 0, got " <> T.pack (show n)) - _ -> Fail ("expected VInt, got " <> T.pack (show val)) - ] - --- --------------------------------------------------------------------------- --- Tests: environment values as bytes --- --------------------------------------------------------------------------- - --- | An environment value reaches the evaluator as its bytes, through --- @builtins.getEnv@ and through @NIX_PATH@, as upstream's @getenv@ reads --- it; each case's outcome was read off nix-instantiate 2.33.2 under the --- same environment. A POSIX environment is bytes and a Windows one is --- UTF-16, so each platform runs the cases its environment can express. -testEnvironmentBytes :: IO [Bool] -testEnvironmentBytes = do - putStrLn "eval/environment-bytes" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-env-bytes" - pkgDir = testDir "mypkg" - bracket_ - ( do - createDirectoryIfMissing True pkgDir - BS.writeFile (pkgDir "default.nix") "42" - BS.writeFile (testDir "name.bin") nonUtf8EnvName - ) - (Dir.removePathForcibly testDir) - $ do - getEnvResults <- mapM (getEnvCase testDir) envByteCases - nixPathResults <- mapM (nixPathCase testDir) envByteCases - rest <- - sequence - [ withEnvBytes "a lookup passes a NIX_PATH entry whose prefix has no UTF-8 reading" (TE.encodeUtf8 nixPathVarName) ("\xFC=/nonexistent:mypkg=" <> TE.encodeUtf8 (T.pack pkgDir)) $ - assertEqual "lookup" (Right (VInt 42)) <$> evalNixIO testDir "import ", - withEnvBytes "getEnv looks a name up by its bytes" nonUtf8EnvName "hello" $ - expectBytes "name" "hello" <$> evalNixIO testDir "builtins.getEnv (builtins.readFile ./name.bin)", - unpairedSurrogateGetEnv testDir, - unpairedSurrogateNixPath testDir - ] - pure (getEnvResults ++ nixPathResults ++ rest) - where - getEnvCase dir (label, bytes) = - withEnvBytes ("getEnv carries " <> label) (TE.encodeUtf8 testEnvVarName) bytes $ - expectBytes "getEnv" bytes <$> evalNixIO dir ("builtins.getEnv \"" <> testEnvVarName <> "\"") - nixPathCase dir (label, bytes) = - withEnvBytes ("NIX_PATH carries " <> label <> " into prefix and path") (TE.encodeUtf8 nixPathVarName) (bytes <> "=/x" <> bytes) $ - expectBytes "nixPath" (bytes <> "|/x" <> bytes) <$> evalNixIO dir "let e = builtins.head builtins.nixPath; in e.prefix + \"|\" + e.path" - expectBytes label expected = \case - Right (VStr actual _) -> assertEqual label expected actual - other -> Fail (label <> ": expected a string, got " <> T.pack (show other)) - --- | The values the environment cases carry: a byte with no UTF-8 reading, --- a multibyte UTF-8 character, and nothing at all. -envByteCases :: [(Text, BS.ByteString)] -envByteCases = - [ ("a byte with no UTF-8 reading", "\xFC"), - ("a multibyte UTF-8 value", "caf\xC3\xA9"), - ("an empty value", "") - ] - -testEnvVarName :: Text -testEnvVarName = "NOVA_NIX_TEST_ENV_BYTES" - -nixPathVarName :: Text -nixPathVarName = "NIX_PATH" - --- | A variable name holding a byte with no UTF-8 reading. -nonUtf8EnvName :: BS.ByteString -nonUtf8EnvName = "NOVA_NIX_TEST_ENV_\xFC" - --- | Run one case with a variable set to the given bytes, restoring it --- afterwards. A Windows environment is UTF-16 and cannot hold a byte --- with no UTF-8 reading, so such a case skips there. -withEnvBytes :: Text -> BS.ByteString -> BS.ByteString -> IO TestResult -> IO Bool -withEnvBytes label name value check = do - spelledName <- envSpelling name - spelledValue <- envSpelling value - case (,) <$> spelledName <*> spelledValue of - Nothing -> True <$ putStrLn (" SKIP " <> T.unpack label <> ": a Windows environment cannot hold a byte with no UTF-8 reading") - Just (nameSpelling, valueSpelling) -> runTestM label (withEnvVar nameSpelling valueSpelling check) - --- | The 'String' that base's environment setters and file functions, and --- a spawned process's environment, write as the given bytes: on POSIX --- they encode with the file-system encoding, whose round-trip escape --- restores every byte its decoding escaped, and on Windows they write --- UTF-16. -envSpelling :: BS.ByteString -> IO (Maybe String) -envSpelling bytes - | SI.os == "mingw32" = pure (either (const Nothing) (Just . T.unpack) (TE.decodeUtf8' bytes)) - | otherwise = do - encoding <- getFileSystemEncoding - Just <$> BS.useAsCStringLen bytes (GHCForeign.peekCStringLen encoding) - --- | Run an action with a variable set (to an empty value too, which --- 'setEnv' would unset), restoring what the variable held afterwards. -withEnvVar :: String -> String -> IO a -> IO a -withEnvVar name value action = - bracket (lookupEnv name) restore (const (Blank.setEnv name value True >> action)) - where - restore = maybe (unsetEnv name) (\saved -> Blank.setEnv name saved True) - --- | A Windows value holding an unpaired UTF-16 surrogate has no UTF-8 --- form, so getEnv refuses it rather than substituting U+FFFD. -unpairedSurrogateGetEnv :: FilePath -> IO Bool -unpairedSurrogateGetEnv dir - | SI.os /= "mingw32" = True <$ putStrLn unpairedSurrogateSkip - | otherwise = - runTestM "getEnv refuses a value holding an unpaired surrogate" $ - withEnvVar (T.unpack testEnvVarName) "a\xD800" $ do - result <- evalNixIO dir ("builtins.getEnv \"" <> testEnvVarName <> "\"") - pure $ case result of - Left err | unpairedSurrogateWords `T.isInfixOf` err -> Pass - other -> Fail ("expected the unpaired-surrogate refusal, got " <> T.pack (show other)) - --- | The same refusal for @NIX_PATH@, raised as the evaluation state is --- created. -unpairedSurrogateNixPath :: FilePath -> IO Bool -unpairedSurrogateNixPath dir - | SI.os /= "mingw32" = True <$ putStrLn unpairedSurrogateSkip - | otherwise = - runTestM "NIX_PATH holding an unpaired surrogate is refused" $ - withEnvVar (T.unpack nixPathVarName) "a=\xD800" $ do - storeDir <- evalNixIOStoreDir - outcome <- try (newEvalState storeDir dir) - pure $ case outcome of - Left (err :: IOException) - | unpairedSurrogateWords `T.isInfixOf` T.pack (displayException err) -> Pass - | otherwise -> Fail ("wrong error: " <> T.pack (displayException err)) - Right _ -> Fail "NIX_PATH was accepted" - -unpairedSurrogateWords :: Text -unpairedSurrogateWords = "unpaired UTF-16 surrogate" - -unpairedSurrogateSkip :: String -unpairedSurrogateSkip = " SKIP an unpaired UTF-16 surrogate exists only in a Windows environment" - --- --------------------------------------------------------------------------- --- Tests: Batch B - placeholder, storePath --- --------------------------------------------------------------------------- - -testBatchB :: IO [Bool] -testBatchB = do - putStrLn "eval/builtins-batchB" - sequence - [ -- placeholder - runTest "placeholder out matches Nix hashPlaceholder" $ - assertRight "placeholder-out" (evalNix "builtins.placeholder \"out\"") $ \val -> - case val of - VStr p _ -> assertEqual "placeholder out" "/1rz4g4znpzjwh1xymhjpm42vipw92pr73vdgl6xs1hycac8kf2n9" p - _ -> Fail ("expected VStr, got " <> T.pack (show val)), - runTest "placeholder deterministic" $ - assertRight "placeholder-det" (evalNix "builtins.placeholder \"out\" == builtins.placeholder \"out\"") $ \val -> - assertEqual "deterministic" (VBool True) val, - runTest "placeholder out /= placeholder dev" $ - assertRight "placeholder-diff" (evalNix "builtins.placeholder \"out\" == builtins.placeholder \"dev\"") $ \val -> - assertEqual "different" (VBool False) val, - runTest "placeholder type error" $ - assertEvalFail "placeholder-err" "builtins.placeholder 42", - -- storePath returns a STRING marked already-in-store (SCPlain context), - -- not a bare path - the marker is what stops a later coercion re-NARing it. - runTest "storePath returns an in-store string" $ - assertEval - "storePath-isstring" - "builtins.isString (builtins.storePath \"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\")" - (VBool True), - runTest "storePath result carries a plain-path context" $ - assertEval - "storePath-hasctx" - "(builtins.getContext (builtins.storePath \"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\")).\"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\".path" - (VBool True), - runTest "storePath preserves the path text" $ - assertEval - "storePath-text" - "builtins.unsafeDiscardStringContext (builtins.storePath \"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\")" - (mkStr "/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1"), - runTest "storePath invalid" $ - assertEvalFail "storePath-bad" "builtins.storePath \"/tmp/not-a-store-path\"", - runTest "storePath type error" $ - assertEvalFail "storePath-err" "builtins.storePath 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Batch C - findFile --- --------------------------------------------------------------------------- - -testBatchC :: IO [Bool] -testBatchC = do - putStrLn "eval/builtins-batchC" - sequence - [ runTest "findFile empty list errors" $ - assertEvalFail "findFile-empty" "builtins.findFile [ ] \"foo\"", - runTest "findFile type error arg1" $ - assertEvalFail "findFile-err1" "builtins.findFile 42 \"foo\"", - runTest "findFile type error arg2" $ - assertEvalFail "findFile-err2" "builtins.findFile [ ] 42" - ] - -testBatchCIO :: IO [Bool] -testBatchCIO = do - putStrLn "eval/builtins-batchC-io" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-batchC" - nixpkgsDir = testDir "nixpkgs" - bracket_ - ( do - createDirectoryIfMissing True nixpkgsDir - TIO.writeFile (nixpkgsDir "default.nix") "42" - ) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ runTestIO - "findFile with matching entry" - testDir - ( "builtins.findFile [ { prefix = \"nixpkgs\"; path = " - <> nixQuotedPath nixpkgsDir - <> "; } ] \"nixpkgs\"" - ) - (VPath (canonPathValue (T.pack nixpkgsDir))), - runTestIOFail - "findFile no match" - testDir - "builtins.findFile [ { prefix = \"other\"; path = \"/nope\"; } ] \"nixpkgs\"" - ] - --- --------------------------------------------------------------------------- --- Tests: Blackhole (infinite recursion detection) --- --------------------------------------------------------------------------- - -testBlackhole :: IO [Bool] -testBlackhole = do - putStrLn "eval/blackhole" - tmpBase <- getTemporaryDirectory - sequence - [ runTestIOFail "let x = x; in x" tmpBase "let x = x; in x", - runTestIOFail "rec { a = a; }.a" tmpBase "rec { a = a; }.a", - runTestIOFail "let a = b; b = a; in a" tmpBase "let a = b; b = a; in a", - -- Non-recursive cases must still work - runTestIO "rec { a = 1; b = a; }.b" tmpBase "rec { a = 1; b = a; }.b" (VInt 1), - runTestIO "let a = 1; b = a + 1; in b" tmpBase "let a = 1; b = a + 1; in b" (VInt 2) - ] - --- --------------------------------------------------------------------------- --- Tests: Eval - Call depth (max-call-depth) --- --------------------------------------------------------------------------- - --- | The issue's counter recursion to a given depth. -counterRecursion :: Int -> Text -counterRecursion n = "let f = n: if n == 0 then 0 else 1 + f (n - 1); in f " <> T.pack (show n) - --- | The identity applied to itself syntactically @n@ deep: a chain of pure --- lambda frames with nothing else counted. -lambdaNesting :: Int -> Text -lambdaNesting n = "let f = x: x; in " <> T.replicate n "f (" <> "0" <> T.replicate n ")" - --- | Upstream's message, which the CLI prints after its own "error: ". -maxCallDepthMessage :: Text -maxCallDepthMessage = "stack overflow; max-call-depth exceeded" - --- | A result that must be the max-call-depth error, word for word. -expectMaxCallDepth :: Text -> Either Text NixValue -> TestResult -expectMaxCallDepth label result = case result of - Left err - | err == maxCallDepthMessage -> Pass - | otherwise -> Fail (label <> ": wrong error: " <> err) - Right val -> Fail (label <> ": expected the max-call-depth error but got: " <> T.pack (show val)) - --- | IO evaluation under an explicit call-depth ceiling. -evalAtCeiling :: Word32 -> Text -> IO (Either Text NixValue) -evalAtCeiling limit source = case parseNix "." "" source of - Left err -> pure (Left (T.pack (show err))) - Right expr -> do - storeDir <- evalNixIOStoreDir - st0 <- newEvalState storeDir "." - let st = st0 {esCallDepth = topLevelCallDepth limit} - runEvalIO st (eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr) - --- | The function-call nesting ceiling, upstream's max-call-depth (10000). --- Every boundary here was read off nix-instantiate 2.33.2 and the 2.24.9 --- source: the count is the frames already active, checked on entry, so --- 10001 nested lambda calls pass and 10002 fail, and the counter --- recursion passes at 9999 and fails at 10000, its deepest frame being --- the @n - 1@ forced inside @f 0@, a builtin call upstream's parser --- desugars @-@ into. The cases under a ceiling of 10 pin what costs a --- frame and what does not, each boundary taken from the same upstream. -testCallDepth :: IO [Bool] -testCallDepth = do - putStrLn "eval/call-depth" - sequence - [ failsIO "the issue expression is refused with upstream's words" (counterRecursion 100000), - runTestIO "the counter recursion one under the ceiling evaluates" "." (counterRecursion 9999) (VInt 9999), - failsIO "the counter recursion at the ceiling is refused" (counterRecursion 10000), - runTest "pure evaluation enforces the ceiling too" $ - assertEval "pure-under" (lambdaNesting 10001) (VInt 0), - runTest "pure evaluation refuses past the ceiling with upstream's words" $ - expectMaxCallDepth "pure-over" (evalNix (lambdaNesting 10002)), - -- Under a ceiling of n, n + 1 nested lambda calls pass and n + 2 fail. - passesAt 10 "lambda nesting one past the ceiling passes" (lambdaNesting 11) (VInt 0), - failsAt 10 "lambda nesting two past the ceiling fails" (lambdaNesting 12), - -- The operators upstream desugars into builtin calls cost a frame - -- while their operands are forced; its native operators cost none. - passesAt 10 "a subtraction at the ceiling passes" (wrapped 10 "1 - 1") (VInt 0), - failsAt 10 "a subtraction one past the ceiling fails" (wrapped 11 "1 - 1"), - failsAt 10 "a multiplication one past the ceiling fails" (wrapped 11 "2 * 1"), - failsAt 10 "a division one past the ceiling fails" (wrapped 11 "2 / 1"), - failsAt 10 "a less-than one past the ceiling fails" (wrapped 11 "1 < 2"), - failsAt 10 "a less-or-equal one past the ceiling fails" (wrapped 11 "1 <= 2"), - failsAt 10 "a greater-than one past the ceiling fails" (wrapped 11 "2 > 1"), - failsAt 10 "a greater-or-equal one past the ceiling fails" (wrapped 11 "2 >= 1"), - failsAt 10 "a negation one past the ceiling fails" (wrapped 11 "-1"), - passesAt 10 "an equality one past the ceiling passes" (wrapped 11 "1 == 1") (VBool True), - passesAt 10 "an inequality one past the ceiling passes" (wrapped 11 "1 != 2") (VBool True), - passesAt 10 "a not one past the ceiling passes" (wrapped 11 "!true") (VBool False), - passesAt 10 "an addition one past the ceiling passes" (wrapped 11 "1 + 1") (VInt 2), - passesAt 10 "a list concatenation one past the ceiling passes" (wrapped 11 "([1] ++ [2]) == [1 2]") (VBool True), - passesAt 10 "an attrset update one past the ceiling passes" (wrapped 11 "({ a = 1; } // { b = 2; }) == { a = 1; b = 2; }") (VBool True), - -- A builtin costs a frame even when partially applied. - failsAt 10 "a partially applied builtin one past the ceiling fails" (wrapped 11 "builtins.add 0"), - failsAt 10 "a builtin application one past the ceiling fails" (wrapped 11 "builtins.add 0 0"), - -- A functor costs two frames: its inner call is a callFunction of its own. - passesAt 10 "functor nesting of five passes" (functorNesting 5) (VInt 0), - failsAt 10 "functor nesting of six fails" (functorNesting 6), - -- A __toString coercion is a callFunction. - passesAt 10 "a __toString coercion at the ceiling passes" (wrapped 10 "\"${s}\"") (mkStr "a"), - failsAt 10 "a __toString coercion one past the ceiling fails" (wrapped 11 "\"${s}\""), - -- A higher-order builtin's callback is applied where its result is - -- forced, not inside the builtin's frame: upstream's prim_map returns - -- app values. Forced by ==, which opens no frame, the callback at - -- the ceiling passes; forced by elemAt, a frame deeper, it is - -- elemAt's own call that fails. - passesAt 10 "a map callback forced at the ceiling passes" (wrapped 10 "(builtins.map f [ 0 ]) == [ 0 ]") (VBool True), - failsAt 10 "a map callback forced one past the ceiling fails" (wrapped 11 "(builtins.map f [ 0 ]) == [ 0 ]"), - passesAt 10 "an elemAt over map under the ceiling passes" (wrapped 9 "builtins.elemAt (builtins.map f [ 0 ]) 0") (VInt 0), - failsAt 10 "an elemAt over map at the ceiling fails" (wrapped 10 "builtins.elemAt (builtins.map f [ 0 ]) 0"), - -- mapAttrs and zipAttrsWith apply @f name@ a frame below the value - -- application: upstream builds two nested app values. - passesAt 10 "a mapAttrs callback under the ceiling passes" (wrapped 9 "(builtins.mapAttrs (n: v: v) { a = 0; }).a") (VInt 0), - failsAt 10 "a mapAttrs callback at the ceiling fails" (wrapped 10 "(builtins.mapAttrs (n: v: v) { a = 0; }).a"), - passesAt 10 "a zipAttrsWith callback under the ceiling passes" (wrapped 9 "(builtins.zipAttrsWith (n: vs: 0) [ { a = 1; } ]).a") (VInt 0), - failsAt 10 "a zipAttrsWith callback at the ceiling fails" (wrapped 10 "(builtins.zipAttrsWith (n: vs: 0) [ { a = 1; } ]).a"), - -- A sort by builtins.lessThan itself opens no frame per comparison - -- (upstream's prim_sort bypass); a lambda comparator costs its call - -- and the < inside it. - passesAt 10 "a sort by lessThan at the ceiling passes" (wrapped 10 "builtins.sort builtins.lessThan [ 2 1 ] == [ 1 2 ]") (VBool True), - failsAt 10 "a sort by lessThan one past the ceiling fails" (wrapped 11 "builtins.sort builtins.lessThan [ 2 1 ] == [ 1 2 ]"), - passesAt 10 "a sort by a lambda two under the ceiling passes" (wrapped 8 "builtins.sort (a: b: a < b) [ 2 1 ] == [ 1 2 ]") (VBool True), - failsAt 10 "a sort by a lambda one under the ceiling fails" (wrapped 9 "builtins.sort (a: b: a < b) [ 2 1 ] == [ 1 2 ]"), - passesAt 10 "the counter recursion to 9 passes under a ceiling of 10" (counterRecursion 9) (VInt 9), - failsAt 10 "the counter recursion to 10 fails under a ceiling of 10" (counterRecursion 10), - -- An eval error, not a throw: tryEval does not catch it. - failsAt 10 "tryEval does not catch the ceiling" ("(builtins.tryEval (" <> lambdaNesting 12 <> ")).success"), - -- A ceiling of 0 still admits one frame: the check is against the - -- frames already active when the call is entered. - passesAt 0 "one call passes under a ceiling of 0" "(x: x) 1" (VInt 1), - failsAt 0 "a nested call fails under a ceiling of 0" "(x: x) ((x: x) 1)", - passesAt 0 "a bare subtraction passes under a ceiling of 0" "1 - 1" (VInt 0), - failsAt 0 "a subtraction inside a call fails under a ceiling of 0" "(x: x - 1) 1" - ] - where - failsIO label source = evalNixIO "." source >>= runTest label . expectMaxCallDepth label - passesAt limit label source expected = do - result <- evalAtCeiling limit source - runTest label $ assertRight label result $ assertEqual label expected - failsAt limit label source = evalAtCeiling limit source >>= runTest label . expectMaxCallDepth label - wrapped n inner = scope <> T.replicate n "f (" <> inner <> T.replicate n ")" - functorNesting n = scope <> T.replicate n "g (" <> "0" <> T.replicate n ")" - scope = "let f = x: x; g = { __functor = self: x: x; }; s = { __toString = self: \"a\"; }; in " - --- --------------------------------------------------------------------------- --- Tests: Batch D - toFile --- --------------------------------------------------------------------------- - -testBatchD :: IO [Bool] -testBatchD = do - putStrLn "eval/builtins-batchD" - sequence - [ runTest "toFile pure mode error" $ - assertEvalFail "toFile-pure" "builtins.toFile \"hello\" \"world\"", - runTest "toFile type error arg1" $ - assertEvalFail "toFile-err1" "builtins.toFile 42 \"world\"", - runTest "toFile type error arg2" $ - assertEvalFail "toFile-err2" "builtins.toFile \"hello\" 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Batch E - scopedImport --- --------------------------------------------------------------------------- - -testBatchE :: IO [Bool] -testBatchE = do - putStrLn "eval/builtins-batchE" - sequence - [ runTest "scopedImport pure error" $ - assertEvalFail "scopedImport-pure" "builtins.scopedImport { } ./foo.nix", - runTest "scopedImport type error arg1" $ - assertEvalFail "scopedImport-err1" "builtins.scopedImport 42 ./foo.nix", - runTest "scopedImport type error arg2" $ - assertEvalFail "scopedImport-err2" "builtins.scopedImport { } 42" - ] - -testBatchEIO :: IO [Bool] -testBatchEIO = do - putStrLn "eval/builtins-batchE-io" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-batchE" - bracket_ - ( do - createDirectoryIfMissing True testDir - TIO.writeFile (testDir "scoped.nix") "x" - ) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ runTestIO - "scopedImport injects scope" - testDir - ("builtins.scopedImport { x = 42; } " <> nixQuotedPath (testDir "scoped.nix")) - (VInt 42) - ] - --- --------------------------------------------------------------------------- --- Tests: Batch F - fetchurl, fetchTarball, fetchGit --- --------------------------------------------------------------------------- - -testBatchF :: IO [Bool] -testBatchF = do - putStrLn "eval/builtins-batchF" - sequence - [ runTest "fetchurl pure error" $ - assertEvalFail "fetchurl-pure" "builtins.fetchurl \"http://example.com\"", - runTest "fetchurl type error" $ - assertEvalFail "fetchurl-err" "builtins.fetchurl 42", - runTest "fetchTarball pure error" $ - assertEvalFail "fetchTarball-pure" "builtins.fetchTarball \"http://example.com\"", - runTest "fetchTarball type error" $ - assertEvalFail "fetchTarball-err" "builtins.fetchTarball 42", - runTest "fetchGit pure error" $ - assertEvalFail "fetchGit-pure" "builtins.fetchGit \"http://example.com\"", - runTest "fetchGit type error" $ - assertEvalFail "fetchGit-err" "builtins.fetchGit 42" - ] - --- --------------------------------------------------------------------------- --- Tests: Batch G - ATerm serialization --- --------------------------------------------------------------------------- - -testBatchG :: IO [Bool] -testBatchG = do - putStrLn "derivation/aterm" - let minimalDrv = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/sh", - drvArgs = [], - drvEnv = Map.empty - } - let drvWithOutput = - minimalDrv - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = StorePath "abc" "hello", - doHashAlgo = "", - doHash = "" - } - ] - } - let drvWithEnv = - minimalDrv - { drvEnv = Map.fromList [("name", "hello"), ("system", "x86_64-linux")] - } - sequence - [ runTest "ATerm minimal" $ - let aterm = toATerm minimalDrv - in if BS.isPrefixOf "Derive(" aterm && BS.isSuffixOf ")" aterm - then Pass - else Fail ("bad ATerm: " <> bytesText aterm), - runTest "ATerm has output" $ - let aterm = toATerm drvWithOutput - in if "\"out\"" `BS.isInfixOf` aterm - then Pass - else Fail ("missing output in ATerm: " <> bytesText aterm), - runTest "ATerm env sorted" $ - let aterm = toATerm drvWithEnv - in -- "name" should come before "system" in sorted order - case (BS.breakSubstring "\"name\"" aterm, BS.breakSubstring "\"system\"" aterm) of - ((before1, _), (before2, _)) -> - if BS.length before1 < BS.length before2 - then Pass - else Fail ("env not sorted in ATerm: " <> bytesText aterm), - runTest "ATerm string escaping" $ - let drv = minimalDrv {drvEnv = Map.fromList [("msg", "hello\nworld")]} - aterm = toATerm drv - in if "\\n" `BS.isInfixOf` aterm - then Pass - else Fail ("missing escaped newline: " <> bytesText aterm), - runTest "ATerm deterministic" $ - assertEqual "deterministic" (toATerm minimalDrv) (toATerm minimalDrv), - -- platformToText - runTest "platformToText linux" $ - assertEqual "linux" "x86_64-linux" (platformToText X86_64_Linux), - runTest "platformToText darwin" $ - assertEqual "darwin" "x86_64-darwin" (platformToText X86_64_Darwin), - runTest "platformToText aarch64-darwin" $ - assertEqual "aarch64" "aarch64-darwin" (platformToText Aarch64_Darwin), - runTest "platformToText windows" $ - assertEqual "windows" "x86_64-windows" (platformToText X86_64_Windows), - runTest "platformToText aarch64-linux" $ - assertEqual "aarch64-linux" "aarch64-linux" (platformToText Aarch64_Linux), - runTest "platformToText i686" $ - assertEqual "i686" ["i686-linux", "i686-windows"] (map platformToText [I686_Linux, I686_Windows]), - runTest "platformToText other" $ - assertEqual "other" "riscv64-freebsd" (platformToText (OtherPlatform "riscv64-freebsd")), - -- The i686 spellings parse to their own constructors, not to - -- OtherPlatform, or extraPlatforms could never name them. - runTest "textToPlatform round-trips every named platform" $ - assertEqual - "round-trip" - namedPlatforms - (map (textToPlatform . platformToText) namedPlatforms), - -- Upstream's default extra-platforms, and nothing more: the x86_64 - -- hosts run their i686 counterpart, every other host runs only itself. - runTest "extraPlatforms is the i686 counterpart on x86_64 hosts only" $ - assertEqual - "extra" - [[I686_Linux], [I686_Windows], [], [], [], [], []] - (map extraPlatforms [X86_64_Linux, X86_64_Windows, X86_64_Darwin, Aarch64_Darwin, Aarch64_Linux, I686_Linux, I686_Windows]) - ] - where - namedPlatforms = [X86_64_Linux, X86_64_Darwin, Aarch64_Darwin, X86_64_Windows, Aarch64_Linux, I686_Linux, I686_Windows] - --- --------------------------------------------------------------------------- --- Tests: Batch H - derivation --- --------------------------------------------------------------------------- - -testBatchH :: IO [Bool] -testBatchH = do - putStrLn "eval/builtins-batchH" - let withTwoOutputs expr = - "let D = derivation { name = \"x\"; system = \"s\"; builder = \"b\"; outputs = [ \"out\" \"dev\" ]; }; in " <> expr - sequence - [ runTest "derivation has type" $ - assertEval - "drv-type" - "let d = derivation { name = \"hello\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d.type" - (mkStr "derivation"), - runTest "derivation has drvPath" $ - assertRight "drv-drvPath" (evalNix "let d = derivation { name = \"hello\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d.drvPath") $ \val -> - case val of - VStr p ctx -> - if "/nix/store/" `BS.isPrefixOf` p && ".drv" `BS.isSuffixOf` p && ctx /= emptyContext - then Pass - else Fail ("bad drvPath: " <> bytesText p) - _ -> Fail ("expected VStr with context, got " <> T.pack (show val)), - runTest "derivation has outPath" $ - assertRight "drv-outPath" (evalNix "let d = derivation { name = \"hello\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d.outPath") $ \val -> - case val of - VStr p ctx -> - if "/nix/store/" `BS.isPrefixOf` p && ctx /= emptyContext - then Pass - else Fail ("bad outPath: " <> bytesText p) - _ -> Fail ("expected VStr with context, got " <> T.pack (show val)), - -- 'derivation' is lazy (matches C++ Nix): the missing-required-attribute - -- error fires when a path is forced (.drvPath), not at construction. - runTest "derivation missing name" $ - assertEvalFail "drv-noname" "(derivation { system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).drvPath", - runTest "derivation missing system" $ - assertEvalFail "drv-nosys" "(derivation { name = \"hello\"; builder = \"/bin/sh\"; }).drvPath", - runTest "derivation missing builder" $ - assertEvalFail "drv-nobuilder" "(derivation { name = \"hello\"; system = \"x86_64-linux\"; }).drvPath", - runTest "derivation type error" $ - assertEvalFail "drv-tyerr" "derivation 42", - runTest "derivation deterministic" $ - assertRight "drv-det" (evalNix "let d1 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; d2 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d1.drvPath == d2.drvPath") $ \val -> - assertEqual "deterministic" (VBool True) val, - -- The result is upstream's derivation.nix wrapper evaluated as the - -- builtin, so its shape is the wrapper's: every row below was read - -- from nix-instantiate 2.33.2 (#217). - runTest "derivation result carries exactly upstream's attributes" $ - assertEval - "drv-attrnames" - (withTwoOutputs "builtins.attrNames D == [ \"all\" \"builder\" \"dev\" \"drvAttrs\" \"drvPath\" \"name\" \"out\" \"outPath\" \"outputName\" \"outputs\" \"system\" \"type\" ]") - (VBool True), - runTest "derivation outputName is the first output" $ - assertEval "drv-outputname" (withTwoOutputs "D.outputName") (mkStr "out"), - runTest "derivation default output is the first listed, not out" $ - assertEval - "drv-first-output" - "(derivation { name = \"x\"; system = \"s\"; builder = \"b\"; outputs = [ \"dev\" \"out\" ]; }).outputName" - (mkStr "dev"), - runTest "every output attribute is a complete derivation set" $ - assertEval "drv-output-set" (withTwoOutputs "builtins.attrNames D.dev == builtins.attrNames D") (VBool True), - runTest "an output set names its own output" $ - assertEval "drv-output-name" (withTwoOutputs "D.dev.outputName") (mkStr "dev"), - runTest "output sets refer back to each other" $ - assertEval "drv-output-cycle" (withTwoOutputs "D.dev.out.outPath == D.outPath && D.dev.dev.out.dev.outputName == \"dev\"") (VBool True), - runTest "derivation all lists every output set in order" $ - assertEval "drv-all" (withTwoOutputs "map (o: o.outputName) D.all == [ \"out\" \"dev\" ]") (VBool True), - runTest "derivation drvAttrs is the argument set" $ - assertEval "drv-drvattrs" (withTwoOutputs "builtins.attrNames D.drvAttrs == [ \"builder\" \"name\" \"outputs\" \"system\" ]") (VBool True), - runTest "derivation leaks no internal attribute" $ - assertEval "drv-no-internal" (withTwoOutputs "D ? _derivation") (VBool False), - -- derivationStrict is reached only through outPath and drvPath, so a - -- derivation forced to WHNF forces none of its inputs. - runTest "forcing a derivation to WHNF forces no input" $ - assertEval - "drv-whnf" - "builtins.seq (derivation { name = \"x\"; system = \"s\"; builder = throw \"forced\"; }) \"whnf-ok\"" - (mkStr "whnf-ok"), - runTest "derivationStrict returns drvPath and one path per output" $ - assertEval - "drvstrict-shape" - "builtins.attrNames (derivationStrict { name = \"x\"; system = \"s\"; builder = \"b\"; outputs = [ \"out\" \"dev\" ]; }) == [ \"dev\" \"drvPath\" \"out\" ]" - (VBool True), - runTest "derivation is a lambda with upstream's formals" $ - assertEval "drv-functionargs" "builtins.functionArgs derivation == { outputs = true; }" (VBool True) - ] - --- --------------------------------------------------------------------------- --- Tests: StringContext (Phase 3, Batch 1) --- --------------------------------------------------------------------------- - -testStringContext :: IO [Bool] -testStringContext = do - putStrLn "eval/string-context" - let sp1 = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello" - sp2 = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "world" - sequence - [ runTest "StringContext Eq" $ - let ctx1 = StringContext (Set.singleton (SCPlain sp1)) - ctx2 = StringContext (Set.singleton (SCPlain sp1)) - in assertEqual "ctx-eq" ctx1 ctx2, - runTest "mkStr constructor" $ - let v = mkStr "hello" - in case v of - VStr t ctx -> - if t == "hello" && ctx == emptyContext - then Pass - else Fail "mkStr produced wrong value" - _ -> Fail "mkStr did not produce VStr", - runTest "mergeContexts mempty" $ - let ctx1 = StringContext (Set.singleton (SCPlain sp1)) - merged = ctx1 <> emptyContext - in assertEqual "merge-mempty" ctx1 merged, - runTest "mergeContexts union" $ - let ctx1 = StringContext (Set.singleton (SCPlain sp1)) - ctx2 = StringContext (Set.singleton (SCDrvOutput sp2 "out")) - merged = ctx1 <> ctx2 - expected = StringContext (Set.fromList [SCPlain sp1, SCDrvOutput sp2 "out"]) - in assertEqual "merge-union" expected merged - ] - --- --------------------------------------------------------------------------- --- Tests: Context propagation (Phase 3, Batch 3) --- --------------------------------------------------------------------------- - -testContextPropagation :: IO [Bool] -testContextPropagation = do - putStrLn "eval/context-propagation" - sequence - [ -- String equality ignores context - runTest "string equality ignores context" $ - assertEval "str-eq-ctx" "\"hello\" == \"hello\"" (VBool True), - -- String comparison ignores context - runTest "string comparison ignores context" $ - assertEval "str-cmp-ctx" "\"a\" < \"b\"" (VBool True), - -- Interpolation produces correct text - runTest "interp text correct" $ - assertEval "interp-text" "let x = \"world\"; in \"hello ${x}\"" (mkStr "hello world"), - -- String + merges (tested at value level) - runTest "string + merges text" $ - assertEval "str-plus" "\"a\" + \"b\"" (mkStr "ab"), - -- concatStringsSep merges text - runTest "concatStringsSep result" $ - assertEval "css-text" "builtins.concatStringsSep \"-\" [\"a\" \"b\"]" (mkStr "a-b"), - -- substring preserves text - runTest "substring text" $ - assertEval "substr-text" "builtins.substring 1 2 \"hello\"" (mkStr "el"), - -- unsafeDiscardStringContext strips context - runTest "discardContext strips" $ - assertEval "discard-ctx" "builtins.unsafeDiscardStringContext \"hello\"" (mkStr "hello"), - -- stringLength drops context (returns int) - runTest "stringLength drops context" $ - assertEval "strlen-drop" "builtins.stringLength \"hello\"" (VInt 5), - -- hashString drops context (returns string with no context) - runTest "hashString result type" $ - assertRight "hash-type" (evalNix "builtins.typeOf (builtins.hashString \"sha256\" \"x\")") $ \val -> - assertEqual "hash-typeof" (mkStr "string") val, - -- replaceStrings text result - runTest "replaceStrings text" $ - assertEval "replace-text" "builtins.replaceStrings [\"o\"] [\"0\"] \"foo\"" (mkStr "f00"), - -- baseNameOf preserves text - runTest "baseNameOf text" $ - assertEval "basename-text" "builtins.baseNameOf \"/foo/bar\"" (mkStr "bar"), - -- dirOf preserves text - runTest "dirOf text" $ - assertEval "dirof-text" "builtins.dirOf \"/foo/bar\"" (mkStr "/foo"), - -- toString propagates - runTest "toString on string" $ - assertEval "tostr-str" "builtins.toString \"hello\"" (mkStr "hello"), - -- toString on int (no context) - runTest "toString on int" $ - assertEval "tostr-int" "builtins.toString 42" (mkStr "42") - ] - --- --------------------------------------------------------------------------- --- Tests: Context helpers (Phase 3, Batch 2) --- --------------------------------------------------------------------------- - -testContextHelpers :: IO [Bool] -testContextHelpers = do - putStrLn "eval/context-helpers" - let sp1 = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello" - sp2 = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "world.drv" - sp3 = StorePath "cccccccccccccccccccccccccccccccc" "source.tar.gz" - sequence - [ runTest "plainContext singleton" $ - let ctx = Context.plainContext sp1 - in assertEqual "plain" (StringContext (Set.singleton (SCPlain sp1))) ctx, - runTest "drvOutputContext singleton" $ - let ctx = Context.drvOutputContext sp2 "out" - in assertEqual "drvOut" (StringContext (Set.singleton (SCDrvOutput sp2 "out"))) ctx, - runTest "allOutputsContext singleton" $ - let ctx = Context.allOutputsContext sp2 - in assertEqual "allOut" (StringContext (Set.singleton (SCAllOutputs sp2))) ctx, - runTest "contextIsEmpty on mempty" $ - assertEqual "emptyCtx" True (Context.contextIsEmpty emptyContext), - runTest "contextIsEmpty on non-empty" $ - assertEqual "nonEmptyCtx" False (Context.contextIsEmpty (Context.plainContext sp1)), - runTest "extractInputSrcs" $ - let ctx = Context.plainContext sp1 <> Context.drvOutputContext sp2 "out" - in assertEqual "srcs" [sp1] (Context.extractInputSrcs ctx), - runTest "extractInputDrvs" $ - let ctx = Context.drvOutputContext sp2 "out" <> Context.drvOutputContext sp2 "dev" <> Context.plainContext sp3 - drvs = Context.extractInputDrvs ctx - in case Map.lookup sp2 drvs of - Just outs -> if length outs == 2 then Pass else Fail ("expected 2 outputs, got " <> T.pack (show (length outs))) - Nothing -> Fail "sp2 not found in drvs", - runTest "appendStrings merges" $ - let ctx1 = Context.plainContext sp1 - ctx2 = Context.drvOutputContext sp2 "out" - (txt, ctx) = Context.appendStrings "hello" ctx1 "world" ctx2 - in if txt == "helloworld" && not (Context.contextIsEmpty ctx) then Pass else Fail "bad append", - runTest "concatStrings empty" $ - let (txt, ctx) = Context.concatStrings [] - in if txt == "" && Context.contextIsEmpty ctx then Pass else Fail "bad empty concat", - runTest "concatStrings merges all" $ - let ctx1 = Context.plainContext sp1 - ctx2 = Context.drvOutputContext sp2 "out" - (txt, ctx) = Context.concatStrings [("a", ctx1), ("b", ctx2), ("c", mempty)] - in if txt == "abc" && Set.size (unStringContext ctx) == 2 then Pass else Fail "bad concat" - ] - --- --------------------------------------------------------------------------- --- Tests: structured attributes and the JSON they travel as --- --------------------------------------------------------------------------- - --- | @__structuredAttrs@ end to end on the evaluation side, and the JSON --- rules the evaluator and builder share. Every drvPath, rendering and --- @.attrs.sh@ expected here was read off Nix 2.33.2 (nix-instantiate and --- a build on aarch64-darwin), whose code for each is 2.24.9's. -testStructuredAttrs :: IO [Bool] -testStructuredAttrs = do - putStrLn "derivation/structured-attrs" - tmpBase <- getTemporaryDirectory - let base = "name = \"sa\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; __structuredAttrs = true; " - structured attrs = "(derivation { " <> base <> attrs <> " })" - withoutContext expr = "builtins.unsafeDiscardStringContext " <> expr - drvPathIs label attrs expected = - runTest label (assertEval label (withoutContext (structured attrs <> ".drvPath")) (mkStr expected)) - dependency = "let d = derivation { name = \"d\"; system = \"x\"; builder = \"b\"; }; in " - envResult <- evalDerivationIO tmpBase (structured "outputs = [ \"out\" \"dev\" \"lib\" ];") - -- A file for the outPath that is a path, copied to the store as upstream - -- copies it: "hello\n" named x is m5zd3qj7...-x there. - let jsonDir = tmpBase "nova-nix-test-json-outpath" - createDirectoryIfMissing True jsonDir - BS.writeFile (jsonDir "x") "hello\n" - copiedOutPath <- evalNixIO jsonDir "builtins.unsafeDiscardStringContext (builtins.toJSON { outPath = ./x; })" - lengthOfPath <- evalNixIO jsonDir "builtins.stringLength ./x" - substringOfPath <- evalNixIO jsonDir "builtins.substring 11 32 ./x" - substringContext <- evalNixIO jsonDir "builtins.hasContext (builtins.substring 11 32 ./x)" - discardedPath <- evalNixIO jsonDir "builtins.unsafeDiscardStringContext ./x" - discardedContext <- evalNixIO jsonDir "builtins.hasContext (builtins.unsafeDiscardStringContext ./x)" - copiedContext <- evalNixIO jsonDir "builtins.attrNames (builtins.getContext (builtins.toJSON { outPath = ./x; })) == [ \"/nix/store/m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg-x\" ]" - -- The IO evaluator, because it is the one with a store to copy into. - uncopiedPath <- evalNixIO jsonDir "builtins.toJSON { __toString = s: ./x; }" - uncopiedNested <- evalNixIO jsonDir "builtins.toJSON { __toString = s: { outPath = ./x; }; }" - removeDirectoryRecursive jsonDir - let jsonDirPath = mkStr ("\"" <> canonPathValue (T.pack (jsonDir "x")) <> "\"") - sequence - [ drvPathIs - "a nested set and a mixed list are one JSON object" - "nested = { a = 1; b = { c = [ \"x\" \"y\" ]; }; \"with space\" = true; }; list = [ \"a\" \"b c\" 1 2.5 null true false ];" - "/nix/store/rkxyljjwm2miccr3ffbkvgm7fzmjqddg-sa.drv", - drvPathIs - "scalars render as nlohmann renders them" - "i = 42; neg = -7; f = 1.0; f2 = 0.1; big = 1.0e20; small = 1.0e-7; b = true; n = null; s = \"str\\n\\t\\\"q\\\"\\\\\";" - "/nix/store/hgzhpjmp6cpjj0r768xp982an303rh2q-sa.drv", - drvPathIs - "member names order by their bytes" - "\"\233\" = 1; \"Z\" = 2; \"a\" = 3; \"_\" = 4; \"1x\" = 5;" - "/nix/store/s2aaxxxqvmdh95wqq3sa75fqal0nv2vf-sa.drv", - drvPathIs "a kept null is a JSON null" "n = null;" "/nix/store/r3880xygjwsqk8a4xiq8zrbhpanlf9a3-sa.drv", - drvPathIs - "__ignoreNulls leaves a null out of the object" - "n = null; __ignoreNulls = true;" - "/nix/store/cms7b67rf9bn7b376f64i05v1cw2chrh-sa.drv", - drvPathIs - "a placeholder stays a placeholder in the object" - "here = builtins.placeholder \"out\";" - "/nix/store/2iqn1i3rl4x9ll8a6j46k1rkk9c3fkd5-sa.drv", - drvPathIs - "a fixed-output derivation keeps its hash fields in the object" - "outputHash = \"sha256-47DEQpj8HBSKTXA6xJbgU1CNMmz7W08F06XOTYP1hmM=\"; outputHashMode = \"flat\"; outputHashAlgo = \"sha256\";" - "/nix/store/dp6sib5psffrm1krca5l9wn9nshspn7f-sa.drv", - drvPathIs - "a set under outputChecks is passed as it is" - "outputChecks.out = { allowedReferences = [ ]; maxSize = 100; };" - "/nix/store/xzkk2dxqm69akjjshlvk45s8yd6y1dbn-sa.drv", - runTest "__structuredAttrs = false keeps one variable per attribute" $ - assertEval - "sa-false" - (withoutContext "(derivation { name = \"sa\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; __structuredAttrs = false; x = [ \"a\" \"b\" ]; }).drvPath") - (mkStr "/nix/store/i9rm0fa7pbzrbrsaakninfa4232wmj7c-sa.drv"), - runTest "every output of a structured derivation gets upstream's path" $ - assertEval - "sa-outputs" - (withoutContext (structured "outputs = [ \"out\" \"dev\" \"lib\" ];" <> ".dev.outPath")) - (mkStr "/nix/store/jfnikb9k7953srg5mlp3mccmqaijvxyy-sa-dev"), - runTest "the environment holds __json and the outputs, nothing else" $ - assertRight "sa-env" envResult $ \drv -> - assertEqual - "sa-env" - [ ("__json", "{\"builder\":\"/bin/sh\",\"name\":\"sa\",\"outputs\":[\"out\",\"dev\",\"lib\"],\"system\":\"x86_64-linux\"}"), - ("dev", "/nix/store/jfnikb9k7953srg5mlp3mccmqaijvxyy-sa-dev"), - ("lib", "/nix/store/zpjd7d2l5jqzynv3377a36nk6rzb5il4-sa-lib"), - ("out", "/nix/store/bs6ppbphi38qlbjfz67pfk86sx7l4vks-sa") - ] - (Map.toList (drvEnv drv)), - -- toJSON's rules for a set, which the object above shares. - runTest "toJSON of a set with outPath converts the outPath value, not its string" $ - assertEval "json-outpath-int" "builtins.toJSON { outPath = 1; }" (mkStr "1") - `andThen` assertEval "json-outpath-set" "builtins.toJSON { outPath = { a = 1; }; }" (mkStr "{\"a\":1}") - `andThen` assertEval "json-outpath-list" "builtins.toJSON { outPath = [ 1 { outPath = 2; } ]; }" (mkStr "[1,2]") - `andThen` assertEval "json-outpath-null" "builtins.toJSON { outPath = null; }" (mkStr "null"), - runTest "toJSON of a set whose outPath is a path copies it to the store, with context" $ - assertRight "json-outpath-path" copiedOutPath (assertEqual "json-outpath-path" (mkStr "\"/nix/store/m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg-x\"")) - `andThen` assertRight "json-outpath-path-context" copiedContext (assertEqual "json-outpath-path-context" (VBool True)), - runTest "a builtin taking a string copies a path to the store first" $ - assertRight "strlen-path" lengthOfPath (assertEqual "strlen-path" (VInt 45)) - `andThen` assertRight "substring-path" substringOfPath (assertEqual "substring-path-text" "m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg" . stringBytes) - `andThen` assertRight "substring-path-context" substringContext (assertEqual "substring-path-context" (VBool True)) - `andThen` assertRight "discard-path" discardedPath (assertEqual "discard-path" (mkStr "/nix/store/m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg-x")) - `andThen` assertRight "discard-path-context" discardedContext (assertEqual "discard-path-context" (VBool False)), - runTest "toJSON of a __toString set returning a path keeps the path's own text, uncopied" $ - assertRight "json-tostring-path" uncopiedPath (assertEqual "json-tostring-path" jsonDirPath) - `andThen` assertRight "json-tostring-nested" uncopiedNested (assertEqual "json-tostring-nested" jsonDirPath), - runTest "toJSON of a __toString set returning a string keeps its context" $ - let json = "(builtins.toJSON { __toString = s: \"${d}\"; })" - in assertEval "json-tostring-string" (dependency <> withoutContext json) (mkStr "\"/nix/store/74ii7m3ms7x609g9mcy8j52jfvpdizcp-d\"") - `andThen` assertEval - "json-tostring-context" - (dependency <> "builtins.getContext " <> json <> " == { \"/nix/store/nzvhjdd45mdh8mkqm4vz4hdqsjrvkm8j-d.drv\" = { outputs = [ \"out\" ]; }; }") - (VBool True), - runTest "toJSON of a __toString set returning an integer is an error, not a coercion" $ - assertEvalFail "json-tostring-int" "builtins.toJSON { __toString = s: 1; }", - drvPathIs - "a structured attribute's outPath and __toString follow toJSON's rules" - "o = { outPath = { inner = 1; }; }; i = { outPath = 1; }; t = { __toString = s: \"str\"; };" - "/nix/store/rz7pfawzsr1a5ig11s1xssbsc2mxys9b-sa.drv", - runTest "toJSON escapes backspace and form feed by name" $ - assertEval - "json-bf" - "builtins.toJSON (builtins.fromJSON \"\\\"\\\\u0008\\\\u000c\\\\u0001\\\"\")" - (mkStr "\"\\b\\f\\u0001\""), - runTest "__structuredAttrs must be a boolean" $ - assertEvalFail "sa-flag" "(derivation { name = \"sa\"; system = \"x\"; builder = \"b\"; __structuredAttrs = \"yes\"; }).drvPath", - runTest "a structured system may not refer to a store path" $ - assertEvalError - "sa-system-ctx" - (dependency <> "(derivation { name = \"sa\"; builder = \"/bin/sh\"; __structuredAttrs = true; system = \"${d}\"; }).drvPath") - "the string '/nix/store/74ii7m3ms7x609g9mcy8j52jfvpdizcp-d' is not allowed to refer to a store path (such as '!out!nzvhjdd45mdh8mkqm4vz4hdqsjrvkm8j-d.drv')", - runTest "a structured output name may not refer to a store path" $ - assertEvalError - "sa-output-ctx" - (dependency <> structured "outputs = [ \"out\" \"${d}\" ];" <> ".drvPath") - "the string '/nix/store/74ii7m3ms7x609g9mcy8j52jfvpdizcp-d' is not allowed to refer to a store path (such as '!out!nzvhjdd45mdh8mkqm4vz4hdqsjrvkm8j-d.drv')", - runTest "a structured builder must be a string, not a value coerced to one" $ - assertEvalError - "sa-builder" - "(derivation { name = \"sa\"; system = \"x\"; __structuredAttrs = true; builder = 1; }).drvPath" - "expected a string but found an integer: 1", - runTest "a structured outputHash must be a string" $ - assertEvalError "sa-outputhash" (structured "outputHash = 1;" <> ".drvPath") "expected a string but found an integer: 1", - runTest "a function cannot become JSON" $ - assertEvalFail "sa-function" (structured "f = x: x;" <> ".drvPath"), - -- The JSON both halves share. - runTest "JSON escapes control characters as nlohmann does" $ - assertEqual - "json-escape" - (TE.encodeUtf8 "\"a\\b\\f\\n\\r\\t\\u0001\\u001f\127/\\\"\\\\\233\"") - (renderJson (JsonString "a\b\f\n\r\t\1\31\127/\"\\\233")), - runTest "JSON numbers render as nlohmann renders them" $ - assertEqual - "json-numbers" - "[1.0,1e+20,1e-07,0.1,null,null,-7,18446744073709551615]" - (renderJson (JsonArray [JsonFloat 1, JsonFloat 1e20, JsonFloat 1e-7, JsonFloat 0.1, JsonFloat (1 / 0), JsonFloat (0 / 0), JsonInt (-7), JsonInt 18446744073709551615])), - runTest "upstream's .attrs.json reads back and renders to the same bytes" $ - assertRight "json-upstream" (decodeStructuredAttrs upstreamAttrsJson) $ \attrs -> - assertEqual "json-upstream" (TE.encodeUtf8 upstreamAttrsJson) (encodeStructuredAttrs attrs), - runTest "the .attrs.sh renderer writes what upstream writes" $ - assertRight "attrs-sh" (decodeStructuredAttrs upstreamAttrsJson) $ \attrs -> - assertEqual "attrs-sh" upstreamAttrsShell (renderAttrsShell attrs), - runTest "outputs become an object of placeholders" $ - assertEqual - "outputs-object" - (StructuredAttrs (Map.fromList [("outputs", JsonObject (Map.fromList [("dev", JsonString (hashPlaceholder "dev")), ("out", JsonString (hashPlaceholder "out"))]))])) - (withOutputPlaceholders ["out", "dev"] (StructuredAttrs (Map.fromList [("outputs", JsonArray [JsonString "out", JsonString "dev"])]))), - runTest "a null __json is an empty object, another non-object an error" $ - assertEqual "decode-shape" (Right (StructuredAttrs Map.empty)) (decodeStructuredAttrs "null") - `andThen` assertLeft "decode-array" (decodeStructuredAttrs "[1]"), - runTest "a list-of-strings attribute is read strictly" $ - let attrs = StructuredAttrs (Map.fromList [("good", JsonArray [JsonString "a", JsonString "b"]), ("mixed", JsonArray [JsonString "a", JsonInt 1]), ("scalar", JsonString "a b")]) - in assertEqual "strings-good" (Right (Just ["a", "b"])) (stringsAttr "good" attrs) - `andThen` assertEqual "strings-absent" (Right Nothing) (stringsAttr "absent" attrs) - `andThen` assertLeft "strings-mixed" (stringsAttr "mixed" attrs) - `andThen` assertLeft "strings-scalar" (stringsAttr "scalar" attrs), - runTest "JSON parsing decodes every escape, surrogate pairs included" $ - assertEqual - "parse-escapes" - (Right (JsonString "\"\\/\b\f\n\r\t\233\128512")) - (parseJson "\"\\\"\\\\\\/\\b\\f\\n\\r\\t\\u00E9\\ud83d\\ude00\""), - runTest "JSON parsing keeps integers apart from floats, as nlohmann's lexer does" $ - assertEqual - "parse-numbers" - (Right (JsonArray [JsonInt 18446744073709551615, JsonFloat 18446744073709551616, JsonInt (-9223372036854775808), JsonFloat (-9223372036854775809), JsonInt 0, JsonFloat 1, JsonFloat 100])) - (parseJson "[18446744073709551615,18446744073709551616,-9223372036854775808,-9223372036854775809,-0,1.0,1E2]"), - runTest "JSON parsing takes the last of a repeated name, whitespace and a byte order mark around" $ - assertEqual - "parse-object" - (Right (JsonObject (Map.fromList [("a", JsonArray [JsonInt 2, JsonNull])]))) - (parseJson "\65279 \n{ \"a\" : 1 , \"a\":[ 2 ,null ] }\r\n"), - runTest "JSON parsing refuses what nlohmann refuses" $ - foldr - (\bad acc -> assertLeft ("parse-refuses " <> bad) (parseJson bad) `andThen` acc) - Pass - ["\"a\tb\"", "01", "[1,]", "1e400", "{\"a\" 1}", "tru", "1 2", "\"\\ud800\"", "\"\\udc00\"", "\"\\x\"", "1.", "-", "\"unterminated", ""], - runTestM "rendered JSON parses back to the value it came from" $ do - result <- - QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ - QC.forAll (genJson 3) $ \json -> - (parseJson =<< either (Left . T.pack . show) Right (TE.decodeUtf8' (renderJson json))) QC.=== Right json - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - ] - --- | A subset of the @.attrs.json@ a Nix 2.33.2 build handed its builder --- (the members holding no store path), byte for byte. -upstreamAttrsJson :: Text -upstreamAttrsJson = - "{\"1x\":\"skipped\",\"badList\":[\"a\",[\"nested\"]],\"badObj\":{\"k\":{\"nested\":1}},\"big\":1099511627776,\"ctl\":\"a\\b\\f\\u0001\\u001f\127/\\\"\\\\z\",\"emptyList\":[],\"emptyObj\":{},\"f\":1.5,\"fbig\":1e+20,\"fi\":3.0,\"fl\":false,\"fltList\":[1.5],\"fltObj\":{\"a\":1,\"b\":2.5},\"fneg\":-1e+20,\"fneg2\":-2.5,\"fsmall\":0.1,\"ftrunc\":16777217.5,\"huge\":9223372036854775807,\"int\":42,\"list\":[\"a\",\"b c\",1,2.0,true,false,null],\"n\":null,\"neg\":-7,\"obj\":{\"b\":false,\"k\":\"v\",\"key with space\":1,\"q\":\"'\"},\"str\":\"it's a \\\"test\\\"\\n\",\"t\":true,\"uni\":\"\233\8364\128512\",\"with space\":\"skipped\"}" - --- | The lines of that build's @.attrs.sh@ for the members of --- 'upstreamAttrsJson'. Missing ones (a non-integral number, a nested --- array or object, a name bash cannot hold) are upstream's omissions; --- @fbig@ and @fneg@ are aarch64's saturating float conversion. -upstreamAttrsShell :: Text -upstreamAttrsShell = - "declare big=0\ndeclare ctl='a\8\12\1\31\127/\"\\z'\ndeclare -a emptyList=()\ndeclare -A emptyObj=()\ndeclare fbig=2147483647\ndeclare fi=3\ndeclare fl=\ndeclare fneg=-2147483648\ndeclare ftrunc=16777217\ndeclare huge=-1\ndeclare int=42\ndeclare -a list=('a' 'b c' 1 2 1 '' )\ndeclare n=''\ndeclare neg=-7\ndeclare -A obj=(['b']= ['k']='v' ['key with space']=1 ['q']=''\\''' )\ndeclare str='it'\\''s a \"test\"\n'\ndeclare t=1\ndeclare uni='\233\8364\128512'\n" - --- | JSON values up to a nesting depth, strings drawn from what the --- renderer escapes and what it passes through as UTF-8, numbers across --- both integer types and finite floats. -genJson :: Int -> QC.Gen Json -genJson depth = QC.oneof (scalars <> [nested | depth > 0]) - where - scalars = - [ pure JsonNull, - JsonBool <$> QC.arbitrary, - JsonInt . toInteger <$> (QC.arbitrary :: QC.Gen Int64), - JsonInt . toInteger <$> (QC.arbitrary :: QC.Gen Word64), - JsonFloat <$> (QC.arbitrary `QC.suchThat` (\d -> not (isNaN d || isInfinite d))), - JsonString <$> genJsonText - ] - nested = - QC.oneof - [ JsonArray <$> QC.resize 4 (QC.listOf (genJson (depth - 1))), - JsonObject . Map.fromList <$> QC.resize 4 (QC.listOf ((,) <$> genJsonText <*> genJson (depth - 1))) - ] - --- | Text mixing the characters JSON escapes with plain and multi-byte ones. -genJsonText :: QC.Gen Text -genJsonText = - T.pack <$> QC.listOf (QC.elements ['"', '\\', '/', '\b', '\f', '\n', '\r', '\t', '\0', '\31', '\127', 'a', ' ', '\233', '\8364', '\128512']) - --- --------------------------------------------------------------------------- --- Tests: Derivation context + new builtins (Phase 3, Batch 4) --- --------------------------------------------------------------------------- - -testDrvContext :: IO [Bool] -testDrvContext = do - putStrLn "eval/drv-context" - sequence - [ -- hasContext: plain string has no context - runTest "hasContext on plain string" $ - assertEval "hasCtx-plain" "builtins.hasContext \"hello\"" (VBool False), - -- hasContext: derivation outPath has context - runTest "hasContext on drv outPath" $ - assertEval - "hasCtx-drv" - "builtins.hasContext (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath" - (VBool True), - -- hasContext: after discardContext, no context - runTest "hasContext after discard" $ - assertEval - "hasCtx-discard" - "builtins.hasContext (builtins.unsafeDiscardStringContext (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath)" - (VBool False), - -- getContext: plain string returns empty attrset - runTest "getContext on plain string" $ - assertRight "getCtx-plain" (evalNix "builtins.getContext \"hello\"") $ \val -> - case val of - VAttrs m -> if attrSetNull m then Pass else Fail "expected empty attrset" - _ -> Fail ("expected VAttrs, got " <> T.pack (show val)), - -- getContext: drv outPath has outputs entry - runTest "getContext on drv outPath" - $ assertRight - "getCtx-drv" - (evalNix "builtins.getContext (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath") - $ \val -> case val of - VAttrs m -> - if attrSetSize m == 1 - then Pass - else Fail ("expected 1 entry, got " <> T.pack (show (attrSetSize m))) - _ -> Fail ("expected VAttrs, got " <> T.pack (show val)), - -- getContext: drvPath has allOutputs - runTest "getContext on drvPath has allOutputs" - $ assertRight - "getCtx-drvPath" - (evalNix "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ctx = builtins.getContext d.drvPath; in builtins.length (builtins.attrNames ctx)") - $ \val -> assertEqual "one-entry" (VInt 1) val, - -- getContext keys are identity: canonical /nix/store spelling on - -- every platform, never the platform file-path mapping. - runTest "getContext key is canonical store path" - $ assertRight - "getCtx-canonical" - (evalNix "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in builtins.elemAt (builtins.attrNames (builtins.getContext d.drvPath)) 0") - $ \val -> case val of - VStr key _ - | "/nix/store/" `BS.isPrefixOf` key && not ("\\" `BS.isInfixOf` key) -> Pass - | otherwise -> Fail ("expected a canonical /nix/store key, got " <> bytesText key) - _ -> Fail ("expected VStr, got " <> T.pack (show val)), - -- appendContext: adds context to plain string - runTest "appendContext adds context" $ - assertEval - "appendCtx-add" - "let ctx = builtins.listToAttrs [{ name = \"/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo\"; value = { path = true; }; }]; in builtins.hasContext (builtins.appendContext \"hello\" ctx)" - (VBool True), - -- appendContext: empty context is no-op - runTest "appendContext empty is no-op" $ - assertEval "appendCtx-empty" "builtins.hasContext (builtins.appendContext \"hello\" {})" (VBool False), - -- unsafeDiscardOutputDependency KEEPS a derivation-output (Built) ref - -- unchanged (upstream), rather than dropping it as it once did. - runTest "discardOutputDep keeps output-dependency context" - $ assertRight - "discardOutDep-keep" - ( evalNix $ - T.concat - [ "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ", - "stripped = builtins.unsafeDiscardOutputDependency d.outPath; ", - "in builtins.hasContext stripped" - ] - ) - $ \val -> assertEqual "keep-ctx" (VBool True) val, - -- ctx3: an all-outputs (DrvDeep) reference on d.drvPath is DOWNGRADED to - -- a plain path reference, not dropped. - runTest "discardOutputDep downgrades drvPath to a plain ref" $ - assertEval - "discardOutDep-downgrade" - "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ctx = builtins.getContext (builtins.unsafeDiscardOutputDependency d.drvPath); key = builtins.elemAt (builtins.attrNames ctx) 0; in ctx.${key} == { path = true; }" - (VBool True), - -- ctx4: getContext renders each path's output names ascending. - runTest "getContext output names are ascending" $ - assertEval - "getctx-ascending" - "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ \"out\" \"dev\" \"lib\" ]; }; s = \"${d.out}${d.lib}${d.dev}\"; ctx = builtins.getContext s; key = builtins.elemAt (builtins.attrNames ctx) 0; in ctx.${key}.outputs == [ \"dev\" \"lib\" \"out\" ]" - (VBool True), - -- ctx5: addDrvOutputDependencies upgrades a plain .drv reference back to - -- an all-outputs reference (the inverse of the ctx3 downgrade). - runTest "addDrvOutputDependencies upgrades a plain drv ref" $ - assertEval - "adddrvout-upgrade" - "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; plain = builtins.unsafeDiscardOutputDependency d.drvPath; ctx = builtins.getContext (builtins.addDrvOutputDependencies plain); key = builtins.elemAt (builtins.attrNames ctx) 0; in ctx.${key} == { allOutputs = true; }" - (VBool True), - runTest "addDrvOutputDependencies rejects a derivation output" $ - assertEvalFail - "adddrvout-built" - "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in builtins.addDrvOutputDependencies d.outPath", - runTest "addDrvOutputDependencies rejects a multi-element context" $ - assertEvalFail - "adddrvout-multi" - "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in builtins.addDrvOutputDependencies \"${d.drvPath}${d.outPath}\"", - -- drv1: a derivation embedding another's drvPath (an all-outputs ref) - -- needs the referenced .drv's output names, which only the IO evaluator - -- supplies; pure eval fails loudly rather than dropping the reference. - runTest "deep drvPath reference fails loudly in pure eval" $ - assertEvalFail - "drv1-pure-miss" - "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ref = dep.drvPath; }; in main.drvPath", - -- derivation outPath is a string (not path) with context - runTest "drv outPath is VStr" - $ assertRight - "drv-outPath-type" - (evalNix "builtins.typeOf (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath") - $ \val -> assertEqual "string-type" (mkStr "string") val, - -- derivation drvPath is a string (not path) with context - runTest "drv drvPath is VStr" - $ assertRight - "drv-drvPath-type" - (evalNix "builtins.typeOf (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).drvPath") - $ \val -> assertEqual "string-type" (mkStr "string") val, - -- hasContext error on non-string - runTest "hasContext type error" $ - assertEvalFail "hasCtx-err" "builtins.hasContext 42", - -- getContext error on non-string - runTest "getContext type error" $ - assertEvalFail "getCtx-err" "builtins.getContext 42", - -- appendContext error on non-string first arg - runTest "appendContext type error" $ - assertEvalFail "appendCtx-err" "builtins.appendContext 42 {}", - -- deterministic: same derivation produces same paths - runTest "derivation with context deterministic" - $ assertRight - "drv-det-ctx" - (evalNix "let d1 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; d2 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d1.outPath == d2.outPath") - $ \val -> assertEqual "deterministic" (VBool True) val - ] - --- --------------------------------------------------------------------------- --- Tests: DependencyGraph (Phase 3, Batch 5) --- --------------------------------------------------------------------------- - --- | 'DepGraph.buildDepGraph' over a pure .drv lookup. -pureDepGraph :: (StorePath -> Either Text Derivation) -> Derivation -> StorePath -> Either Text DepGraph.DepGraph -pureDepGraph readDrv rootDrv rootPath = runIdentity (DepGraph.buildDepGraph (Identity . readDrv) rootDrv rootPath) - -testDepGraph :: IO [Bool] -testDepGraph = do - putStrLn "dep-graph" - let mkSP = StorePath - spA = mkSP "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "a.drv" - spB = mkSP "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "b.drv" - spC = mkSP "cccccccccccccccccccccccccccccccccc" "c.drv" - spD = mkSP "dddddddddddddddddddddddddddddddd" "d.drv" - baseDrv = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/sh", - drvArgs = [], - drvEnv = Map.empty - } - -- Single node: A has no deps - drvA = baseDrv - -- Linear chain: B depends on C - drvB = baseDrv {drvInputDrvs = Map.singleton spC ["out"]} - -- C has no deps - drvC = baseDrv - -- Diamond: D depends on B and C, B depends on C - drvD = baseDrv {drvInputDrvs = Map.fromList [(spB, ["out"]), (spC, ["out"])]} - -- Cycle: A depends on B, B depends on A - drvACycle = baseDrv {drvInputDrvs = Map.singleton spB ["out"]} - drvBCycle = baseDrv {drvInputDrvs = Map.singleton spA ["out"]} - readSingle _ = Left "not found" - readChain sp - | sp == spC = Right drvC - | otherwise = Left ("unknown drv: " <> spName sp) - readDiamond sp - | sp == spB = Right drvB - | sp == spC = Right drvC - | otherwise = Left ("unknown drv: " <> spName sp) - readCycle sp - | sp == spB = Right drvBCycle - | sp == spA = Right drvACycle - | otherwise = Left ("unknown drv: " <> spName sp) - -- Self-loop: A depends on itself - drvSelf = baseDrv {drvInputDrvs = Map.singleton spA ["out"]} - readSelf sp - | sp == spA = Right drvSelf - | otherwise = Left ("unknown drv: " <> spName sp) - sequence - [ -- Single node - runTest "single node graph" $ case pureDepGraph readSingle drvA spA of - Right (DepGraph.DepGraph g) -> assertEqual "single-size" 1 (Map.size g) - Left err -> Fail ("unexpected error: " <> err), - -- Linear chain A to C: topoSort should give [C, A] - runTest "linear chain topo" $ case pureDepGraph readChain drvB spB of - Right graph -> case DepGraph.topoSort graph of - DepGraph.TopoSorted order -> - case order of - [first, _] | first == spC -> Pass - _ -> Fail ("bad order: " <> T.pack (show order)) - DepGraph.TopoCycle cyc -> Fail ("unexpected cycle: " <> T.pack (show cyc)) - Left err -> Fail ("graph build failed: " <> err), - -- Diamond D to B,C; B to C: topoSort should have C first, D last - runTest "diamond topo" $ case pureDepGraph readDiamond drvD spD of - Right graph -> case DepGraph.topoSort graph of - DepGraph.TopoSorted order -> - case order of - [first, _, lastElem] | first == spC, lastElem == spD -> Pass - _ -> Fail ("bad diamond order: " <> T.pack (show order)) - DepGraph.TopoCycle cyc -> Fail ("unexpected cycle: " <> T.pack (show cyc)) - Left err -> Fail ("graph build failed: " <> err), - -- transitiveDeps - runTest "transitiveDeps diamond" $ case pureDepGraph readDiamond drvD spD of - Right graph -> - let deps = DepGraph.transitiveDeps graph spD - in if Set.size deps == 2 && Set.member spB deps && Set.member spC deps - then Pass - else Fail ("bad transitive deps: " <> T.pack (show deps)) - Left err -> Fail ("graph build failed: " <> err), - -- directDeps - runTest "directDeps diamond" $ case pureDepGraph readDiamond drvD spD of - Right graph -> - let deps = DepGraph.directDeps graph spD - in assertEqual "direct-count" 2 (length deps) - Left err -> Fail ("graph build failed: " <> err), - -- Missing .drv causes failure - runTest "missing drv fails" $ case pureDepGraph readSingle drvB spB of - Left _ -> Pass - Right _ -> Fail "expected failure for missing drv", - -- Single node topoSort - runTest "single node topoSort" $ case pureDepGraph readSingle drvA spA of - Right graph -> case DepGraph.topoSort graph of - DepGraph.TopoSorted [x] -> assertEqual "single-topo" spA x - other -> Fail ("unexpected topo result: " <> T.pack (show other)) - Left err -> Fail ("graph build failed: " <> err), - -- buildDepGraph with mock for cycle detection - -- (Cycle detection happens at topoSort level, not buildDepGraph) - runTest "cycle detection" $ case pureDepGraph readCycle drvACycle spA of - Right graph -> case DepGraph.topoSort graph of - DepGraph.TopoCycle _ -> Pass - -- A "sorted" cyclic graph means Kahn's silently dropped the - -- cycle: buildWithDeps would then loop or build with unbuilt - -- inputs. - DepGraph.TopoSorted order -> - Fail ("cyclic graph topo-sorted as " <> T.pack (show (length order)) <> " nodes") - -- A loud rejection at graph-build time also counts as detection. - Left _ -> Pass, - -- A root that depends on itself: the walk marks the root visited - -- on enqueue, so it terminates - and per contract the result - -- excludes the root, leaving nothing. - runTestM "transitiveDeps terminates on a self-loop" $ do - outcome <- - timeout walkWatchdogMicros $ - evaluate $ case pureDepGraph readSelf drvSelf spA of - Left _ -> Nothing - Right graph -> Just $! DepGraph.transitiveDeps graph spA - pure $ case outcome of - Nothing -> Fail "did not terminate on a self-loop" - Just Nothing -> Fail "graph build failed" - Just (Just deps) -> assertEqual "self-loop deps" Set.empty deps, - -- A two-node cycle already terminated; pin that the root stays - -- excluded from its own transitive closure. - runTestM "transitiveDeps two-node cycle excludes the root" $ do - outcome <- - timeout walkWatchdogMicros $ - evaluate $ case pureDepGraph readCycle drvACycle spA of - Left _ -> Nothing - Right graph -> Just $! DepGraph.transitiveDeps graph spA - pure $ case outcome of - Nothing -> Fail "did not terminate on a cycle" - Just Nothing -> Fail "graph build failed" - Just (Just deps) -> assertEqual "cycle deps" (Set.singleton spB) deps - ] - --- --------------------------------------------------------------------------- --- Tests: Substituter (Phase 3, Batch 6) --- --------------------------------------------------------------------------- - --- | A fake HTTP body reader: yields the given chunks, then empty --- forever (an HTTP BodyReader is just an IO ByteString). -chunkReader :: [BS.ByteString] -> IO (IO BS.ByteString) -chunkReader chunks = do - ref <- newIORef chunks - pure $ - atomicModifyIORef' ref $ \case - [] -> ([], BS.empty) - (c : cs) -> (cs, c) - --- | Drain a chunk source to its byte count - the shape of a streaming --- consumer, for tests that only care whether the pipeline fails. -drainChunkSource :: IO BS.ByteString -> IO (Either Subst.AttemptFailure Int) -drainChunkSource pull = go 0 - where - go n = do - chunk <- pull - if BS.null chunk - then pure (Right n) - else let total = n + BS.length chunk in total `seq` go total - -testSubstituter :: IO [Bool] -testSubstituter = do - putStrLn "substituter" - -- Every tree this group materializes under the temp directory keys - -- sibling names the way a store on that volume would. - tmpSensitivity <- tempCaseSensitivity - sequence - [ -- sortCaches: priority ordering - runTest "sortCaches priority ordering" $ - let c1 = Subst.CacheConfig "https://a.example.com" ["key-a"] 40 - c2 = Subst.CacheConfig "https://b.example.com" ["key-b"] 10 - c3 = Subst.CacheConfig "https://c.example.com" ["key-c"] 30 - sorted = Subst.sortCaches [c1, c2, c3] - in case sorted of - [s1, s2, s3] -> - if Subst.ccPriority s1 == 10 && Subst.ccPriority s2 == 30 && Subst.ccPriority s3 == 40 - then Pass - else Fail ("bad order: " <> T.pack (show (map Subst.ccPriority sorted))) - _ -> Fail "expected 3 caches", - -- sortCaches: empty list - runTest "sortCaches empty" $ - assertEqual "empty-sort" [] (Subst.sortCaches []), - -- readBodyCapped: the client-side body cap (mirror of the server's - -- readBodyLimited). A body reader is just IO ByteString yielding - -- chunks then empty. - runTestM "readBodyCapped concatenates under the cap" $ do - reader <- chunkReader ["abc", "def", "g"] - body <- Subst.readBodyCapped 10 reader - pure (assertEqual "under cap" (Just "abcdefg") body), - runTestM "readBodyCapped allows exactly the cap" $ do - reader <- chunkReader ["abcde", "fghij"] - body <- Subst.readBodyCapped 10 reader - pure (assertEqual "at cap" (Just "abcdefghij") body), - runTestM "readBodyCapped aborts past the cap" $ do - reader <- chunkReader ["abcdef", "ghijkl"] - body <- Subst.readBodyCapped 10 reader - pure (assertEqual "over cap" Nothing body), - -- decompressorFor decides support from the narinfo's declared - -- values alone, so unsupported compression rejects before any - -- NAR download; xz resolves a bounded decompressor. - runTest "decompressorFor xz resolves" $ - case Subst.decompressorFor 1024 "xz" of - Right _ -> Pass - Left err -> Fail ("xz rejected: " <> err), - runTestM "decompressorFor none is identity" $ - case Subst.decompressorFor 5 "none" of - Right decompress -> assertEqual "identity" (Right "bytes") <$> decompress "bytes" - Left err -> pure (Fail ("expected none to be supported, got: " <> err)), - -- verifyNarSize: the declared NarSize is a signed claim that flows - -- into the store DB, so it must equal the downloaded byte count. - runTest "verifyNarSize accepts matching size" $ - assertEqual - "narsize-match" - (Right ()) - (Subst.verifyNarSize ((sampleNarInfo sampleNarHash) {NarInfo.niNarSize = toInteger (BS.length sampleNarBytes)}) sampleNarBytes), - runTest "verifyNarSize rejects mismatched size" $ - case Subst.verifyNarSize ((sampleNarInfo sampleNarHash) {NarInfo.niNarSize = toInteger (BS.length sampleNarBytes) + 1}) sampleNarBytes of - Left err | "size mismatch" `T.isInfixOf` err -> Pass - other -> Fail ("expected size mismatch, got: " <> T.pack (show other)), - -- decompressNar: "none" passes through - runTestM "decompressNar none" $ - let input = "fake nar data" - in assertEqual "decompress-none" (Right input) <$> Subst.decompressNar (toInteger (BS.length input)) "none" input, - -- decompressNar: an empty Compression field means bzip2 upstream - -- (the field's historical default), never identity, so the empty - -- spelling must decode a real bzip2 body exactly as the named - -- one does. - runTestM "decompressNar empty means bzip2" $ - case B64.decode bzip2FixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - out <- Subst.decompressNar xzFixtureSize "" compressed - pure $ case out of - Right decoded -> assertEqual "empty-is-bzip2" xzFixturePayload decoded - Left err -> Fail ("empty Compression failed to decode as bzip2: " <> err), - -- decompressNar: bzip2 decodes under the same declared-NarSize - -- bound as the other codecs; the fixture comes from the bzip2 - -- CLI, so the decoder is checked against the format's own - -- reference encoder rather than its own library. - runTestM "decompressNar bzip2 bounded roundtrip" $ - case B64.decode bzip2FixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - out <- Subst.decompressNar xzFixtureSize "bzip2" compressed - pure $ case out of - Right decoded -> assertEqual "bzip2-roundtrip" xzFixturePayload decoded - Left err -> Fail ("bzip2 roundtrip failed: " <> err), - runTestM "decompressNar bzip2 over-bound rejects" $ - case B64.decode bzip2FixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - out <- Subst.decompressNar (xzFixtureSize - 1) "bzip2" compressed - pure $ case out of - Left err | "NarSize" `T.isInfixOf` err -> Pass - other -> Fail ("expected over-bound rejection, got: " <> T.pack (show other)), - -- decompressNar: xz decodes under the declared-NarSize bound - -- (the fixture is a real 112-byte xz stream of 1792 payload - -- bytes, embedded base64 to keep the source ASCII). - runTestM "decompressNar xz bounded roundtrip" $ - case B64.decode xzFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - out <- Subst.decompressNar xzFixtureSize "xz" compressed - pure $ case out of - Right decoded -> assertEqual "xz-roundtrip" xzFixturePayload decoded - Left err -> Fail ("xz roundtrip failed: " <> err), - -- The output bound is exact: one byte under the real size must - -- refuse, naming the declared NarSize. - runTestM "decompressNar xz over-bound rejects" $ - case B64.decode xzFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - out <- Subst.decompressNar (xzFixtureSize - 1) "xz" compressed - pure $ case out of - Left err | "NarSize" `T.isInfixOf` err -> Pass - other -> Fail ("expected over-bound rejection, got: " <> T.pack (show other)), - -- decompressNar: bytes that are not an xz stream are an error, - -- never silently passed through - runTestM "decompressNar xz garbage rejects" $ do - out <- Subst.decompressNar 64 "xz" "not an xz stream" - pure $ case out of - Left _ -> Pass - Right _ -> Fail "garbage decoded as xz", - -- decompressNar: zstd decodes under the same declared-NarSize - -- bound; the fixture compresses with the sublibrary's own - -- encoder, the same pairing the push path ships. - runTestM "decompressNar zstd bounded roundtrip" $ do - out <- Subst.decompressNar xzFixtureSize "zstd" zstdFixtureCompressed - pure $ case out of - Right decoded -> assertEqual "zstd-roundtrip" xzFixturePayload decoded - Left err -> Fail ("zstd roundtrip failed: " <> err), - runTestM "decompressNar zstd over-bound rejects" $ do - out <- Subst.decompressNar (xzFixtureSize - 1) "zstd" zstdFixtureCompressed - pure $ case out of - Left err | "NarSize" `T.isInfixOf` err -> Pass - other -> Fail ("expected over-bound rejection, got: " <> T.pack (show other)), - -- decompressNar: unknown compression - runTestM "decompressNar unknown" $ do - out <- Subst.decompressNar 4 "brotli" "data" - pure $ case out of - Left _ -> Pass - Right _ -> Fail "expected error for unknown", - -- parseReferences: narinfo references are wire-format basenames - runTest "parseReferences basenames" $ - let refs = ["aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello", "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-dep-2.0"] - expected = - [ StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello", - StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "dep-2.0" - ] - in assertEqual "parse-refs" (Right expected) (Subst.parseReferences refs), - -- parseReferences: a malformed token is a loud error, never dropped - runTest "parseReferences malformed rejected" $ - case Subst.parseReferences ["not-a-store-path"] of - Left _ -> Pass - Right refs -> Fail ("expected rejection, got: " <> T.pack (show refs)), - -- parseDeriver: basename becomes the DB's full path text - runTest "parseDeriver basename" $ - let sp = StorePath "cccccccccccccccccccccccccccccccc" "hello.drv" - expected = Just (T.pack (storePathToFilePath defaultStoreDir sp)) - in assertEqual "parse-deriver" (Right expected) (Subst.parseDeriver defaultStoreDir (Just "cccccccccccccccccccccccccccccccc-hello.drv")), - -- parseDeriver: upstream's unknown-deriver sentinel means no deriver - runTest "parseDeriver unknown sentinel" $ - assertEqual "parse-deriver-unknown" (Right Nothing) (Subst.parseDeriver defaultStoreDir (Just "unknown-deriver")), - -- parseDeriver: absent stays absent, malformed is an error - runTest "parseDeriver absent and malformed" $ - case (Subst.parseDeriver defaultStoreDir Nothing, Subst.parseDeriver defaultStoreDir (Just "bogus")) of - (Right Nothing, Left _) -> Pass - other -> Fail ("unexpected: " <> T.pack (show other)), - -- Recorded production narinfos from cache.nixos.org (paths this - -- codebase did not produce): the parse -> validate -> signature - -- pipeline against real cache data, the production ed25519 - -- signature verified offline with the shipped public key. - runTest "recorded cache.nixos.org narinfo verifies end to end" $ - case NarInfo.parseNarInfo recordedHelloNarInfo of - Left err -> Fail ("parse failed: " <> T.pack err) - Right ni -> - case Subst.validateNarInfoFields ni >> Subst.verifySigs Subst.defaultCacheConfig ni of - Left err -> Fail ("validate/verify failed: " <> err) - Right () -> assertEqual "compression" "xz" (NarInfo.niCompression ni), - -- References of a path built by Hydra, including the self - -- reference, and its Deriver - both produced by upstream Nix. - runTest "recorded narinfo references and deriver parse" $ - case NarInfo.parseNarInfo recordedHelloNarInfo of - Left err -> Fail ("parse failed: " <> T.pack err) - Right ni -> - case (Subst.parseReferences (NarInfo.niReferences ni), Subst.parseDeriver defaultStoreDir (NarInfo.niDeriver ni)) of - (Right refs, Right (Just _)) -> - assertEqual - "reference hashes" - ["dska0s3gxxd8azbsn85pwm6xcqhivldw", "jppkr0h8aap5z7m4xy4vg5yrwlly9h2v"] - (map spHash refs) - other -> Fail ("references/deriver did not parse: " <> T.pack (show other)), - -- The empty References line ("References: " with a trailing - -- space) production caches emit for leaf paths. - runTest "recorded no-reference narinfo verifies" $ - case NarInfo.parseNarInfo recordedHelloDocNarInfo of - Left err -> Fail ("parse failed: " <> T.pack err) - Right ni -> - case Subst.validateNarInfoFields ni >> Subst.verifySigs Subst.defaultCacheConfig ni >> Subst.parseReferences (NarInfo.niReferences ni) of - Right [] -> Pass - other -> Fail ("expected verified empty references, got: " <> T.pack (show other)), - -- The fingerprint covers NarSize: altering the signed claim must - -- break the production signature. - runTest "tampered recorded narinfo fails signature" $ - case NarInfo.parseNarInfo recordedHelloNarInfo of - Left err -> Fail ("parse failed: " <> T.pack err) - Right ni -> - case Subst.verifySigs Subst.defaultCacheConfig (ni {NarInfo.niNarSize = NarInfo.niNarSize ni + 1}) of - Left _ -> Pass - Right () -> Fail "signature verified over an altered NarSize", - -- Streaming pipeline: the chunk-fed download materializes, - -- hashes, and verifies without ever holding the NAR. The tree - -- carries the interesting shapes: nesting, an executable, a - -- symlink, and a sibling pair colliding on folding filesystems - - -- the digest equality proves the materialized tree re-serialises - -- to its NAR on every platform strategy. - -- Every length word, tag, and padding run must survive splitting - -- across Await boundaries, so the whole materialization runs at - -- several chunk sizes including single-byte feeds. - runTestM "streaming unpack materializes and verifies across chunk sizes" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-stream-unpack" - chunkSizes = [1, 7, 8, 11] :: [Int] - runAt n = do - let dest = tmpDir ("out-" <> show n) - source <- chunkReader (streamChunks n streamTestNar) - result <- Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo streamTestNar) streamTestDigest source - onDisk <- ExecBit.serialiseFromPath (volumeCaseHack tmpSensitivity) dest - pure $ case result of - Left err -> - Just ("chunk size " <> T.pack (show n) <> ": " <> Subst.attemptFailureMessage err) - Right narByteCount - | narByteCount == BS.length streamTestNar - && CHash.hashBytes (NAR.serialise onDisk) == streamTestDigest -> - Nothing - | otherwise -> - Just ("chunk size " <> T.pack (show n) <> ": streamed tree diverges from its NAR") - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - outcomes <- mapM runAt chunkSizes - forceRemoveIfExists tmpDir - pure $ case catMaybes outcomes of - [] -> Pass - (msg : _) -> Fail msg, - -- A truncated stream is a loud parse failure, never a short - -- tree - and it retries: truncation and a torn transfer - -- parse-fail the same way. - runTestM "streaming unpack refuses a truncated stream as transient" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-stream-trunc" - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - source <- chunkReader (streamChunks 7 (BS.take (BS.length streamTestNar - 10) streamTestNar)) - result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") (streamTestNarInfo streamTestNar) streamTestDigest source - forceRemoveIfExists tmpDir - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - Left (Subst.FatalFailure err) -> Fail ("truncation classified fatal: " <> err) - Right _ -> Fail "truncated NAR stream was accepted", - -- A digest mismatch reports before the tree is trusted, and it - -- is fatal: the size matched, so the transfer completed. - runTestM "streaming unpack refuses a digest mismatch as fatal" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-stream-digest" - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - source <- chunkReader (streamChunks 7 streamTestNar) - result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") (streamTestNarInfo streamTestNar) (CHash.hashBytes "not the nar") source - forceRemoveIfExists tmpDir - pure $ case result of - Left (Subst.FatalFailure err) | "hash mismatch" `T.isInfixOf` err -> Pass - Left other -> Fail ("expected fatal hash mismatch, got: " <> Subst.attemptFailureMessage other) - Right _ -> Fail "digest mismatch was accepted", - -- A narinfo lying about NarSize in either direction is refused - -- at NarDone - the grammar completed, so the mismatch is the - -- narinfo misdeclaring, and fatal. - runTestM "streaming unpack refuses an overdeclared NarSize" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-stream-oversize" - lying = (streamTestNarInfo streamTestNar) {NarInfo.niNarSize = toInteger (BS.length streamTestNar) + 1} - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - source <- chunkReader (streamChunks 7 streamTestNar) - result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") lying streamTestDigest source - forceRemoveIfExists tmpDir - pure $ case result of - Left (Subst.FatalFailure err) | "size mismatch" `T.isInfixOf` err -> Pass - Left other -> Fail ("expected fatal size mismatch, got: " <> Subst.attemptFailureMessage other) - Right _ -> Fail "overdeclared NarSize was accepted", - runTestM "streaming unpack refuses an underdeclared NarSize" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-stream-undersize" - lying = (streamTestNarInfo streamTestNar) {NarInfo.niNarSize = toInteger (BS.length streamTestNar) - 1} - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - source <- chunkReader (streamChunks 7 streamTestNar) - result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") lying streamTestDigest source - forceRemoveIfExists tmpDir - pure $ case result of - Left (Subst.FatalFailure err) | "size mismatch" `T.isInfixOf` err -> Pass - Left other -> Fail ("expected fatal size mismatch, got: " <> Subst.attemptFailureMessage other) - Right _ -> Fail "underdeclared NarSize was accepted", - -- cappedBodySource: the streaming mirror of readBodyCapped - - -- a body past the key-trusted declared size aborts mid-stream. - runTestM "cappedBodySource aborts past the cap" $ do - reader <- chunkReader ["abcdef", "ghijkl"] - source <- Subst.cappedBodySource 10 reader - firstChunk <- source - overCap <- try source :: IO (Either SomeException BS.ByteString) - pure $ case (firstChunk, overCap) of - ("abcdef", Left _) -> Pass - other -> Fail ("expected abort past the cap, got: " <> T.pack (show other)), - -- withDecompressedSource: xz chunks decompress under the - -- declared bound; the support decision mirrors decompressorFor. - runTestM "withDecompressedSource xz chunked roundtrip" $ - case B64.decode xzFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 7 compressed) - result <- Subst.withDecompressedSource xzFixtureSize "xz" source $ \pull -> - let go acc = do - chunk <- pull - if BS.null chunk - then pure (Right (BS.concat (reverse acc))) - else go (chunk : acc) - in go [] - pure $ case result of - Right out | out == xzFixturePayload -> Pass - other -> Fail ("xz source roundtrip diverged: " <> T.pack (show (fmap BS.length other))), - runTestM "withDecompressedSource zstd chunked roundtrip" $ do - source <- chunkReader (streamChunks 7 zstdFixtureCompressed) - result <- Subst.withDecompressedSource xzFixtureSize "zstd" source $ \pull -> - let go acc = do - chunk <- pull - if BS.null chunk - then pure (Right (BS.concat (reverse acc))) - else go (chunk : acc) - in go [] - pure $ case result of - Right out | out == xzFixturePayload -> Pass - other -> Fail ("zstd source roundtrip diverged: " <> T.pack (show (fmap BS.length other))), - runTestM "withDecompressedSource xz single-byte chunks" $ - case B64.decode xzFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 1 compressed) - result <- Subst.withDecompressedSource xzFixtureSize "xz" source $ \pull -> - let go acc = do - chunk <- pull - if BS.null chunk - then pure (Right (BS.concat (reverse acc))) - else go (chunk : acc) - in go [] - pure $ case result of - Right out | out == xzFixturePayload -> Pass - other -> Fail ("xz 1-byte roundtrip diverged: " <> T.pack (show (fmap BS.length other))), - -- The LIVE pipeline's defenses, not the strict oracle's: hostile - -- compressed input through withDecompressedSource must land in - -- the Left channel with the right retry class, never escape as - -- an exception. - runTestM "withDecompressedSource xz over-bound is fatal" $ - case B64.decode xzFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 7 compressed) - result <- Subst.withDecompressedSource (xzFixtureSize - 1) "xz" source drainChunkSource - pure $ case result of - Left (Subst.FatalFailure err) | "NarSize" `T.isInfixOf` err -> Pass - other -> Fail ("expected fatal over-bound, got: " <> T.pack (show (void other))), - runTestM "withDecompressedSource xz garbage is transient" $ do - source <- chunkReader ["not an xz stream"] - result <- Subst.withDecompressedSource 64 "xz" source drainChunkSource - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected transient stream error, got: " <> T.pack (show (void other))), - runTestM "withDecompressedSource xz truncated is transient" $ - case B64.decode xzFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 7 (BS.take 40 compressed)) - result <- Subst.withDecompressedSource xzFixtureSize "xz" source drainChunkSource - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected transient truncation, got: " <> T.pack (show (void other))), - -- The failure contract of the post-download pipeline: every - -- failing materialization removes the tree it wrote, and a - -- clean one registers the verified metadata. - runTestM "materialize registers a verified tree" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-materialize-ok" - forceRemoveIfExists tmpStore - createDirectoryIfMissing True tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath sampleHash "stream" - destPath = storePathToFilePath (StoreDir tmpStore) sp - source <- chunkReader (streamChunks 7 streamTestNar) - result <- Subst.materializeNarFromSource store sp (streamTestNarInfo streamTestNar) streamTestDigest [] Nothing source - survived <- doesDirectoryExist destPath - closeStore store - forceRemoveIfExists tmpStore - pure $ case result of - Left err -> Fail ("materialize failed: " <> Subst.attemptFailureMessage err) - Right reg - | not survived -> Fail "verified tree missing after materialize" - | prNarSize reg /= BS.length streamTestNar -> Fail "registration NarSize diverges" - | prNarHash reg /= CHash.formatNixHash streamTestDigest -> Fail "registration NarHash diverges" - | otherwise -> Pass, - runTestM "materialize removes the tree on a digest mismatch" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-materialize-digest" - forceRemoveIfExists tmpStore - createDirectoryIfMissing True tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath sampleHash "stream" - destPath = storePathToFilePath (StoreDir tmpStore) sp - source <- chunkReader (streamChunks 7 streamTestNar) - result <- Subst.materializeNarFromSource store sp (streamTestNarInfo streamTestNar) (CHash.hashBytes "not the nar") [] Nothing source - survived <- doesDirectoryExist destPath - closeStore store - forceRemoveIfExists tmpStore - pure $ case result of - Right _ -> Fail "digest mismatch was accepted" - Left (Subst.TransientFailure err) -> Fail ("mismatch classified transient: " <> err) - Left (Subst.FatalFailure err) - | not ("hash mismatch" `T.isInfixOf` err) -> Fail ("unexpected failure: " <> err) - | survived -> Fail "tree survived a digest mismatch" - | otherwise -> Pass, - runTestM "materialize removes the tree on a truncated stream" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-materialize-trunc" - forceRemoveIfExists tmpStore - createDirectoryIfMissing True tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath sampleHash "stream" - destPath = storePathToFilePath (StoreDir tmpStore) sp - source <- chunkReader (streamChunks 7 (BS.take (BS.length streamTestNar - 10) streamTestNar)) - result <- Subst.materializeNarFromSource store sp (streamTestNarInfo streamTestNar) streamTestDigest [] Nothing source - survived <- doesDirectoryExist destPath - closeStore store - forceRemoveIfExists tmpStore - pure $ case result of - Right _ -> Fail "truncated stream was accepted" - Left (Subst.FatalFailure err) -> Fail ("truncation classified fatal: " <> err) - Left (Subst.TransientFailure _) - | survived -> Fail "tree survived a truncated stream" - | otherwise -> Pass, - -- The download cap derives from the SIGNED NarSize; the unsigned - -- FileSize may only lower it, never raise it. - runTest "downloadCapFor lets FileSize lower but never raise the cap" $ - let base = streamTestNarInfo streamTestNar - narSize = NarInfo.niNarSize base - ceilingCap = Subst.compressedBodyCeiling narSize - absent = Subst.downloadCapFor base {NarInfo.niFileSize = Nothing} - lowered = Subst.downloadCapFor base {NarInfo.niFileSize = Just 100} - inflated = Subst.downloadCapFor base {NarInfo.niFileSize = Just (ceilingCap * 1000)} - in case (absent, lowered, inflated) of - (Right capAbsent, Right capLowered, Right capInflated) - | toInteger capAbsent == ceilingCap - && capLowered == 100 - && toInteger capInflated == ceilingCap -> - Pass - other -> Fail ("unexpected caps: " <> T.pack (show other)), - runTest "compressedBodyCeiling floors small and scales large" $ - let smallCeiling = Subst.compressedBodyCeiling 10 - largeSize = 64 * 1024 * 1024 - largeCeiling = Subst.compressedBodyCeiling largeSize - in if smallCeiling == 10 + 64 * 1024 && largeCeiling == largeSize + largeSize `div` 64 - then Pass - else Fail ("unexpected ceilings: " <> T.pack (show (smallCeiling, largeCeiling))), - -- The zstd mirror of the xz hostile trio: over-bound output is - -- deterministic, while a corrupt frame and a frame cut off - -- mid-way both retry - the codec judges end of input by - -- libzstd's own frame-boundary signal, so truncation refuses - -- here instead of yielding a short output. - runTestM "withDecompressedSource zstd over-bound is fatal" $ do - source <- chunkReader (streamChunks 7 zstdFixtureCompressed) - result <- Subst.withDecompressedSource (xzFixtureSize - 1) "zstd" source drainChunkSource - pure $ case result of - Left (Subst.FatalFailure err) | "NarSize" `T.isInfixOf` err -> Pass - other -> Fail ("expected fatal over-bound, got: " <> T.pack (show (void other))), - runTestM "withDecompressedSource zstd garbage is transient" $ do - source <- chunkReader ["not a zstd frame"] - result <- Subst.withDecompressedSource 64 "zstd" source drainChunkSource - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected transient stream error, got: " <> T.pack (show (void other))), - runTestM "withDecompressedSource zstd truncated is transient" $ do - source <- chunkReader (streamChunks 7 (BS.take (BS.length zstdFixtureCompressed - 8) zstdFixtureCompressed)) - result <- Subst.withDecompressedSource xzFixtureSize "zstd" source drainChunkSource - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected transient truncation, got: " <> T.pack (show (void other))), - -- The codec refuses a truncated frame, and the whole pipeline - -- must carry that refusal into the Left channel as retryable - -- rather than let a short NAR reach the store. - runTestM "zstd truncated body fails the pipeline as transient" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-zstd-trunc" - compressedNar = CZstd.compress CZstd.defaultCompressionLevel streamTestNar - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - source <- chunkReader (streamChunks 7 (BS.take (BS.length compressedNar - 8) compressedNar)) - result <- - Subst.withDecompressedSource (toInteger (BS.length streamTestNar)) "zstd" source $ - Subst.consumeNarStream tmpSensitivity (tmpDir "out") ((streamTestNarInfo streamTestNar) {NarInfo.niCompression = "zstd"}) streamTestDigest - forceRemoveIfExists tmpDir - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - Left (Subst.FatalFailure err) -> Fail ("zstd truncation classified fatal: " <> err) - Right _ -> Fail "truncated zstd body was accepted", - -- The bzip2 mirror of the xz hostile trio, over a fixture the - -- bzip2 CLI produced: over-bound output is deterministic, while - -- garbage and a truncated stream retry. - runTestM "withDecompressedSource bzip2 chunked roundtrip" $ - case B64.decode bzip2FixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 7 compressed) - result <- Subst.withDecompressedSource xzFixtureSize "bzip2" source $ \pull -> - let go acc = do - chunk <- pull - if BS.null chunk - then pure (Right (BS.concat (reverse acc))) - else go (chunk : acc) - in go [] - pure $ case result of - Right out | out == xzFixturePayload -> Pass - other -> Fail ("bzip2 source roundtrip diverged: " <> T.pack (show (fmap BS.length other))), - runTestM "withDecompressedSource bzip2 over-bound is fatal" $ - case B64.decode bzip2FixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 7 compressed) - result <- Subst.withDecompressedSource (xzFixtureSize - 1) "bzip2" source drainChunkSource - pure $ case result of - Left (Subst.FatalFailure err) | "NarSize" `T.isInfixOf` err -> Pass - other -> Fail ("expected fatal over-bound, got: " <> T.pack (show (void other))), - runTestM "withDecompressedSource bzip2 garbage is transient" $ do - source <- chunkReader ["not a bzip2 stream"] - result <- Subst.withDecompressedSource 64 "bzip2" source drainChunkSource - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected transient stream error, got: " <> T.pack (show (void other))), - runTestM "withDecompressedSource bzip2 truncated is transient" $ - case B64.decode bzip2FixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - source <- chunkReader (streamChunks 7 (BS.take (BS.length compressed - 8) compressed)) - result <- Subst.withDecompressedSource xzFixtureSize "bzip2" source drainChunkSource - pure $ case result of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected transient truncation, got: " <> T.pack (show (void other))), - -- A bzip2-compressed NAR through the whole post-download - -- pipeline: the format the historical caches serve decompresses, - -- hashes, parses, and materializes in one bounded pass. - runTestM "bzip2 NAR streams through the pipeline" $ - case B64.decode bzip2NarFixtureB64 of - Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) - Right compressed -> do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-bzip2-pipeline" - destPath = tmpDir "out" - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - source <- chunkReader (streamChunks 7 compressed) - result <- - Subst.withDecompressedSource (toInteger (BS.length bzip2NarFixture)) "bzip2" source $ - Subst.consumeNarStream - tmpSensitivity - destPath - ((streamTestNarInfo bzip2NarFixture) {NarInfo.niCompression = "bzip2"}) - (CHash.hashBytes bzip2NarFixture) - materialized <- Dir.doesFileExist (destPath "greeting") - forceRemoveIfExists tmpDir - pure $ case result of - Left err -> Fail ("bzip2 pipeline failed: " <> Subst.attemptFailureMessage err) - Right narBytes - | narBytes /= BS.length bzip2NarFixture -> Fail "bzip2 pipeline counted the wrong NAR size" - | not materialized -> Fail "bzip2 pipeline left no tree at the destination" - | otherwise -> Pass, - runTest "streaming compression support matches the strict set" $ - case (Subst.streamingDecompressionSupported "xz", Subst.streamingDecompressionSupported "zstd", Subst.streamingDecompressionSupported "bzip2", Subst.streamingDecompressionSupported "brotli") of - (Right (), Right (), Right (), Left _) -> Pass - other -> Fail ("unexpected support set: " <> T.pack (show other)), - -- The support set is encoded twice - the strict decompressor and - -- the streaming decision - so their agreement is pinned across - -- the codecs either could plausibly grow, not left to comments. - runTest "strict and streaming support sets agree" $ - let agrees compression = - case (Subst.decompressorFor 1 compression, Subst.streamingDecompressionSupported compression) of - (Right _, Right ()) -> True - (Left _, Left _) -> True - _ -> False - in if all agrees ["none", "", "xz", "zstd", "bzip2", "brotli"] - then Pass - else Fail "strict and streaming compression support drifted", - -- The strict path is the streaming path's differential oracle: - -- the same NAR materialized by both must produce the same tree. - runTestM "strict and streaming unpack agree" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-stream-oracle" - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - strictOutcome <- case NAR.deserialise streamTestNar of - Left err -> pure (Left (T.pack err)) - Right entry -> unpackNarEntry tmpSensitivity (tmpDir "strict") entry - source <- chunkReader (streamChunks 11 streamTestNar) - streamOutcome <- Subst.consumeNarStream tmpSensitivity (tmpDir "streamed") (streamTestNarInfo streamTestNar) streamTestDigest source - strictTree <- NAR.serialiseFromPath (tmpDir "strict") - streamedTree <- NAR.serialiseFromPath (tmpDir "streamed") - forceRemoveIfExists tmpDir - pure $ case (strictOutcome, streamOutcome) of - (Right (), Right _) - | NAR.serialise strictTree == NAR.serialise streamedTree -> Pass - | otherwise -> Fail "strict and streaming trees diverge" - other -> Fail ("oracle setup failed: " <> T.pack (show other)), - -- trySubstitute: empty caches returns SubstNotFound - runTestM "trySubstitute no caches" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-subst" - createDirectoryIfMissing True tmpStore - store <- openStore (StoreDir tmpStore) - result <- Subst.trySubstitute store [] (StorePath "test" "hello") - closeStore store - removeDirectoryRecursive tmpStore - pure (assertEqual "no-caches" Subst.SubstNotFound result), - -- defaultCacheConfig has correct URL - runTest "defaultCacheConfig url" $ - assertEqual "default-url" "https://cache.nixos.org" (Subst.ccUrl Subst.defaultCacheConfig), - -- defaultCacheConfig has priority 40 - runTest "defaultCacheConfig priority" $ - assertEqual "default-prio" 40 (Subst.ccPriority Subst.defaultCacheConfig), - -- verifyNarHash: matching NAR hash accepted (HIGH#2 integrity gate); - -- the returned digest is the declared hash, decoded. - runTest "verifyNarHash accepts matching hash" $ - case Subst.verifyNarHash (sampleNarInfo sampleNarHash) sampleNarBytes of - Right declared - | CHash.formatNixHash declared == sampleNarHash -> Pass - | otherwise -> Fail "returned digest does not match the declared hash" - Left err -> Fail ("expected acceptance, got: " <> err), - -- verifyNarHash: mismatched NAR hash rejected - runTest "verifyNarHash rejects mismatched hash" $ - case Subst.verifyNarHash (sampleNarInfo wrongNarHash) sampleNarBytes of - Left _ -> Pass - Right _ -> Fail "expected mismatch rejection", - -- verifyNarHash: malformed NAR hash rejected - runTest "verifyNarHash rejects malformed hash" $ - case Subst.verifyNarHash (sampleNarInfo "not-a-hash") sampleNarBytes of - Left _ -> Pass - Right _ -> Fail "expected malformed-hash rejection", - -- verifyNar: the only constructor of VerifiedNar carries the bytes - -- unchanged and the declared digest decoded, so the unpack sink - -- and the registration read both from the witness. - runTest "verifyNar carries the bytes and the declared digest" $ - case Subst.verifyNar (sampleNarInfo sampleNarHash) sampleNarBytes of - Right verified - | Subst.verifiedNarBytes verified /= sampleNarBytes -> Fail "verified bytes differ from the input" - | CHash.formatNixHash (Subst.verifiedNarDigest verified) /= sampleNarHash -> Fail "carried digest is not the declared hash" - | otherwise -> Pass - Left err -> Fail ("expected acceptance, got: " <> err), - -- verifyNar: either signed claim failing yields no witness at all. - runTest "verifyNar rejects a hash or size mismatch" $ - let wrongHash = Subst.verifyNar (sampleNarInfo wrongNarHash) sampleNarBytes - wrongSize = Subst.verifyNar ((sampleNarInfo sampleNarHash) {NarInfo.niNarSize = toInteger (BS.length sampleNarBytes) + 1}) sampleNarBytes - in case (wrongHash, wrongSize) of - (Left _, Left _) -> Pass - other -> Fail ("expected both rejections, got: " <> T.pack (show other)), - -- narInfoMatchesPath: identity match accepted - runTest "narInfoMatchesPath accepts matching identity" $ - if Subst.narInfoMatchesPath (StorePath sampleHash "hello") (sampleNarInfo sampleNarHash) - then Pass - else Fail "expected identity match", - -- narInfoMatchesPath: identity mismatch rejected - runTest "narInfoMatchesPath rejects mismatched identity" $ - if Subst.narInfoMatchesPath (StorePath (T.replicate 32 "b") "hello") (sampleNarInfo sampleNarHash) - then Fail "expected identity mismatch" - else Pass, - -- tryCachesWith: the first success stops the scan (later caches - -- are never contacted) - runTestM "tryCachesWith success stops scan" $ do - calls <- newIORef (0 :: Int) - withChainLock "nova-nix-test-chain-stop" $ \lock -> do - let hit = PathRegistration (StorePath (T.replicate 32 "d") "hit") "sha256:d" 1 Nothing [] - attempt cache = do - atomicModifyIORef' calls (\n -> (n + 1, ())) - pure $ - if Subst.ccUrl cache == "https://b" - then Subst.SubstSuccess hit lock - else Subst.SubstNotFound - result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b", chainCache "https://c"] - made <- readIORef calls - pure $ - if result == Subst.SubstSuccess hit lock && made == 2 - then Pass - else Fail ("got " <> T.pack (show result) <> " after " <> T.pack (show made) <> " attempts"), - -- tryCachesWith: an already-valid path found mid-scan is terminal - -- like a success - later caches are never contacted - runTestM "tryCachesWith already-valid stops scan" $ do - calls <- newIORef (0 :: Int) - let attempt _ = do - atomicModifyIORef' calls (\n -> (n + 1, ())) - pure Subst.SubstAlreadyValid - result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"] - made <- readIORef calls - pure $ - if result == Subst.SubstAlreadyValid && made == 1 - then Pass - else Fail ("got " <> T.pack (show result) <> " after " <> T.pack (show made) <> " attempts"), - -- tryCachesWith: an erroring cache falls through to a later hit - -- instead of aborting the chain - runTestM "tryCachesWith error falls through to next cache" $ - withChainLock "nova-nix-test-chain-fallthrough" $ \lock -> do - let hit = PathRegistration (StorePath (T.replicate 32 "f") "hit") "sha256:f" 1 Nothing [] - attempt cache - | Subst.ccUrl cache == "https://a" = pure (Subst.SubstError "transient 500") - | otherwise = pure (Subst.SubstSuccess hit lock) - result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"] - pure (assertEqual "fallthrough" (Subst.SubstSuccess hit lock) result), - -- tryCachesWith: all misses stay SubstNotFound - runTestM "tryCachesWith all misses" $ do - result <- Subst.tryCachesWith (\_ -> pure Subst.SubstNotFound) [chainCache "https://a", chainCache "https://b"] - pure (assertEqual "misses" Subst.SubstNotFound result), - -- tryCachesWith: with no hit anywhere, the FIRST error is reported, - -- tagged with the URL of the cache that produced it - runTestM "tryCachesWith reports first error tagged with cache" $ do - let attempt cache - | Subst.ccUrl cache == "https://a" = pure Subst.SubstNotFound - | Subst.ccUrl cache == "https://b" = pure (Subst.SubstError "first") - | otherwise = pure (Subst.SubstError "second") - result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b", chainCache "https://c"] - pure $ case result of - Subst.SubstError err - | "https://b" `T.isPrefixOf` err && "first" `T.isSuffixOf` err -> Pass - other -> Fail ("expected tagged first error, got " <> T.pack (show other)), - -- catchSync (the split every attempt wraps itself in): a - -- synchronous exception folds into SubstError and the scan falls - -- through to the next cache - runTestM "catchSync folds sync exception into SubstError" $ do - let attempt cache = - Subst.catchSync - ( if Subst.ccUrl cache == "https://a" - then throwIO (ErrorCall "disk full") - else pure Subst.SubstNotFound - ) - (pure . Subst.SubstError . T.pack . show) - result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"] - pure $ case result of - Subst.SubstError err - | "disk full" `T.isInfixOf` err -> Pass - other -> Fail ("expected SubstError from sync exception, got " <> T.pack (show other)), - -- catchSync: an asynchronous exception thrown mid-attempt - -- propagates out of the cache scan instead of folding into - -- SubstError - cancellation must abort substitution, never be - -- spent as fallthrough to the next cache or to a local build - runTestM "catchSync propagates async exception out of the scan" $ do - scanned <- newIORef (0 :: Int) - let attempt _ = - Subst.catchSync - ( do - atomicModifyIORef' scanned (\n -> (n + 1, ())) - throwIO (asyncExceptionToException (ErrorCall "cancelled")) - ) - (pure . Subst.SubstError . T.pack . show) - outcome <- try (Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"]) - made <- readIORef scanned - pure $ case (outcome :: Either SomeException Subst.SubstResult) of - Left escaped -> case fromException escaped of - Just (SomeAsyncException _) - | made == 1 -> Pass - | otherwise -> Fail ("scan continued past the interrupt: " <> T.pack (show made) <> " attempts") - Nothing -> Fail ("wrong exception escaped: " <> T.pack (show escaped)) - Right result -> Fail ("async exception folded into " <> T.pack (show result)), - -- clearStaleDestination: removes a read-only leftover tree (the - -- crash-between-unpack-and-register wedge) - runTestM "clearStaleDestination removes read-only leftovers" $ do - tmpBase <- getTemporaryDirectory - let staleRoot = tmpBase "nova-nix-test-stale-dest" - staleFile = staleRoot "bin" "tool" - createDirectoryIfMissing True (staleRoot "bin") - writeFile staleFile "leftover" - perms <- getPermissions staleFile - Dir.setPermissions staleFile (Dir.setOwnerWritable False perms) - Subst.clearStaleDestination staleRoot - gone <- Dir.doesPathExist staleRoot - pure (if gone then Fail "stale tree survived" else Pass), - -- clearStaleDestination: a missing destination is a no-op - runTestM "clearStaleDestination missing path no-op" $ do - tmpBase <- getTemporaryDirectory - outcome <- try (Subst.clearStaleDestination (tmpBase "nova-nix-test-no-such-dir")) - pure $ case (outcome :: Either SomeException ()) of - Right () -> Pass - Left e -> Fail ("threw: " <> T.pack (show e)), - -- unpackNarEntry: what the archive grammar refuses (traversal - -- shapes, a NUL) is refused on every host before anything is - -- written - runTestM "unpackNarEntry rejects unsafe entry names" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-unsafe" - evil name = NAR.NarDirectory [(name, NAR.NarRegular False "x")] - -- Cleared before each: the root is created exclusively, so - -- a leftover from the previous name would refuse for a - -- different reason than the one under test. - unpackFresh name = do - Subst.clearStaleDestination dest - unpackNarEntry tmpSensitivity dest (evil name) - results <- mapM unpackFresh ["..", ".", "", "a/b", "a\NULb"] - Subst.clearStaleDestination dest - pure $ - if all (\case Left err -> "NAR directory entry name" `T.isInfixOf` err; Right () -> False) results - then Pass - else Fail ("accepted an unsafe name: " <> T.pack (show results)), - -- Names upstream's restore writes on POSIX as it finds them - -- (posixOnlyTree, compared against nix-store --restore 2.33.2) - -- materialize byte for byte through both unpack paths there, and - -- the tree re-serialises to the NAR it came from. Windows refuses - -- the first such name before writing any entry. - runTestM "names upstream restores on POSIX materialize as their bytes" $ do - tmpBase <- getTemporaryDirectory - let refusal = "NAR directory entry name 'COM1' is a Windows device name" - outcomes <- unpackedBothWays tmpSensitivity (tmpBase "nova-nix-test-unpack-posix-names") posixOnlyTree - pure $ - if SI.os == "mingw32" - then assertEqual "Windows refusals (strict, streamed)" (Left refusal, Left refusal) outcomes - else assertEqual "trees read back (strict, streamed)" (Right posixOnlyTree, Right posixOnlyTree) outcomes, - -- The same tree substituted into a temp store: the strict pipeline - -- unpacks and seals it, then re-serialises the store path from disk - -- against the narinfo's hash before it registers anything, so a - -- success means the path's bytes reproduce the NAR. Windows - -- refuses it before writing. - runTestM "a store path holding names upstream restores on POSIX substitutes" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-unpack-posix-store" - sp = StorePath (T.replicate 32 "c") "posix-names" - rawNar = NAR.serialise posixOnlyTree - info = (streamTestNarInfo rawNar) {NarInfo.niStorePath = storePathToText defaultStoreDir sp} - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - result <- Subst.unpackAndVerify store sp info rawNar - onDisk <- case result of - Subst.SubstSuccess _ lock -> do - releasePathLock lock - Right <$> NAR.serialiseFromPath (storePathToFilePath (stDir store) sp) - other -> pure (Left (T.pack (show other))) - closeStore store - forceRemoveIfExists tmpStore - pure $ case onDisk of - Left shown - | SI.os == "mingw32" && "is a Windows device name" `T.isInfixOf` shown -> Pass - _ -> assertEqual "store path read back" (Right posixOnlyTree) onDisk, - -- A name and a link target with no UTF-8 reading. Linux holds - -- both as bytes, as upstream restores them; a macOS volume cannot - -- hold the name (APFS refuses it, HFS+ rewrites it) but keeps the - -- target's bytes; Windows holds neither. - runTestM "bytes with no UTF-8 reading materialize where the host holds them" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-raw-bytes" - nameTree = NAR.NarDirectory [("caf\xE9", NAR.NarDirectory [("\xFF", NAR.NarRegular True "x")])] - targetTree = NAR.NarDirectory [("link", NAR.NarSymlink "caf\xE9")] - nameRefusal reason = "NAR directory entry name \"caf\\233\" is not valid UTF-8, " <> reason - targetRefusal = "NAR symlink target \"caf\\233\" is not valid UTF-8, so it has no UTF-16 form for Windows" - both outcome = (outcome, outcome) - named <- unpackedBothWays tmpSensitivity dest nameTree - targeted <- unpackedBothWays tmpSensitivity dest targetTree - pure $ case SI.os of - "mingw32" -> - assertEqual - "Windows refusals" - (both (Left (nameRefusal "so it has no UTF-16 form for Windows")), both (Left targetRefusal)) - (named, targeted) - "darwin" -> - assertEqual - "macOS refuses the name and keeps the target" - (both (Left (nameRefusal "which a macOS filesystem cannot hold")), both (Right targetTree)) - (named, targeted) - _ -> - assertEqual - "Linux keeps both" - (both (Right nameTree), both (Right targetTree)) - (named, targeted), - -- The bytes reach the filesystem without passing through the - -- locale's codec: under an ASCII file-system encoding (a C locale) - -- or a Latin-1 one a UTF-8 name still lands as its UTF-8 bytes. - -- Spelled through 'FilePath', the first cannot encode the name and - -- the second writes other bytes. - runTestM "names land as their bytes whatever the file-system encoding" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-codec" - tree = - NAR.NarDirectory - [ ("caf\xC3\xA9", NAR.NarRegular False "e"), - ("link", NAR.NarSymlink "\xE2\x9C\x93"), - ("\xE2\x9C\x93", NAR.NarRegular False "check") - ] - under encodingName = do - encoding <- mkTextEncoding encodingName - bracket getFileSystemEncoding setFileSystemEncoding $ \_ -> do - setFileSystemEncoding encoding - unpackedBothWays tmpSensitivity dest tree - if SI.os == "mingw32" - then Pass <$ putStrLn " SKIP a Windows path is UTF-16 and no locale codec spells it" - else do - outcomes <- mapM under ["ASCII//ROUNDTRIP", "ISO-8859-1//ROUNDTRIP"] - pure (assertEqual "trees read back under ASCII and Latin-1 (strict, streamed)" (replicate 2 (Right tree, Right tree)) outcomes), - -- unpackNarEntry: a NAR symlink materializes as a REAL link or fails - -- loudly - never as a regular file holding the target text, which - -- would silently diverge from the signed NAR hash - runTestM "unpackNarEntry symlink is real or loud" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-symlink" - tree = - NAR.NarDirectory - [ ("real", NAR.NarRegular False "contents"), - ("link", NAR.NarSymlink "real") - ] - Subst.clearStaleDestination dest - result <- unpackNarEntry tmpSensitivity dest tree - outcome <- case result of - Right () -> do - isLink <- Dir.pathIsSymbolicLink (dest "link") - pure (if isLink then Pass else Fail "symlink materialized as a non-link") - Left _ -> do - leftBehind <- Dir.doesFileExist (dest "link") - pure (if leftBehind then Fail "failed loudly but left a regular file behind" else Pass) - Subst.clearStaleDestination dest - pure outcome, - -- unpackNarEntry: a directory-target symlink that sorts BEFORE its - -- target still gets the directory link flavor (second-pass typing) - runTestM "unpackNarEntry types forward dir symlink" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-dirlink" - tree = - NAR.NarDirectory - [ ("alink", NAR.NarSymlink "zdir"), - ("zdir", NAR.NarDirectory [("f", NAR.NarRegular False "x")]) - ] - Subst.clearStaleDestination dest - result <- unpackNarEntry tmpSensitivity dest tree - outcome <- case result of - Left _ -> pure Pass -- symlinks unavailable here; the loud failure is the contract - Right () -> do - throughLink <- doesDirectoryExist (dest "alink") - pure (if throughLink then Pass else Fail "dir symlink not traversable (wrong flavor)") - Subst.clearStaleDestination dest - pure outcome, - -- Folding sibling names MATERIALIZE on every platform: true names - -- via the NTFS per-directory flag on Windows and on any volume the - -- probe reports sensitive (Linux, case-sensitive APFS), upstream's - -- case-hack renaming on a folding volume. The platform serialiser - -- reverses whichever branch ran, so the tree re-serialises to its - -- original NAR either way. - runTestM "folding sibling names materialize and round-trip" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-fold" - tree = - NAR.NarDirectory - [ ("Foo", NAR.NarRegular False "upper"), - ("foo", NAR.NarRegular False "lower") - ] - Subst.clearStaleDestination dest - result <- unpackNarEntry tmpSensitivity dest tree - outcome <- case result of - Left err -> pure (Fail ("unpack failed: " <> err)) - Right () -> do - onDisk <- NAR.serialiseFromPath dest - if onDisk /= tree - then pure (Fail "materialized tree does not re-serialise to its NAR") - else - if SI.os == "mingw32" || tmpSensitivity == CaseSensitive - then do - -- True names, not the hack: both spellings hold - -- distinct contents. - upper <- BS.readFile (dest "Foo") - lower <- BS.readFile (dest "foo") - pure (assertEqual "true names" ("upper", "lower") (upper, lower)) - else do - -- The hack: the later variant carries the suffix. - lower <- BS.readFile (dest "foo~nix~case~hack~1") - pure (assertEqual "case-hacked name" "lower" lower) - Subst.clearStaleDestination dest - pure outcome, - -- Every unpack creates exclusively, its root included, as - -- upstream's restore does: a destination that already holds an - -- entry is refused with upstream's wording and left as it was, - -- not truncated or written into. Callers clear a stale - -- destination first. Any volume answers this, so it is the - -- exclusive create's check on every platform, Windows' CREATE_NEW - -- included. - runTestM "unpack refuses a destination that already exists" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-taken" - fileTree = NAR.NarRegular False "new" - dirTree = NAR.NarDirectory [("f", NAR.NarRegular False "new")] - fileRefusal = "creating file '" <> quotedAsCxx dest <> "': File exists" - dirOverFile = "creating directory '" <> T.pack dest <> "': File exists" - dirOverDir = "path '" <> T.pack dest <> "' already exists" - streamInto tree = do - let raw = NAR.serialise tree - source <- chunkReader [raw] - outcome <- Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source - pure (either (Left . Subst.attemptFailureMessage) (const (Right ())) outcome) - strictAndStreamed tree = (,) <$> unpackNarEntry tmpSensitivity dest tree <*> streamInto tree - Subst.clearStaleDestination dest - BS.writeFile dest "old" - fileOnFile <- strictAndStreamed fileTree - dirOnFile <- strictAndStreamed dirTree - keptFile <- BS.readFile dest - Subst.clearStaleDestination dest - createDirectoryIfMissing True dest - dirOnDir <- strictAndStreamed dirTree - wroteInto <- Dir.doesPathExist (dest "f") - Subst.clearStaleDestination dest - let verdict - | keptFile /= "old" = Fail "the existing file was written over" - | wroteInto = Fail "the existing directory was written into" - | otherwise = - assertEqual - "refusals, strict and streamed (a file over a file, a directory over a file, a directory over a directory)" - ((Left fileRefusal, Left fileRefusal), (Left dirOverFile, Left dirOverFile), (Left dirOverDir, Left dirOverDir)) - (fileOnFile, dirOnFile, dirOnDir) - pure verdict, - -- std::quoted escapes a double quote and a backslash inside the - -- path, so a name holding both pins upstream's exact text. A - -- Windows name can hold neither. - runTestM "the file refusal quotes its path as std::quoted does" $ do - tmpBase <- getTemporaryDirectory - let plain = tmpBase "nova-nix-test-unpack-q" - dest = plain <> "\"b\\s" - expected = "creating file '\"" <> T.pack plain <> "\\\"b\\\\s\"': File exists" - tree = NAR.NarRegular False "new" - raw = NAR.serialise tree - if SI.os == "mingw32" - then Pass <$ putStrLn " SKIP a Windows name cannot hold a double quote" - else do - Subst.clearStaleDestination dest - BS.writeFile dest "old" - strict <- unpackNarEntry tmpSensitivity dest tree - source <- chunkReader [raw] - streamed <- Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source - Subst.clearStaleDestination dest - pure (assertEqual "refusals (strict, streamed)" (Left expected, Left expected) (strict, either (Left . Subst.attemptFailureMessage) (const (Right ())) streamed)), - -- The exclusive create reaches as far as base's own open on - -- Windows, where a raw CreateFileW stops at MAX_PATH (260 - -- characters) unless the path is spelled in the file namespace. - -- Every component here is short; only the whole path is long. - runTestM "unpack writes a file whose path is past MAX_PATH" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-long" - component = replicate 60 'd' - depth = 5 :: Int - nest inner = NAR.NarDirectory [(TE.encodeUtf8 (T.pack component), inner)] - tree = foldr (const nest) (NAR.NarDirectory [("leaf", NAR.NarRegular False "deep")]) [1 .. depth] - leafPath = foldl' () dest (replicate depth component) "leaf" - raw = NAR.serialise tree - readLeaf = either (pure . Left) (const (Right <$> BS.readFile leafPath)) - Subst.clearStaleDestination dest - strict <- unpackNarEntry tmpSensitivity dest tree >>= readLeaf - Subst.clearStaleDestination dest - source <- chunkReader [raw] - streamed <- - Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source - >>= readLeaf . either (Left . Subst.attemptFailureMessage) (const (Right ())) - Subst.clearStaleDestination dest - pure $ - if length leafPath <= 260 - then Fail "the fixture path is not past MAX_PATH" - else assertEqual "leaf contents (strict, streamed)" (Right "deep", Right "deep") (strict, streamed), - -- The pure case-hack naming is a function of the probed - -- sensitivity, not of the platform: on a folding volume later - -- case variants gain the reversible suffix with a per-name - -- counter, on a sensitive one every name keeps its spelling. - runTest "caseHackDiskNames renames later case variants on a folding volume" $ - assertEqual - "hack naming" - [("Foo", "Foo"), ("foo", "foo~nix~case~hack~1"), ("fOO", "fOO~nix~case~hack~2"), ("bar", "bar")] - (caseHackDiskNames CaseInsensitive ["Foo", "foo", "fOO", "bar"]), - runTest "caseHackDiskNames keeps every name on a sensitive volume" $ - assertEqual - "identity naming" - [("Foo", "Foo"), ("foo", "foo"), ("fOO", "fOO"), ("bar", "bar")] - (caseHackDiskNames CaseSensitive ["Foo", "foo", "fOO", "bar"]), - -- The key behind both: case variants share it exactly on a - -- folding volume. - runTest "onDiskNameKey folds case only on a folding volume" $ - if onDiskNameKey CaseSensitive "Makefile" /= onDiskNameKey CaseSensitive "makefile" - && onDiskNameKey CaseInsensitive "Makefile" == onDiskNameKey CaseInsensitive "makefile" - then Pass - else Fail "the key does not follow the probed sensitivity", - -- A name with no UTF-8 reading has no characters to fold, so it - -- keys as its bytes even on a folding volume. - runTest "onDiskNameKey keys a name with no UTF-8 reading as its bytes" $ - assertEqual - "keys of a Latin-1 and a UTF-8 spelling" - ("caf\xE9", "CAF\xC3\x89") - (onDiskNameKey CaseInsensitive "caf\xE9", onDiskNameKey CaseInsensitive "caf\xC3\xA9"), - -- The probe against the filesystem's own answer: two sibling - -- names differing only by case are two entries on a sensitive - -- volume and one on a folding one. - runTestM "probeCaseSensitivity agrees with the filesystem" $ do - tmpBase <- getTemporaryDirectory - let dir = tmpBase "nova-nix-test-case-probe" - Subst.clearStaleDestination dir - createDirectoryIfMissing True dir - BS.writeFile (dir "Probe") "upper" - BS.writeFile (dir "probe") "lower" - entries <- Dir.listDirectory dir - probed <- probeCaseSensitivity dir - Subst.clearStaleDestination dir - let observed = if length entries == 2 then CaseSensitive else CaseInsensitive - pure (assertEqual "probe against the filesystem" observed probed), - -- Where the volume's serialiser strips the suffix (a folding - -- volume), an incoming name carrying it must reject (it could - -- not round-trip); on a volume that keeps names apart such a - -- name is legitimate and materializes verbatim. - runTestM "incoming case-hack suffix names reject where the serialiser strips" $ do - tmpBase <- getTemporaryDirectory - let dest = tmpBase "nova-nix-test-unpack-suffix" - tree = NAR.NarDirectory [("x~nix~case~hack~1", NAR.NarRegular False "v")] - Subst.clearStaleDestination dest - result <- unpackNarEntry tmpSensitivity dest tree - outcome <- case (tmpSensitivity, result) of - (CaseInsensitive, Left _) -> pure Pass - (CaseInsensitive, Right ()) -> pure (Fail "suffix-bearing name accepted where the serialiser strips") - (CaseSensitive, Right ()) -> do - kept <- BS.readFile (dest "x~nix~case~hack~1") - pure (assertEqual "verbatim where names stay apart" "v" kept) - (CaseSensitive, Left err) -> pure (Fail ("a volume keeping names apart rejected a legitimate name: " <> err)) - Subst.clearStaleDestination dest - pure outcome, - -- The capability probe itself: NTFS grants the per-directory flag - -- (CI runners and the dev box run NTFS temp dirs); other - -- platforms report unsupported. - runTestM "trySetCaseSensitiveDir reflects platform support" $ do - tmpBase <- getTemporaryDirectory - let dir = tmpBase "nova-nix-test-csdir" - Subst.clearStaleDestination dir - createDirectoryIfMissing True dir - flagged <- trySetCaseSensitiveDir dir - Subst.clearStaleDestination dir - pure (assertEqual "flag support" (SI.os == "mingw32") flagged), - -- unpackAndVerify re-serialises the materialized tree and checks it - -- against the declared hash before returning a registration: a - -- faithful round-trip passes, and the registration carries the - -- declared hash. - runTestM "unpackAndVerify accepts a tree that reproduces its hash" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-unpack-verify" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath (T.replicate 32 "b") "roundtrip" - tree = - NAR.NarDirectory - [ ("data.txt", NAR.NarRegular False "verified bytes"), - ("sub", NAR.NarDirectory [("inner", NAR.NarRegular False "nested")]) - ] - rawNar = NAR.serialise tree - narHash = CHash.formatNixHash (CHash.hashBytes rawNar) - info = - NarInfo.NarInfo - { NarInfo.niStorePath = storePathToText defaultStoreDir sp, - NarInfo.niUrl = "nar/roundtrip.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = narHash, - NarInfo.niNarSize = fromIntegral (BS.length rawNar), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - result <- Subst.unpackAndVerify store sp info rawNar - onDisk <- BS.readFile (storePathToFilePath (stDir store) sp "data.txt") - -- A success carries the path lock still held; release it before - -- the store teardown (Windows cannot delete a file a handle - -- holds open). - case result of - Subst.SubstSuccess _ lock -> releasePathLock lock - _ -> pure () - closeStore store - forceRemoveIfExists tmpStore - pure $ case result of - Subst.SubstSuccess reg _ -> - if prNarHash reg == narHash && onDisk == "verified bytes" - then Pass - else Fail "registration or on-disk bytes diverge from the declared hash" - other -> Fail ("unpackAndVerify failed: " <> T.pack (show other)), - -- The verify-fails branch of the strict pipeline: bytes that do - -- not match the narinfo's signed NarHash or NarSize never reach - -- the unpack sink, so nothing is written at the store path and - -- the lock is free afterwards. - runTestM "unpackAndVerify writes nothing for a NAR that fails verification" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-unpack-unverified" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath (T.replicate 32 "f") "unverified" - rawNar = NAR.serialise (NAR.NarDirectory [("data.txt", NAR.NarRegular False "untrusted bytes")]) - consistent = - NarInfo.NarInfo - { NarInfo.niStorePath = storePathToText defaultStoreDir sp, - NarInfo.niUrl = "nar/unverified.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes rawNar), - NarInfo.niNarSize = toInteger (BS.length rawNar), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - wrongHash = consistent {NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes "not the nar")} - wrongSize = consistent {NarInfo.niNarSize = toInteger (BS.length rawNar) + 1} - destPath = storePathToFilePath (stDir store) sp - hashResult <- Subst.unpackAndVerify store sp wrongHash rawNar - sizeResult <- Subst.unpackAndVerify store sp wrongSize rawNar - written <- Dir.doesPathExist destPath - reLock <- tryAcquirePathLock (StoreDir tmpStore) sp - mapM_ releasePathLock reLock - closeStore store - forceRemoveIfExists tmpStore - pure $ case (hashResult, sizeResult, reLock) of - (Subst.SubstError hashErr, Subst.SubstError sizeErr, Just _) - | written -> Fail "an unverified NAR reached the store path" - | not ("NAR hash mismatch" `T.isInfixOf` hashErr) -> Fail ("wrong hash error: " <> hashErr) - | not ("NAR size mismatch" `T.isInfixOf` sizeErr) -> Fail ("wrong size error: " <> sizeErr) - | otherwise -> Pass - (_, _, Nothing) -> Fail "lock still held after a refused NAR" - other -> Fail ("expected two SubstError results, got: " <> T.pack (show other)) - ] - where - chainCache url = Subst.CacheConfig url ["unused-key"] 10 - -- A tree unpacked into a fresh destination through the strict and - -- the streaming path, each read back from disk, or the unpack's - -- refusal. The read-back tree carries every name and link target - -- as the bytes on disk, so equal trees serialise to the same NAR. - unpackedBothWays sensitivity dest tree = do - let raw = NAR.serialise tree - streamed = do - source <- chunkReader [raw] - outcome <- Subst.consumeNarStream sensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source - pure (either (Left . Subst.attemptFailureMessage) (const (Right ())) outcome) - readBack unpack = do - Subst.clearStaleDestination dest - result <- unpack - onDisk <- either (pure . Left) (const (Right <$> NAR.serialiseFromPath dest)) result - Subst.clearStaleDestination dest - pure onDisk - strict <- readBack (unpackNarEntry sensitivity dest tree) - viaStream <- readBack streamed - pure (strict, viaStream) - -- A real held lock for tests that construct 'SubstSuccess' by hand: - -- the constructor carries the path's lock, so a fabricated success - -- needs a genuine one, taken in a scratch directory. - withChainLock dirName act = do - tmpBase <- getTemporaryDirectory - let lockRoot = tmpBase (dirName :: FilePath) - forceRemoveIfExists lockRoot - createDirectoryIfMissing True lockRoot - lock <- acquirePathLock (StoreDir lockRoot) (StorePath (T.replicate 32 "d") "hit") - result <- act lock - releasePathLock lock - forceRemoveIfExists lockRoot - pure result - sampleNarBytes = "nova-nix nar sample bytes" :: BS.ByteString - sampleNarHash = CHash.formatNixHash (CHash.hashBytes sampleNarBytes) - wrongNarHash = CHash.formatNixHash (CHash.hashBytes ("different bytes" :: BS.ByteString)) - sampleHash = T.replicate 32 "a" - sampleNarInfo narHash = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/" <> sampleHash <> "-hello", - NarInfo.niUrl = "nar/sample.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Just sampleNarHash, - NarInfo.niFileSize = Just 0, - NarInfo.niNarHash = narHash, - NarInfo.niNarSize = fromIntegral (BS.length sampleNarBytes), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - -- A real xz stream: "nova-nix xz fixture payload\n" 64 times - -- (1792 bytes) compressed with xz -9 to 112 bytes, embedded as - -- base64 so the test source stays ASCII. - xzFixturePayload = BS.concat (replicate 64 "nova-nix xz fixture payload\n") - xzFixtureSize = toInteger (BS.length xzFixturePayload) - xzFixtureB64 = - "/Td6WFoAAATm1rRGAgAhARwAAAAQz1jM4Ab/AC1dADcbyzKSinKbUBue2bMHcUt1zJQMzAec5W6XwPbK3dKJtL3q9K3rfg1KQ/ZOAAAAAAAWUPRD8XwohgABSYAOAAAA2Eg7urHEZ/sCAAAAAARZWg==" :: Text - -- cache.nixos.org narinfos recorded 2026-08-20 (nixos-25.05 - -- channel), verbatim: GNU hello (references including itself, - -- deriver, production signature) and a doc output whose References - -- line is empty. - recordedHelloNarInfo = - T.unlines - [ "StorePath: /nix/store/jppkr0h8aap5z7m4xy4vg5yrwlly9h2v-hello-2.12.1", - "URL: nar/1m1sbal63vqhlvbcxzdj8yr6fhhld7dsyhxbxwip54dgvg56rjnc.nar.xz", - "Compression: xz", - "FileHash: sha256:1m1sbal63vqhlvbcxzdj8yr6fhhld7dsyhxbxwip54dgvg56rjnc", - "FileSize: 52056", - "NarHash: sha256:0s8wi24d3bc4zxyxq3hffj102zi7cjp3wqnpj6nhqrwgjsgqff81", - "NarSize: 249480", - "References: dska0s3gxxd8azbsn85pwm6xcqhivldw-glibc-2.40-66 jppkr0h8aap5z7m4xy4vg5yrwlly9h2v-hello-2.12.1", - "Deriver: a9y211d3lq3yf2mpfvb72f0qvsl0wi3s-hello-2.12.1.drv", - "Sig: cache.nixos.org-1:xV9xUvtPGHTSo6eeFWYYhaNFiH8MYSXKZzmxe0cf+acdDkIYxFPLC/MNc1CjlbsVoaUwGhcigUdr9eW2+W1UAw==" - ] - recordedHelloDocNarInfo = - T.unlines - [ "StorePath: /nix/store/4xrqj3kcd89bsg5crbpnx1ppg7nxw9xp-hello-1.0.0.2-doc", - "URL: nar/1r86zzj3g8jhzyvi17vchsj3frrqk5l329viq2i24iish53x922l.nar.xz", - "Compression: xz", - "FileHash: sha256:1r86zzj3g8jhzyvi17vchsj3frrqk5l329viq2i24iish53x922l", - "FileSize: 892", - "NarHash: sha256:0amizmj17fgj5sz1gvr743kncrzwvq747lml3zhd374f14hzgd7a", - "NarSize: 2072", - "References: ", - "Deriver: 5knzybx32a3iq53jjw6xd6fn4awn2l3h-hello-1.0.0.2.drv", - "Sig: cache.nixos.org-1:jUFHex7R7zPonZZqjVy/OOTguUZZE/sityC0zvu3sb35Az8zBTROeFhUC/J/UFx8Ui8UflA7uHyLJm5Z+Ca6Bw==" - ] - -- A NAR with the shapes streaming unpack must materialize: - -- nesting, an executable, a symlink, a zero-byte file, an empty - -- directory, and a sibling pair that collides on folding - -- filesystems. Entries in NAR name order. - -- Both survive a round trip through disk on every platform. The - -- executable bit does on Windows because the store keeps it in an - -- alternate data stream (#35); the nested symlink target does because - -- nova-cache 0.11.1.1 normalises a Windows reparse point's separators - -- back to the POSIX spelling at the NAR boundary (#112). - streamTestLinkTarget = "bin/tool" - streamTestNar = - NAR.serialise - ( NAR.NarDirectory - [ ("Makefile", NAR.NarRegular False "all:\n"), - ("bin", NAR.NarDirectory [("tool", NAR.NarRegular True "#!/bin/sh\n")]), - ("empty", NAR.NarRegular False ""), - ("emptydir", NAR.NarDirectory []), - ("link", NAR.NarSymlink streamTestLinkTarget), - ("makefile", NAR.NarRegular False "lower\n") - ] - ) - streamTestDigest = CHash.hashBytes streamTestNar - streamTestNarInfo rawNar = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/" <> sampleHash <> "-stream", - NarInfo.niUrl = "nar/stream.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes rawNar), - NarInfo.niNarSize = fromIntegral (BS.length rawNar), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - streamChunks chunkLen bytes - | BS.null bytes = [] - | otherwise = BS.take chunkLen bytes : streamChunks chunkLen (BS.drop chunkLen bytes) - -- The xz fixture's payload, compressed by nova-cache:zstandard's - -- own encoder - the exact pairing the push path ships. - zstdFixtureCompressed = CZstd.compress CZstd.defaultCompressionLevel xzFixturePayload - -- The same payload compressed by the bzip2 CLI (bzip2 -9), - -- embedded base64 so the test source stays ASCII. The reference - -- encoder is deliberately the format's own tool and not the - -- decoder's library: nova-cache:bzip2 decodes only, so a - -- self-produced fixture could not catch the two disagreeing. - bzip2FixtureB64 = - "QlpoOTFBWSZTWTop7coAAf/RgAAQQAInJddwIACQKZMTIMjAqqBkDaJtTgCQKgZA5AyBAFwNwMAeAYAgCQLgXA+AoBUCQIAkCAJAUAgCgH4u5IpwoSB0U9uU" :: Text - -- A NAR every platform materializes identically (no executable - -- bit, no separator-bearing symlink target), and the bzip2 CLI's - -- compression of exactly these bytes. - bzip2NarFixture = - NAR.serialise - (NAR.NarDirectory [("greeting", NAR.NarRegular False "nova-nix bzip2 fixture\n")]) - bzip2NarFixtureB64 = - "QlpoOTFBWSZTWa3VDM4AAFJ5gG7yAIBAYjAAP+ffcCAAlIaTJM1PUnqD1DJpoHo01BkkA9I0AAAAtARwcfWQAq1WLMjpmBpVKUAJM6EA8IDQEABOzcRgdDpvigJ6ZZa760fpxZtj+ts6GDiuqt/B6UuthWIrabWmZTkFlI46C8MmbMoVmMYwEYRUCYQW/F3JFOFCQrdUMzg=" :: Text - --- --------------------------------------------------------------------------- --- Tests: per-store-path locks (the substitution race) --- --------------------------------------------------------------------------- - --- | Watchdog for the concurrent-substitution race: generous, because a --- lock-protocol regression shows up as a hang, never as a fast wrong --- answer. -raceWatchdogMicros :: Int -raceWatchdogMicros = 30 * 1000000 - --- | How long a delete gets to (wrongly) finish while the path lock is --- held elsewhere: long enough that an unlocked delete of one tiny tree --- always completes inside it, while a correctly blocked delete waits --- until the release that follows the probe. -deleteLockProbeMicros :: Int -deleteLockProbeMicros = 500 * 1000 - --- | The executable bit's own representation, independent of any store. --- --- Every assertion here is platform-agnostic on purpose: the module's whole --- point is that a caller asks 'ExecBit' rather than the filesystem, so the --- same questions must have the same answers on Windows and on Unix even --- though the bit is kept in different places. -testExecBit :: IO [Bool] -testExecBit = do - putStrLn "store/exec-bit" - sequence - [ -- The round-trip the representation exists for: what was marked - -- reads back marked, and an unmarked sibling stays unmarked. - runTestM "exec mark round-trips through isExecutable" $ do - dir <- freshExecBitDir "roundtrip" - let marked = dir "tool" - plain = dir "data" - BS.writeFile marked "#!x" - BS.writeFile plain "hello" - ExecBit.markExecutable marked - isMarked <- ExecBit.isExecutable marked - isPlain <- ExecBit.isExecutable plain - forceRemoveIfExists dir - pure $ case (isMarked, isPlain) of - (True, False) -> Pass - (False, _) -> Fail "a marked file did not read back executable" - (_, True) -> Fail "an unmarked file read back executable", - -- copyExecMark out of a sealed store path. setReadOnly is what - -- placeInStore does, and on Windows copyFile propagates that - -- attribute to the copy, where a mark cannot be written until it is - -- cleared again. The source must also survive read-only. - runTestM "exec mark survives a copy out of a read-only source" $ do - dir <- freshExecBitDir "copy" - let src = dir "tool" - dest = dir "tool-copy" - BS.writeFile src "#!x" - ExecBit.markExecutable src - setReadOnly src - Dir.copyFile src dest - ExecBit.copyExecMark src dest - copied <- ExecBit.isExecutable dest - srcStillExec <- ExecBit.isExecutable src - -- Unseal before cleanup: a read-only file resists removal on - -- Windows the same way it resists a stream write. - Dir.getPermissions src >>= Dir.setPermissions src . Dir.setOwnerWritable True - forceRemoveIfExists dir - pure $ case (copied, srcStillExec) of - (True, True) -> Pass - (False, _) -> Fail "the copy lost its exec mark" - (_, False) -> Fail "sealing the source dropped its exec mark", - -- The serialiser reads the mark, not the file's permissions: this is - -- the flag a NAR carries, and on Windows getPermissions would answer - -- from the extension instead. - runTestM "serialiseFromPath reports the marked flag" $ do - dir <- freshExecBitDir "serialise" - let marked = dir "tool" - BS.writeFile marked "#!x" - BS.writeFile (dir "data") "hello" - ExecBit.markExecutable marked - entry <- ExecBit.serialiseFromPath processCaseHack dir - forceRemoveIfExists dir - pure $ case entry of - NAR.NarDirectory entries -> - assertEqual - "flags of (data, tool)" - [("data", False), ("tool", True)] - [(n, e) | (n, NAR.NarRegular e _) <- entries] - other -> Fail ("expected a directory entry, got: " <> T.pack (show other)), - -- The sink and the verifier must read one source of truth. A - -- substituted tree is written through markExecutable and its hash - -- rechecked on disk, so if narHashOfPath consulted the filesystem's - -- own idea of executability instead, every path holding a marked - -- file would be downloaded, rejected and deleted. - runTestM "narHashOfPath agrees with the serialiser it verifies" $ do - dir <- freshExecBitDir "hash" - let marked = dir "tool" - BS.writeFile marked "#!x" - BS.writeFile (dir "data") "hello" - ExecBit.markExecutable marked - streamed <- ExecBit.narHashOfPath processCaseHack dir - fromEntry <- NAR.narHash <$> ExecBit.serialiseFromPath processCaseHack dir - -- A control on the same axis: an unmarked tree must hash - -- differently, or agreement above would prove nothing. - unmarkedDir <- freshExecBitDir "hash-plain" - BS.writeFile (unmarkedDir "tool") "#!x" - BS.writeFile (unmarkedDir "data") "hello" - unmarked <- ExecBit.narHashOfPath processCaseHack unmarkedDir - forceRemoveIfExists dir - forceRemoveIfExists unmarkedDir - pure $ - if streamed /= fromEntry - then Fail "the verifier's hash disagrees with the serialiser's" - else - if streamed == unmarked - then Fail "the exec mark did not reach the hash at all" - else Pass, - -- correct/ recurses by name, and a non-ASCII name must survive that - -- recursion: decoding it a byte at a time names a file that is not - -- there and the mark silently reads as absent. - runTestM "a non-ASCII directory name keeps its child's mark" $ do - dir <- freshExecBitDir "utf8" - let sub = dir "\955-dir" - marked = sub "\955-tool" - createDirectoryIfMissing True sub - BS.writeFile marked "#!x" - ExecBit.markExecutable marked - entry <- ExecBit.serialiseFromPath processCaseHack dir - forceRemoveIfExists dir - pure $ case entry of - NAR.NarDirectory [(_, NAR.NarDirectory [(_, NAR.NarRegular True _)])] -> Pass - other -> Fail ("expected one marked child, got: " <> T.pack (show other)) - ] - --- | An empty scratch directory for one 'testExecBit' case. -freshExecBitDir :: String -> IO FilePath -freshExecBitDir name = do - tmpBase <- getTemporaryDirectory - let dir = tmpBase ("nova-nix-test-execbit-" ++ name) - forceRemoveIfExists dir - createDirectoryIfMissing True dir - pure dir - -testPathLocks :: IO [Bool] -testPathLocks = do - putStrLn "store/path-locks" - sequence - [ -- Two independent handles on one path lock exclude each other - - -- the guarantee flock and LockFileEx share, and exactly the shape - -- of two processes contending for one store path. - runTestM "path lock excludes a second handle" $ do - tmpBase <- getTemporaryDirectory - let lockRoot = tmpBase "nova-nix-test-lock-excl" - forceRemoveIfExists lockRoot - createDirectoryIfMissing True lockRoot - let dir = StoreDir lockRoot - sp = StorePath (T.replicate 32 "a") "lockee" - held <- acquirePathLock dir sp - second <- tryAcquirePathLock dir sp - releasePathLock held - third <- tryAcquirePathLock dir sp - mapM_ releasePathLock second - mapM_ releasePathLock third - forceRemoveIfExists lockRoot - pure $ case (second, third) of - (Nothing, Just _) -> Pass - (Just _, _) -> Fail "a second handle acquired a held lock" - (Nothing, Nothing) -> Fail "release did not free the lock", - -- The already-valid short-circuit: a registered path substitutes - -- as SubstAlreadyValid with no network and no disk writes - the - -- configured cache is unreachable, so any contact would surface - -- as an error result. - runTestM "trySubstitute adopts an already-valid path untouched" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-lock-valid" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath (T.replicate 32 "c") "validpath" - destPath = storePathToFilePath (StoreDir tmpStore) sp - createDirectoryIfMissing True destPath - BS.writeFile (destPath "payload") "registered bytes" - reg <- registrationFor store sp Nothing [] - registerPath (stDB store) reg - result <- Subst.trySubstitute store [unreachableCache] sp - survivor <- BS.readFile (destPath "payload") - -- The short-circuit released the lock, so the path must be - -- lockable again at once. - reLock <- tryAcquirePathLock (StoreDir tmpStore) sp - mapM_ releasePathLock reLock - closeStore store - forceRemoveIfExists tmpStore - pure $ case (result, reLock) of - (Subst.SubstAlreadyValid, Just _) - | survivor == "registered bytes" -> Pass - | otherwise -> Fail "tree touched during already-valid adoption" - (Subst.SubstAlreadyValid, Nothing) -> Fail "lock still held after already-valid return" - (other, _) -> Fail ("expected SubstAlreadyValid, got: " <> T.pack (show other)), - -- The strict pipeline honors the same short-circuit: fed a - -- DIFFERENT (self-consistent) NAR for an already-valid path, it - -- must adopt the registered tree rather than overwrite it. - runTestM "unpackAndVerify adopts an already-valid path untouched" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-lock-valid-strict" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath (T.replicate 32 "d") "strictvalid" - destPath = storePathToFilePath (StoreDir tmpStore) sp - createDirectoryIfMissing True destPath - BS.writeFile (destPath "payload") "registered bytes" - reg <- registrationFor store sp Nothing [] - registerPath (stDB store) reg - let differentNar = NAR.serialise (NAR.NarDirectory [("other", NAR.NarRegular False "different bytes")]) - result <- Subst.unpackAndVerify store sp (lockTestNarInfo sp differentNar) differentNar - survivor <- BS.readFile (destPath "payload") - closeStore store - forceRemoveIfExists tmpStore - pure $ case result of - Subst.SubstAlreadyValid - | survivor == "registered bytes" -> Pass - | otherwise -> Fail "tree touched during already-valid adoption" - other -> Fail ("expected SubstAlreadyValid, got: " <> T.pack (show other)), - -- The race the locks exist for: two concurrent substitutions of - -- one path, independent lock handles. Exactly one materializes; - -- the other waits at the lock and adopts the winner's registered - -- path; the surviving tree is intact and registered once. - runTestM "concurrent substitutions: one materializes, one adopts" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-lock-race" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath (T.replicate 32 "e") "racepath" - destPath = storePathToFilePath (StoreDir tmpStore) sp - rawNar = NAR.serialise (NAR.NarDirectory [("data", NAR.NarRegular False "race payload")]) - -- The caller's contract per attempt: register under the - -- still-held lock, then release it. - attempt = do - result <- Subst.unpackAndVerify store sp (lockTestNarInfo sp rawNar) rawNar - case result of - Subst.SubstSuccess winnerReg lock -> do - registerPath (stDB store) winnerReg - releasePathLock lock - _ -> pure () - pure result - firstDone <- newEmptyMVar - secondDone <- newEmptyMVar - _ <- forkIO ((try attempt :: IO (Either SomeException Subst.SubstResult)) >>= putMVar firstDone) - _ <- forkIO ((try attempt :: IO (Either SomeException Subst.SubstResult)) >>= putMVar secondDone) - outcomeA <- timeout raceWatchdogMicros (takeMVar firstDone) - outcomeB <- timeout raceWatchdogMicros (takeMVar secondDone) - rowCount <- length <$> queryAllValidPaths (stDB store) - onDisk <- NAR.serialiseFromPath destPath - closeStore store - forceRemoveIfExists tmpStore - pure $ case (outcomeA, outcomeB) of - (Just (Right resultA), Just (Right resultB)) -> - let outcomes = [resultA, resultB] - materialized = length [() | Subst.SubstSuccess _ _ <- outcomes] - adopted = length [() | Subst.SubstAlreadyValid <- outcomes] - in if materialized == 1 && adopted == 1 && rowCount == 1 && NAR.serialise onDisk == rawNar - then Pass - else - Fail - ( "unexpected race outcome: " - <> T.pack (show outcomes) - <> ", registered rows: " - <> T.pack (show rowCount) - ) - other -> Fail ("a race attempt hung or threw: " <> T.pack (show other)) - ] - where - -- Never contacted when the already-valid short-circuit holds; a - -- regression that reaches for the network fails loudly here. - unreachableCache = Subst.CacheConfig "http://127.0.0.1:9" ["unused-key"] 10 - lockTestNarInfo sp rawNar = - NarInfo.NarInfo - { NarInfo.niStorePath = storePathToText defaultStoreDir sp, - NarInfo.niUrl = "nar/lock-test.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes rawNar), - NarInfo.niNarSize = fromIntegral (BS.length rawNar), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - --- --------------------------------------------------------------------------- --- Tests: Build orchestrator (Phase 3, Batch 7) --- --------------------------------------------------------------------------- - -testBuildOrchestrator :: IO [Bool] -testBuildOrchestrator = do - putStrLn "build/orchestrator" - sequence - [ -- BuildConfig has caches field - runTest "defaultBuildConfig has empty caches" $ - assertEqual "empty-caches" [] (bcCaches (defaultBuildConfig defaultStoreDir)), - -- Upstream's shape is a product token with the version; the comment - -- after it is ours. What bot mitigation keys on is that there is one. - runTest "the User-Agent is a nova-nix product token with a version" $ - assertEqual "ua" True ("nova-nix/" `BS.isPrefixOf` userAgent && BS.length userAgent > BS.length "nova-nix/ (+https://github.com/Novavero-AI/nova-nix)"), - runTestM "withUserAgent sets exactly one User-Agent, replacing any present" $ do - request0 <- HTTP.parseRequest "http://127.0.0.1/narinfo-hashes" - let stale = request0 {HTTP.requestHeaders = [("User-Agent", "curl/0"), ("Accept", "*/*")]} - pure (assertEqual "headers" [("User-Agent", userAgent), ("Accept", "*/*")] (HTTP.requestHeaders (withUserAgent stale))), - -- The build PATH must never open with the build working directory: - -- a bare-name builder has no directory to derive. - runTest "bare-name builder derives no PATH entry" $ - let entries = T.splitOn (if SI.os == "mingw32" then ";" else ":") (buildPath "bash") - in assertEqual "no-dot" False (any (\e -> e == "." || T.isPrefixOf "./" e || T.isPrefixOf ".\\" e) entries), - runTest "dot-relative builder derives no PATH entry" $ - let entries = T.splitOn (if SI.os == "mingw32" then ";" else ":") (buildPath "./bash") - in assertEqual "no-dot-rel" False (any (\e -> e == "." || T.isPrefixOf "./" e || T.isPrefixOf ".\\" e) entries), - runTest "absolute builder opens PATH with its own directory" $ - let path = buildPath ("/store/aaa-bootstrap/bin" "bash") - in assertEqual "builder-dir-first" (Just "/store/aaa-bootstrap/bin") (listToMaybe (T.splitOn (if SI.os == "mingw32" then ";" else ":") path)), - -- unionEnvs: earlier maps win; on Windows displacement is - -- case-insensitive and keeps the winner's spelling. - runTest "unionEnvs left map wins" $ - assertEqual - "left-bias" - (Just "build") - (Map.lookup "A" (unionEnvs [Map.fromList [("A", "build")], Map.fromList [("A", "host")]])), - runTest "unionEnvs displaces a case variant on Windows" $ - let merged = unionEnvs [Map.fromList [("PATH", "build")], Map.fromList [("Path", "host")]] - in if SI.os == "mingw32" - then assertEqual "displaced" (Map.fromList [("PATH", "build")]) merged - else assertEqual "distinct" (Map.fromList [("PATH", "build"), ("Path", "host")]) merged, - -- scrubAmbient: nothing ambient survives on Unix; on Windows only - -- the allowlist passes (keeping its ambient spelling), COMSPEC is - -- synthesized from SystemRoot, and PATHEXT is pinned. - runTest "scrubAmbient drops undeclared ambient variables" $ - let ambient = - Map.fromList - [ ("SystemRoot", "C:\\WINDOWS"), - ("APPDATA", "C:\\Users\\host\\AppData\\Roaming"), - ("LANG", "en_US.UTF-8"), - ("Path", "C:\\host\\bin") - ] - scrubbed = scrubAmbient ambient - in if SI.os == "mingw32" - then - assertEqual - "allowlist-only" - ( Map.fromList - [ ("SystemRoot", "C:\\WINDOWS"), - ("COMSPEC", "C:\\WINDOWS\\System32\\cmd.exe"), - ("PATHEXT", ".COM;.EXE;.BAT;.CMD") - ] - ) - scrubbed - else assertEqual "empty" Map.empty scrubbed, - runTest "scrubAmbient pins PATHEXT even without SystemRoot" $ - let scrubbed = scrubAmbient Map.empty - in if SI.os == "mingw32" - then assertEqual "pinned" (Map.fromList [("PATHEXT", ".COM;.EXE;.BAT;.CMD")]) scrubbed - else assertEqual "empty" Map.empty scrubbed, - -- Build-time placeholder substitution. Upstream rewrites the whole - -- @name=value@ string (local-derivation-goal.cc:2004), so a sentinel in - -- a dynamic attribute name is substituted along with the values. - runTest "rewritePlaceholders substitutes an output sentinel" $ - assertEqual - "substituted" - "/store/aaa-p/lib" - (rewritePlaceholders [("out", "/store/aaa-p")] (hashPlaceholder "out" <> "/lib")), - runTest "rewritePlaceholders leaves a foreign output's sentinel alone" $ - assertEqual - "untouched" - (hashPlaceholder "dev") - (rewritePlaceholders [("out", "/store/aaa-p")] (hashPlaceholder "dev")), - runTest "rewriteEnv rewrites names as well as values" $ - let rewrite = rewritePlaceholders [("out", "/store/aaa-p")] - env = Map.fromList [(hashPlaceholder "out" <> "-flag", hashPlaceholder "out" <> "/lib")] - in assertEqual - "name-and-value" - (Map.fromList [("/store/aaa-p-flag", "/store/aaa-p/lib")]) - (rewriteEnv rewrite env), - -- BuildConfig with caches - runTest "BuildConfig accepts caches" $ - let cache = Subst.CacheConfig "https://cache.example.com" ["key"] 10 - config = (defaultBuildConfig defaultStoreDir) {bcCaches = [cache]} - in assertEqual "one-cache" 1 (length (bcCaches config)), - -- buildWithDeps on a simple derivation (no deps, builder fails but graph resolves) - runTestM "buildWithDeps single drv" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-orch" - createDirectoryIfMissing True tmpStore - store <- openStore (StoreDir tmpStore) - let drv = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = StorePath "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" "test-out", - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = "/nonexistent-builder", - drvArgs = [], - drvEnv = Map.singleton "name" "test" - } - drvSP = StorePath "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy" "test.drv" - -- Write .drv to store so buildWithDeps can read it - writeDrv store drv drvSP - let config = (defaultBuildConfig (StoreDir tmpStore)) {bcTmpDir = tmpBase "nova-nix-test-orch-tmp"} - result <- buildWithDeps config store drv drvSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - -- Builder will fail (nonexistent) but the graph should resolve - -- correctly: the failure must come from SPAWNING THE BUILDER, not - -- from graph resolution or drv reading upstream of it. - pure $ case result of - BuildFailure msg _ - | "nonexistent-builder" `T.isInfixOf` msg -> Pass - | otherwise -> Fail ("failed before reaching the builder: " <> msg) - BuildSuccess _ -> Fail "expected build failure for nonexistent builder", - -- buildWithDeps with cycle detection (mocked through malformed graph) - runTest "cycle detection returns failure" $ - let spA = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "a.drv" - spB = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "b.drv" - drvACyc = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.singleton spB ["out"], - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/sh", - drvArgs = [], - drvEnv = Map.empty - } - drvBCyc = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.singleton spA ["out"], - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/sh", - drvArgs = [], - drvEnv = Map.empty - } - readFn sp - | sp == spB = Right drvBCyc - | sp == spA = Right drvACyc - | otherwise = Left "unknown" - in case pureDepGraph readFn drvACyc spA of - Right graph -> case DepGraph.topoSort graph of - DepGraph.TopoCycle _ -> Pass - DepGraph.TopoSorted order -> Fail ("expected cycle, got sorted: " <> T.pack (show order)) - Left err -> Fail ("expected graph to build, got: " <> err), - -- missing .drv causes failure in dep graph - runTest "missing drv in dep graph" $ - let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "missing.drv" - drv = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.singleton sp ["out"], - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/sh", - drvArgs = [], - drvEnv = Map.empty - } - readFn _ = Left "not found" - in case pureDepGraph readFn drv (StorePath "rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr" "root.drv") of - Left _ -> Pass - Right _ -> Fail "expected failure for missing .drv", - -- derivation with context creates populated inputDrvs. Hashing a - -- dependent derivation reads input modulo hashes from the drv-hash - -- cache, which only the IO evaluator maintains, so this runs under - -- evalNixIO (an in-session dependency hits the cache bottom-up). - runTestM "derivation context populates inputDrvs" $ do - tmpBase <- getTemporaryDirectory - result <- - evalDerivationIO tmpBase $ - T.concat - [ "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ", - "main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; src = dep.outPath; }; ", - "in main" - ] - pure $ assertRight "drv-ctx-inputs" result $ \drv -> - if Map.null (drvInputDrvs drv) - then Fail "expected non-empty drvInputDrvs" - else Pass, - -- drv3: a dependent derivation's drvPath is stable across evaluations - -- (the input modulo substitution is deterministic). - runTestM "dependent derivation drvPath is deterministic (IO eval)" $ do - tmpBase <- getTemporaryDirectory - let expr = - T.concat - [ "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ", - "main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; src = dep.outPath; }; ", - "in main.drvPath" - ] - r1 <- evalNixIO tmpBase expr - r2 <- evalNixIO tmpBase expr - pure $ case (r1, r2) of - (Right (VStr a _), Right (VStr b _)) - | a == b -> Pass - | otherwise -> Fail ("drvPath not deterministic: " <> bytesText a <> " vs " <> bytesText b) - _ -> Fail "expected main.drvPath to evaluate to a string under IO eval", - -- drv1: embedding another derivation's drvPath (an all-outputs ref) adds - -- it to inputDrvs carrying the referenced derivation's FULL - -- output-name set; the IO evaluator recovers the names in-session. - runTestM "derivation embedding a drvPath lists all its outputs in inputDrvs (IO eval)" $ do - tmpBase <- getTemporaryDirectory - let depSrc = "derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ \"out\" \"dev\" ]; }" - depPathR <- evalNixIO tmpBase ("(" <> depSrc <> ").drvPath") - result <- - evalDerivationIO tmpBase $ - T.concat - [ "let dep = ", - depSrc, - "; main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ref = dep.drvPath; }; ", - "in main" - ] - pure $ case (depPathR, result) of - (Right (VStr depPathBytes _), Right drv) -> - case parseStorePath defaultStoreDir (bytesText depPathBytes) of - Nothing -> Fail ("unparseable dep drvPath: " <> bytesText depPathBytes) - Just depSP -> case Map.lookup depSP (drvInputDrvs drv) of - Just outs - | Set.fromList outs == Set.fromList ["dev", "out"] -> Pass - | otherwise -> Fail ("expected the full output set [dev, out], got " <> T.pack (show outs)) - Nothing -> Fail "dep .drv missing from inputDrvs despite the deep drvPath ref" - other -> Fail ("expected dep drvPath and main's derivation, got " <> T.pack (show other)) - ] - --- --------------------------------------------------------------------------- --- Tests: Store.DB (Phase 2, Batch 1) --- --------------------------------------------------------------------------- - --- | Helper: run a test with a temporary store DB, cleaning up after. -withTempStoreDB :: (StoreDir -> IO [Bool]) -> IO [Bool] -withTempStoreDB action = do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-store-db" - removeIfExists tmpStore - createDirectoryIfMissing True tmpStore - results <- action (StoreDir tmpStore) - removeIfExists tmpStore - pure results - -removeIfExists :: FilePath -> IO () -removeIfExists path = do - exists <- doesDirectoryExist path - when exists (removeDirectoryRecursive path) - --- | Names a directory on a case-sensitive volume for --- 'testCaseSensitiveVolumeIO'. A Linux temp directory qualifies on --- its own; on macOS a "Case-sensitive APFS" image attached with --- hdiutil does, and the default volume does not. -caseSensitiveDirVar :: String -caseSensitiveDirVar = "NOVA_NIX_TEST_CASE_SENSITIVE_DIR" - --- | True-name materialization on a volume that does not fold: a store --- opened there probes sensitive, and a NAR carrying @Makefile@ and --- @makefile@ unpacks to two files under their own names through the --- strict and the streaming substituter paths alike. A directory named --- by 'caseSensitiveDirVar' is held to the claim: one that is missing --- or probes folding FAILS, since the variable is how a run asserts a --- volume (macOS CI attaches an image for it) and a typo must not read --- as "no volume available". With the variable unset the temp --- directory is tried, and skips where it folds. -testCaseSensitiveVolumeIO :: IO [Bool] -testCaseSensitiveVolumeIO = do - putStrLn "store/case-sensitive-volume" - named <- lookupEnv caseSensitiveDirVar - case named of - Just base -> do - verdict <- namedDirVerdict base - case verdict of - Right () -> testCaseSensitiveVolumeBody base - Left reason -> - (: []) <$> runTest (T.pack caseSensitiveDirVar <> " names a case-sensitive directory") (Fail reason) - Nothing -> do - tmpBase <- getTemporaryDirectory - sensitivity <- probeCaseSensitivity tmpBase - case sensitivity of - CaseInsensitive -> do - putStrLn (" SKIP needs a case-sensitive volume (" ++ caseSensitiveDirVar ++ " names a directory on one)") - pure [] - CaseSensitive -> testCaseSensitiveVolumeBody tmpBase - where - namedDirVerdict base = do - present <- doesDirectoryExist base - if not present - then pure (Left (T.pack base <> " does not exist")) - else do - sensitivity <- probeCaseSensitivity base - pure $ case sensitivity of - CaseSensitive -> Right () - CaseInsensitive -> Left (T.pack base <> " probes " <> T.pack (show CaseInsensitive)) - -testCaseSensitiveVolumeBody :: FilePath -> IO [Bool] -testCaseSensitiveVolumeBody base = do - let storeRoot = base "nova-nix-test-cs-store" - storeDir = StoreDir storeRoot - tree = - NAR.NarDirectory - [ ("Makefile", NAR.NarRegular False "upper"), - ("makefile", NAR.NarRegular False "lower") - ] - rawNar = NAR.serialise tree - digest = CHash.hashBytes rawNar - narInfoOf nar sp = - NarInfo.NarInfo - { NarInfo.niStorePath = storePathToText defaultStoreDir sp, - NarInfo.niUrl = "nar/case.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes nar), - NarInfo.niNarSize = fromIntegral (BS.length nar), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - narInfoFor = narInfoOf rawNar - -- A name carrying the case-hack suffix beside the name it would - -- strip to: read with the suffix stripped, the two collide. - suffixTree = - NAR.NarDirectory - [ ("Makefile", NAR.NarRegular False "upper"), - ("Makefile~nix~case~hack~1", NAR.NarRegular False "literal") - ] - suffixNar = NAR.serialise suffixTree - suffixNames sp = do - names <- sort <$> Dir.listDirectory (storePathToFilePath storeDir sp) - pure (assertEqual "on-disk names" ["Makefile", "Makefile~nix~case~hack~1"] names) - -- Both spellings present with their own contents, and nothing - -- carrying the case-hack suffix. - trueNames sp = do - let dest = storePathToFilePath storeDir sp - names <- Dir.listDirectory dest - upper <- BS.readFile (dest "Makefile") - lower <- BS.readFile (dest "makefile") - pure $ - if sort names == ["Makefile", "makefile"] && upper == "upper" && lower == "lower" - then Pass - else Fail ("on disk: " <> T.pack (show names)) - forceRemoveIfExists storeRoot - store <- openStore storeDir - results <- - sequence - [ runTest "the store probes its volume as case-sensitive" $ - assertEqual "stCaseSensitivity" CaseSensitive (stCaseSensitivity store), - runTestM "strict substitution materializes true names" $ do - let sp = StorePath (T.replicate 32 "c") "case-strict" - result <- Subst.unpackAndVerify store sp (narInfoFor sp) rawNar - case result of - Subst.SubstSuccess _ lock -> do - releasePathLock lock - trueNames sp - other -> pure (Fail ("substitution failed: " <> T.pack (show other))), - runTestM "streaming substitution materializes true names" $ do - let sp = StorePath (T.replicate 32 "d") "case-stream" - source <- chunkReader [rawNar] - result <- Subst.materializeNarFromSource store sp (narInfoFor sp) digest [] Nothing source - case result of - Right _ -> trueNames sp - Left err -> pure (Fail ("streaming substitution failed: " <> Subst.attemptFailureMessage err)), - -- Nothing on a volume that keeps names apart is ever hacked, so - -- a name carrying the suffix is a name like any other: both - -- pipelines accept it, and their on-disk rechecks read it back - -- as spelled (#236). - runTestM "a name carrying the case-hack suffix substitutes verbatim, strict" $ do - let sp = StorePath (T.replicate 32 "e") "suffix-strict" - result <- Subst.unpackAndVerify store sp (narInfoOf suffixNar sp) suffixNar - case result of - Subst.SubstSuccess _ lock -> do - releasePathLock lock - suffixNames sp - other -> pure (Fail ("substitution failed: " <> T.pack (show other))), - runTestM "a name carrying the case-hack suffix substitutes verbatim, streaming" $ do - let sp = StorePath (T.replicate 32 "f") "suffix-stream" - source <- chunkReader [suffixNar] - result <- Subst.materializeNarFromSource store sp (narInfoOf suffixNar sp) (CHash.hashBytes suffixNar) [] Nothing source - case result of - Right _ -> suffixNames sp - Left err -> pure (Fail ("streaming substitution failed: " <> Subst.attemptFailureMessage err)), - -- A store path already on this volume is read back as spelled - -- too: an evaluation write holding the name reproduces its - -- address and registers the NAR upstream dumps for it with - -- use-case-hack off ('suffixPairNarHash'). - runTestM "a store path naming a file with the case-hack suffix registers under that name" $ - case makeFixedOutputPath "suffix-write" "sha256" "recursive" (sha256Digest suffixNar) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let dest = storePathToFilePath storeDir sp - createDirectoryIfMissing True dest - BS.writeFile (dest "Makefile") "upper" - BS.writeFile (dest "Makefile~nix~case~hack~1") "literal" - materializeEvalStoreWrites store (Map.singleton (storePathToText defaultStoreDir sp) ([], WriteRecursive)) - info <- queryPathInfo (stDB store) sp - pure $ case info of - Just row -> assertEqual "registered NAR hash" suffixPairNarHash (piNarHash row) - Nothing -> Fail "not registered", - -- Evaluation reads a store path as the store does: copying one - -- holding the name hashes it as spelled, where a source read - -- would follow the process and, on macOS, strip it. - runTestM "builtins.path reads a store path under its volume's case-hack mode" $ do - let held = StorePath (T.replicate 32 "g") "suffix-read" - heldPath = storePathToFilePath storeDir held - createDirectoryIfMissing True heldPath - BS.writeFile (heldPath "Makefile") "upper" - BS.writeFile (heldPath "Makefile~nix~case~hack~1") "literal" - copied <- - evalNixIOStore - storeDir - "." - ("builtins.path { path = " <> storePathToText defaultStoreDir held <> "; name = \"suffix-copy\"; }") - let expected = storePathToText defaultStoreDir <$> makeFixedOutputPath "suffix-copy" "sha256" "recursive" (sha256Digest suffixNar) - case (copied, expected) of - (Right (VStr pathBytes _), Right expectedPath) - | bytesText pathBytes /= expectedPath -> pure (Fail ("copied to " <> bytesText pathBytes <> ", expected " <> expectedPath)) - | otherwise -> maybe (pure (Fail "unparseable store path")) suffixNames (parseStorePath defaultStoreDir expectedPath) - (Left err, _) -> pure (Fail ("eval failed: " <> err)) - other -> pure (Fail ("unexpected result: " <> T.pack (show other))), - -- A source tree copied off this volume into one that folds the - -- sharp-s pair: the two names are distinct here and one name - -- there, so the copy refuses the second at the write rather - -- than landing it on the first (#234). - runTestM "a copy into a volume that folds a pair refuses the later name" $ do - probed <- tempFoldsSharpS - case probed of - Left reason -> Pass <$ putStrLn (" SKIP " ++ reason) - Right tmpBase -> do - let src = base "nova-nix-test-cs-copy-src" - dest = tmpBase "nova-nix-test-cs-copy-dest" - contents = Map.fromList [(T.unpack sharpSUpper, "upper"), (T.unpack sharpSLower, "lower")] - forceRemoveIfExists src - Subst.clearStaleDestination dest - createDirectoryIfMissing True src - mapM_ (\(name, bytes) -> BS.writeFile (src name) bytes) (Map.toList contents) - -- The copy walks the listing's order, which the volume - -- chooses, so the refused name is whichever comes second. - listed <- Dir.listDirectory src - outcome <- try (copyPathInto src dest) - landed <- traverse (\name -> (,) name <$> BS.readFile (dest name)) (take 1 listed) - forceRemoveIfExists src - Subst.clearStaleDestination dest - pure $ case (listed, outcome) of - ([earlier, later], Left (e :: IOException)) - | T.pack (ioeGetErrorString e) /= "creating file '" <> quotedAsCxx (dest later) <> "': File exists" -> - Fail ("unexpected refusal: " <> T.pack (show e)) - | landed /= [(earlier, Map.findWithDefault "" earlier contents)] -> - Fail ("the earlier entry was overwritten: " <> T.pack (show landed)) - | otherwise -> Pass - (_, Right ()) -> Fail ("the copy succeeded; on disk: " <> T.pack (show landed)) - other -> Fail ("unexpected listing or outcome: " <> T.pack (show other)), - -- A source holding a case-only pair, built against a store - -- whose volume folds: evaluation names the two-file tree, and - -- the store holds it as upstream's restore does, the later - -- name case-hacked, registered under that address (#235). - runTestM "a coerced source's case-only pair is stored case-hacked on a folding store" $ - caseOnlyPairBuild base canonPathValue, - runTestM "builtins.path stores a case-only pair case-hacked on a folding store" $ - caseOnlyPairBuild base (\srcPath -> "builtins.path { path = " <> canonPathValue srcPath <> "; }") - ] - closeStore store - forceRemoveIfExists storeRoot - pure results - --- | What upstream records for 'caseOnlyPairBuild''s source on a --- folding volume: nix-instantiate 2.33.2 with --- @--store 'local?root=...'@ adds it at this path, @nix-store --- --query --hash@ and @--size@ report this NAR hash and size, and the --- tree holds @Makefile@ and @makefile~nix~case~hack~1@. -caseOnlyPairPath :: StorePath -caseOnlyPairPath = StorePath "1rn1vqr2y9f65qg5vflbfr5gkwllmp22" "src" - -caseOnlyPairNarHash :: Text -caseOnlyPairNarHash = "sha256:04z1mpa501269w2aqjr3kq5k4y85hjzbisvfc3jgmw3dnd7va9hl" - -caseOnlyPairNarSize :: Int -caseOnlyPairNarSize = 480 - --- | Build a derivation whose @src@ is the given expression over a --- source directory named @src@ holding @Makefile@ and @makefile@, on a --- case-sensitive base, against a store in the temp directory, and --- hold the result to what upstream stores ('caseOnlyPairPath'). Skips --- where the temp directory's volume does not fold. -caseOnlyPairBuild :: FilePath -> (Text -> Text) -> IO TestResult -caseOnlyPairBuild base srcExpr = do - tmpBase <- getTemporaryDirectory - sensitivity <- probeCaseSensitivity tmpBase - case sensitivity of - CaseSensitive -> Pass <$ putStrLn " SKIP the temp directory's volume does not fold case" - CaseInsensitive -> do - shell <- findTestShell - let srcRoot = base "nova-nix-test-cs-pair" - srcDir = srcRoot "src" - tmpStore = tmpBase "nova-nix-test-cs-pair-store" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - source = - T.concat - [ "derivation { name = \"pair\"; system = builtins.currentSystem; ", - "builder = \"" <> nixEscape shell <> "\"; ", - "args = [\"-c\" \"cd $src && for f in *; do echo \\\"$f\\\"; done > $out\"]; ", - "src = " <> srcExpr (T.pack srcDir) <> "; }" - ] - forceRemoveIfExists srcRoot - forceRemoveIfExists tmpStore - createDirectoryIfMissing True srcDir - BS.writeFile (srcDir "Makefile") "upper\n" - BS.writeFile (srcDir "makefile") "lower\n" - built <- evalAndBuild (StoreDir tmpStore) source - verdict <- case built of - Left err -> pure (Fail err) - Right (BuildFailure msg _, store) -> Fail msg <$ closeStore store - Right (BuildSuccess outSP, store) -> do - let stored = storePathToFilePath (stDir store) caseOnlyPairPath - names <- sort <$> Dir.listDirectory stored - contents <- traverse (BS.readFile . (stored )) names - info <- queryPathInfo (stDB store) caseOnlyPairPath - seen <- BS.readFile (storePathToFilePath (stDir store) outSP) - closeStore store - let hacked = ["Makefile", "makefile~nix~case~hack~1"] - pure $ case info of - Nothing -> Fail "the source path is not registered" - Just row - | names /= hacked || contents /= ["upper\n", "lower\n"] -> - Fail ("stored as " <> T.pack (show (zip names contents))) - | piNarHash row /= caseOnlyPairNarHash || piNarSize row /= caseOnlyPairNarSize -> - Fail ("registered " <> piNarHash row <> " / " <> T.pack (show (piNarSize row))) - | seen /= "Makefile\nmakefile~nix~case~hack~1\n" -> - Fail ("the builder saw " <> T.pack (show seen)) - | otherwise -> Pass - forceRemoveIfExists srcRoot - forceRemoveIfExists tmpStore - pure verdict - --- | The NAR hash of a directory holding @Makefile@ (@upper@) and --- @Makefile~nix~case~hack~1@ (@literal@): @nix-store --option --- use-case-hack false --dump@ 2.33.2 piped to @nix-hash --flat@. With --- the setting at its macOS default the dump strips the suffix and --- fails on the collision. -suffixPairNarHash :: Text -suffixPairNarHash = "sha256:1x31cqjvkihkh3wbzq00z8xplwbf7i0bpk3g9vqs403lh3f5b4gs" - --- | A path as upstream's formatter streams a @std::filesystem::path@: --- through @std::quoted@, in double quotes with a double quote or a --- backslash inside escaped by a backslash. -quotedAsCxx :: FilePath -> Text -quotedAsCxx path = "\"" <> T.replace "\"" "\\\"" (T.replace "\\" "\\\\" (T.pack path)) <> "\"" - --- | U+1E9E (capital sharp s) and U+00DF (small sharp s): a pair APFS --- folds to one name and 'onDiskNameKey' keeps apart, since 'toUpper' --- leaves U+00DF as it is (#234). Escaped, as the source is ASCII. -sharpSUpper, sharpSLower :: Text -sharpSUpper = "STRA\x1E9E\&E" -sharpSLower = "stra\xDF\&e" - --- | Whether the volume holding a directory folds the sharp-s pair, --- answered by the volume itself: one spelling is created and the other --- looked up. The store's probe says whether a volume folds case at --- all, not which pairs its table folds. -sharpSFolds :: FilePath -> IO Bool -sharpSFolds dir = do - let probeDir = dir "nova-nix-test-sharp-s-probe" - Subst.clearStaleDestination probeDir - createDirectoryIfMissing True probeDir - BS.writeFile (probeDir T.unpack sharpSUpper) "probe" - folds <- Dir.doesFileExist (probeDir T.unpack sharpSLower) - Subst.clearStaleDestination probeDir - pure folds - --- | Whether the suite's temp directory folds the sharp-s pair: the --- store's own probe first, then the volume for the pair itself. -tempFoldsSharpS :: IO (Either String FilePath) -tempFoldsSharpS = do - tmpBase <- getTemporaryDirectory - sensitivity <- probeCaseSensitivity tmpBase - case sensitivity of - CaseSensitive -> pure (Left "the temp directory's volume does not fold case") - CaseInsensitive -> do - folds <- sharpSFolds tmpBase - pure $ - if folds - then Right tmpBase - else Left "the temp directory's volume folds case but keeps U+1E9E and U+00DF apart" - --- | A sibling pair the volume folds but 'onDiskNameKey' keeps apart --- (#234). The exclusive create refuses the later entry at the write, --- in upstream's wording and naming it, through both unpack paths, and --- the earlier entry keeps its own content: nothing lands on it, and --- two directories do not merge. A link needed no new exclusivity --- (link creation never replaces a name); its refusal is pinned --- alongside. Skips with the reason where the temp directory's volume --- does not fold the pair. -testFoldingVolumeIO :: IO [Bool] -testFoldingVolumeIO = do - putStrLn "store/folding-volume" - probed <- tempFoldsSharpS - case probed of - Left reason -> do - putStrLn (" SKIP " ++ reason) - pure [] - Right tmpBase -> testFoldingVolumeBody (tmpBase "nova-nix-test-folding") - -testFoldingVolumeBody :: FilePath -> IO [Bool] -testFoldingVolumeBody root = do - let upperName = T.unpack sharpSUpper - lowerName = T.unpack sharpSLower - pair earlier later = - NAR.NarDirectory [(TE.encodeUtf8 sharpSUpper, earlier), (TE.encodeUtf8 sharpSLower, later)] - filePair = pair (NAR.NarRegular False "upper") (NAR.NarRegular False "lower") - linkPair = pair (NAR.NarRegular False "upper") (NAR.NarSymlink "a") - dirPair = - pair - (NAR.NarDirectory [("a", NAR.NarRegular False "upper")]) - (NAR.NarDirectory [("b", NAR.NarRegular False "lower")]) - dirOverFilePair = pair (NAR.NarRegular False "upper") (NAR.NarDirectory [("b", NAR.NarRegular False "lower")]) - fileRefusal dest = "creating file '" <> quotedAsCxx (dest lowerName) <> "': File exists" - dirRefusal dest = "path '" <> T.pack (dest lowerName) <> "' already exists" - dirOverFileRefusal dest = "creating directory '" <> T.pack (dest lowerName) <> "': File exists" - linkRefusal dest = "creating symlink from '" <> T.pack (dest lowerName) <> "' -> 'a': File exists" - upperFileKept dest = (== "upper") <$> BS.readFile (dest upperName) - upperDirKept dest = (== ["a"]) <$> Dir.listDirectory (dest upperName) - narInfoOf raw = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/" <> T.replicate 32 "f" <> "-folding", - NarInfo.niUrl = "nar/folding.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes raw), - NarInfo.niNarSize = fromIntegral (BS.length raw), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - strictly = unpackNarEntry CaseInsensitive - streamed dest tree = do - let raw = NAR.serialise tree - source <- chunkReader [raw] - outcome <- Subst.consumeNarStream CaseInsensitive dest (narInfoOf raw) (CHash.hashBytes raw) source - pure (either (Left . Subst.attemptFailureMessage) (const (Right ())) outcome) - refusedAtWrite label unpack tree refusal kept = runTestM label $ do - let dest = root "out" - Subst.clearStaleDestination dest - result <- unpack dest tree - earlierKept <- kept dest - Subst.clearStaleDestination dest - pure $ - if earlierKept - then assertEqual "unpack outcome" (Left (refusal dest)) result - else Fail ("the earlier entry was overwritten or merged into; unpack returned " <> T.pack (show result)) - forceRemoveIfExists root - createDirectoryIfMissing True root - results <- - sequence - [ refusedAtWrite "strict unpack refuses the later file of a folded pair" strictly filePair fileRefusal upperFileKept, - refusedAtWrite "streaming unpack refuses the later file of a folded pair" streamed filePair fileRefusal upperFileKept, - refusedAtWrite "strict unpack refuses the later directory of a folded pair" strictly dirPair dirRefusal upperDirKept, - refusedAtWrite "streaming unpack refuses the later directory of a folded pair" streamed dirPair dirRefusal upperDirKept, - refusedAtWrite "strict unpack refuses a directory folding onto a file" strictly dirOverFilePair dirOverFileRefusal upperFileKept, - refusedAtWrite "streaming unpack refuses a directory folding onto a file" streamed dirOverFilePair dirOverFileRefusal upperFileKept, - refusedAtWrite "a link folding onto an earlier file is refused at the link" strictly linkPair linkRefusal upperFileKept - ] - forceRemoveIfExists root - pure results - -testStoreDB :: IO [Bool] -testStoreDB = do - putStrLn "store/db" - withTempStoreDB $ \storeDir -> - sequence - [ -- open and close without error - runTestM "db open/close" $ do - db <- openStoreDB storeDir - closeStoreDB db - pure Pass, - -- isValidPath returns False for unknown path - runTestM "db isValidPath false for unknown" $ do - db <- openStoreDB storeDir - result <- isValidPath db (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa1" "unknown") - closeStoreDB db - pure (assertEqual "unknown" False result), - -- register + isValidPath returns True - runTestM "db register + isValid" $ do - db <- openStoreDB storeDir - let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa2" "hello" - reg = PathRegistration sp "sha256:abc" 100 Nothing [] - registerPath db reg - result <- isValidPath db sp - closeStoreDB db - pure (assertEqual "registered" True result), - -- A peer's held write transaction must be waited out, not died - -- on: SQLite's default busy timeout is zero, and registration - -- used to crash with an uncaught ErrorBusy SQLError while a - -- second process was mid-commit. Upstream waits - -- (sqlite3_busy_timeout, one hour); this pins that we do too. - runTestM "db registration waits out a busy peer" $ do - db <- openStoreDB storeDir - let dbPath = unStoreDir storeDir metaDirName dbFileName - peer <- SQL.open dbPath - SQL.execute_ peer "BEGIN IMMEDIATE" - released <- newEmptyMVar - _ <- forkIO $ do - threadDelay 300000 - SQL.execute_ peer "COMMIT" - SQL.close peer - putMVar released () - let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa3" "busywait" - registerPath db (PathRegistration sp "sha256:busy" 10 Nothing []) - takeMVar released - result <- isValidPath db sp - closeStoreDB db - pure (assertEqual "registered after the peer released" True result), - -- register with refs + query - runTestM "db register with refs + query" $ do - db <- openStoreDB storeDir - let ref1 = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "dep1" - ref2 = StorePath "cccccccccccccccccccccccccccccccc" "dep2" - mainSp = StorePath "dddddddddddddddddddddddddddddddd" "mainpkg" - registerPath db (PathRegistration ref1 "sha256:r1" 50 Nothing []) - registerPath db (PathRegistration ref2 "sha256:r2" 60 Nothing []) - registerPath db (PathRegistration mainSp "sha256:m1" 200 Nothing [ref1, ref2]) - refs <- queryReferences db mainSp - closeStoreDB db - let ref1Path = T.pack (storePathToFilePath storeDir ref1) - ref2Path = T.pack (storePathToFilePath storeDir ref2) - hasRef1 = ref1Path `elem` refs - hasRef2 = ref2Path `elem` refs - pure $ - if hasRef1 && hasRef2 - then Pass - else Fail ("expected refs to contain both deps, got: " <> T.pack (show refs)), - -- Re-registration replaces the edge set: the refresh contract - -- covers references too, and a union would over-report into - -- pushed narinfos. - runTestM "db re-register replaces refs" $ do - db <- openStoreDB storeDir - let refA = StorePath "gggggggggggggggggggggggggggggggg" "refresh-a" - refB = StorePath "hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh" "refresh-b" - sp = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" "refresh-main" - registerPaths - db - [ PathRegistration refA "sha256:ra" 10 Nothing [], - PathRegistration refB "sha256:rb" 11 Nothing [], - PathRegistration sp "sha256:rm" 12 Nothing [refA, refB] - ] - registerPath db (PathRegistration sp "sha256:rm" 12 Nothing [refA]) - refs <- queryReferences db sp - closeStoreDB db - let refAPath = T.pack (storePathToFilePath storeDir refA) - refBPath = T.pack (storePathToFilePath storeDir refB) - pure $ - if refAPath `elem` refs && refBPath `notElem` refs - then Pass - else Fail ("expected only refresh-a after re-register, got: " <> T.pack (show refs)), - -- A reference to an unregistered path is a loud error: a silently - -- dropped edge under-reports narinfos and hands a future GC - -- permission to delete a live dependency. - runTestM "db register with unregistered ref throws" $ do - db <- openStoreDB storeDir - let ghost = StorePath "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj" "ghost" - sp = StorePath "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk" "orphan-edge" - outcome <- try (registerPath db (PathRegistration sp "sha256:oe" 13 Nothing [ghost])) - closeStoreDB db - pure $ case (outcome :: Either SomeException ()) of - Left _ -> Pass - Right () -> Fail "expected registration to throw on an unregistered reference", - -- queryDeriver nothing - runTestM "db queryDeriver nothing" $ do - db <- openStoreDB storeDir - let sp = StorePath "cccccccccccccccccccccccccccccccc" "noderiver" - registerPath db (PathRegistration sp "sha256:nd" 80 Nothing []) - result <- queryDeriver db sp - closeStoreDB db - pure (assertEqual "no deriver" Nothing result), - -- queryDeriver just - runTestM "db queryDeriver just" $ do - db <- openStoreDB storeDir - let sp = StorePath "ffffffffffffffffffffffffffffffff" "hasdrv" - registerPath db (PathRegistration sp "sha256:hd" 90 (Just "/nix/store/xxx.drv") []) - result <- queryDeriver db sp - closeStoreDB db - pure (assertEqual "has deriver" (Just "/nix/store/xxx.drv") result), - -- queryPathInfo - runTestM "db queryPathInfo" $ do - db <- openStoreDB storeDir - let sp = StorePath "gggggggggggggggggggggggggggggggg" "infotest" - registerPath db (PathRegistration sp "sha256:info" 150 (Just "/drv") []) - minfo <- queryPathInfo db sp - closeStoreDB db - pure $ case minfo of - Nothing -> Fail "expected PathInfo but got Nothing" - Just info -> - if piNarHash info == "sha256:info" - && piNarSize info == 150 - && piDeriver info == Just "/drv" - then Pass - else Fail ("bad PathInfo: " <> T.pack (show info)), - -- queryPathInfo for unknown returns Nothing - runTestM "db queryPathInfo unknown" $ do - db <- openStoreDB storeDir - minfo <- queryPathInfo db (StorePath "hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh" "nope") - closeStoreDB db - pure (assertEqual "no info" Nothing minfo), - -- double register is idempotent - runTestM "db double register idempotent" $ do - db <- openStoreDB storeDir - let sp = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" "double" - reg = PathRegistration sp "sha256:dup" 120 Nothing [] - registerPath db reg - registerPath db reg - result <- isValidPath db sp - closeStoreDB db - pure (assertEqual "still valid" True result), - -- multi-path reference graph - runTestM "db multi-path reference graph" $ do - db <- openStoreDB storeDir - let spA = StorePath "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj" "a" - spB = StorePath "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk" "b" - spC = StorePath "llllllllllllllllllllllllllllllll" "c" - registerPath db (PathRegistration spA "sha256:a" 10 Nothing []) - registerPath db (PathRegistration spB "sha256:b" 20 Nothing [spA]) - registerPath db (PathRegistration spC "sha256:c" 30 Nothing [spA, spB]) - refsC <- queryReferences db spC - refsA <- queryReferences db spA - closeStoreDB db - let aPath = T.pack (storePathToFilePath storeDir spA) - bPath = T.pack (storePathToFilePath storeDir spB) - pure $ - if length refsC == 2 && aPath `elem` refsC && bPath `elem` refsC && null refsA - then Pass - else Fail ("bad ref graph: c refs=" <> T.pack (show refsC) <> " a refs=" <> T.pack (show refsA)) - ] - --- --------------------------------------------------------------------------- --- Tests: Store Operations + parseStorePath (Phase 2, Batch 2) --- --------------------------------------------------------------------------- - -testParseStorePath :: IO [Bool] -testParseStorePath = do - putStrLn "store/parseStorePath" - let sd = defaultStoreDir - sequence - [ runTest "parse valid store path" $ - assertEqual - "valid" - (Just (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello-2.12")) - (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-2.12"), - runTest "parse missing prefix" $ - assertEqual "no prefix" Nothing (parseStorePath sd "/tmp/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello"), - runTest "parse too short hash" $ - assertEqual "short hash" Nothing (parseStorePath sd "/nix/store/aaa-hello"), - runTest "parse missing dash after hash" $ - assertEqual "no dash" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaahello"), - runTest "parse empty name" $ - assertEqual "empty name" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-"), - runTest "parse windows store path" $ - assertEqual - "windows" - (Just (StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "pkg")) - (parseStorePath windowsStoreDir "C:\\nix\\store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-pkg"), - -- The backslash separator is the form storePathToFilePath actually - -- produces on Windows (what %out% and DB rows look like there). - runTest "parse windows store path with backslash separator" $ - assertEqual - "windows-backslash" - (Just (StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "pkg")) - (parseStorePath windowsStoreDir "C:\\nix\\store\\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-pkg"), - -- Charset gates (upstream's parse-boundary checks): the hash slot - -- accepts only nix-base32 (no e o u t), and the name only - -- [A-Za-z0-9+._?=-] - parsed text can come from a cache, and an - -- unchecked component would later become a filesystem path. - runTest "parse rejects non-base32 hash" $ - assertEqual "e-hash" Nothing (parseStorePath sd ("/nix/store/" <> T.replicate 32 "e" <> "-hello")), - runTest "parse rejects traversal text in hash slot" $ - assertEqual "traversal-hash" Nothing (parseStorePath sd ("/nix/store/" <> T.replicate 16 ".\\" <> "-x")), - runTest "parse rejects separator in name" $ - assertEqual "sep-name" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-he/llo"), - runTest "parse rejects dot-dot name" $ - assertEqual "dotdot-name" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-.."), - runTest "parse rejects overlong name" $ - assertEqual "overlong-name" Nothing (parseStorePath sd ("/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-" <> T.replicate 212 "x")), - runTest "parse accepts the full name charset" $ - assertEqual - "name-specials" - (Just (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "gcc-13.2.0_pre+x?=")) - (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-gcc-13.2.0_pre+x?="), - -- The first dash-separated component of a name may not be . or .. - -- (upstream checkName): the traversal names' .- / ..- prefixed forms - -- are rejected while other dot-leading names stay valid. - runTest "parse rejects a .- first component" $ - assertEqual "dot-dash" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-.-cfg"), - runTest "parse rejects a ..- first component" $ - assertEqual "dotdot-dash" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-..-cfg"), - runTest "parse accepts a dot-leading name" $ - assertEqual - "dot-leading" - (Just (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ".config-1.0")) - (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-.config-1.0") - ] - --- --------------------------------------------------------------------------- --- Tests: Push (pure narinfo construction + closure computation) --- --------------------------------------------------------------------------- - -testPushPure :: IO [Bool] -testPushPure = do - putStrLn "push/narinfo" - let hashA = T.replicate 32 "a" - hashB = T.replicate 32 "b" - spA = StorePath hashA "hello-1.0" - spB = StorePath hashB "dep-2.0" - narHash = "sha256:0123abcdef" - narBytes = BS.replicate 1234 0x6e - artifactNone = mkPushArtifact PushNone narHash narBytes - artifactZstd = mkPushArtifact PushZstd narHash narBytes - -- References deliberately unsorted; deriver present. - ni = mkNarInfo artifactNone spA [spB, spA] (Just spB) - niZstd = mkNarInfo artifactZstd spA [spB, spA] (Just spB) - sequence - [ runTest "narinfo StorePath is canonical /nix/store" $ - assertEqual "StorePath" ("/nix/store/" <> hashA <> "-hello-1.0") (NarInfo.niStorePath ni), - runTest "narinfo URL is nar/.nar" $ - assertEqual "URL" "nar/0123abcdef.nar" (NarInfo.niUrl ni), - runTest "compression none mirrors NAR fields into file fields" $ - assertEqual - "file fields" - ("none", Just (NarInfo.niNarHash ni), Just (NarInfo.niNarSize ni)) - (NarInfo.niCompression ni, NarInfo.niFileHash ni, NarInfo.niFileSize ni), - runTest "narinfo sizes carry through" $ - assertEqual "NarSize" 1234 (NarInfo.niNarSize ni), - -- The zstd artifact: file fields describe the compressed object, - -- named by its own file hash, while the NAR fields stay the - -- archive's - and the substituter's strict decoder round-trips - -- the bytes under the declared NarSize bound. - runTest "zstd artifact declares the compressed object" $ - assertEqual - "zstd fields" - ("zstd", Just (paFileHash artifactZstd), Just (fromIntegral (paFileSize artifactZstd)), 1234) - (NarInfo.niCompression niZstd, NarInfo.niFileHash niZstd, NarInfo.niFileSize niZstd, NarInfo.niNarSize niZstd), - -- Ground truth, not field copying: the file fields must equal - -- independent computation over the artifact's actual bytes, and - -- must NOT collapse into the NAR fields (the copy-paste hazard - -- for a compressible input like this one). - runTest "zstd file fields are computed from the compressed bytes" $ - let independentHash = CHash.formatNixHash (CHash.hashBytes (paBytes artifactZstd)) - in if paFileHash artifactZstd == independentHash - && paFileSize artifactZstd == BS.length (paBytes artifactZstd) - && paFileHash artifactZstd /= narHash - && paFileSize artifactZstd /= BS.length narBytes - then Pass - else Fail "zstd file fields do not match the compressed bytes", - runTest "none artifact IS the NAR" $ - if paBytes artifactNone == narBytes - && paFileHash artifactNone == narHash - && paFileSize artifactNone == BS.length narBytes - then Pass - else Fail "none artifact diverges from its NAR", - runTest "zstd object is named by its independently computed file hash" $ - assertEqual - "zstd URL" - ("nar/" <> stripHashPrefix (CHash.formatNixHash (CHash.hashBytes (paBytes artifactZstd))) <> ".nar.zst") - (NarInfo.niUrl niZstd), - -- mkNarInfo cannot be handed NAR fields that disagree with the - -- artifact: they now come from the artifact itself. - runTest "narinfo NAR fields come from the artifact" $ - assertEqual - "NAR fields" - (narHash, toInteger (BS.length narBytes)) - (NarInfo.niNarHash niZstd, NarInfo.niNarSize niZstd), - runTestM "zstd artifact round-trips through the substituter decoder" $ do - out <- Subst.decompressNar 1234 "zstd" (paBytes artifactZstd) - pure (assertEqual "push-substitute roundtrip" (Right narBytes) out), - -- The CLI vocabulary is the wire vocabulary, parsed in one place. - runTest "parsePushCompression accepts the register and rejects by name" $ - case (parsePushCompression "none", parsePushCompression "zstd", parsePushCompression "brotli") of - (Right PushNone, Right PushZstd, Left err) - | "none, zstd" `T.isInfixOf` err -> Pass - other -> Fail ("unexpected parse outcomes: " <> T.pack (show other)), - runTest "references are sorted basenames" $ - assertEqual - "References" - [hashA <> "-hello-1.0", hashB <> "-dep-2.0"] - (NarInfo.niReferences ni), - runTest "deriver renders as a basename" $ - assertEqual "Deriver" (Just (hashB <> "-dep-2.0")) (NarInfo.niDeriver ni), - runTest "no client-side signatures" $ - assertEqual "Sigs" ([] :: [Text]) (NarInfo.niSigs ni), - -- The first main run of the cache job pushed a store's first valid - -- path alphabetically, a .drv, and the cache refused its narinfo: - -- a store registers recipes as valid paths, a cache serves outputs. - runTest "outputPathsOnly drops derivations and keeps everything else" $ - assertEqual - "outputs" - ["hello", "hello.drv.tar", "src"] - (map spName (outputPathsOnly [StorePath (T.replicate 32 "a") "hello", StorePath (T.replicate 32 "b") "hello.drv", StorePath (T.replicate 32 "c") "hello.drv.tar", StorePath (T.replicate 32 "d") "src"])), - runTest "isDerivationPath is the .drv suffix on the name, not the hash" $ - assertEqual "drv" [True, False, False] (map isDerivationPath [StorePath (T.replicate 32 "a") "x.drv", StorePath (T.replicate 32 "b") "x", StorePath (T.replicate 32 "c") "drv"]), - runTest "planMissing keeps only uncached paths" $ - assertEqual - "missing" - [hashB] - (map spHash (planMissing (Set.singleton hashA) [spA, spB])), - runTest "stripHashPrefix drops the algo tag" $ - assertEqual "tagged" "deadbeef" (stripHashPrefix "sha256:deadbeef"), - runTest "stripHashPrefix tolerates a bare digest" $ - assertEqual "bare" "deadbeef" (stripHashPrefix "deadbeef"), - runTest "storePathBasename joins hash and name" $ - assertEqual "basename" (hashA <> "-hello-1.0") (storePathBasename spA), - runTest "narFileName appends .nar" $ - assertEqual "file" "0123abcdef.nar" (narFileName narHash), - -- checkRecordedNarHash: the pre-upload integrity gate - runTest "push gate accepts a registered matching path" $ - assertEqual - "gate ok" - (Right ()) - (checkRecordedNarHash (Just (pathInfoFor narHash)) narHash spA), - runTest "push gate refuses an unregistered path" $ - case checkRecordedNarHash Nothing narHash spA of - Left err - | "not registered" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right () -> Fail "unregistered path must not be publishable", - runTest "push gate refuses a changed-on-disk path" $ - case checkRecordedNarHash (Just (pathInfoFor "sha256:other")) narHash spA of - Left err - | "DB recorded" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right () -> Fail "hash mismatch must not be publishable", - -- narHashMatches decodes both spellings before comparing. Today - -- parseNixHash reads only the sha256:nix-base32 spelling, so a - -- base16-recorded digest (both literals spell the empty-string - -- sha256) falls back to text equality and refuses - the safe - -- direction. When the parser learns more spellings (foreign - -- caches), this pin flips and the gate widens with it. - runTest "push gate pins the accepted hash spellings" $ - if narHashMatches - "sha256:e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" - "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" - then Fail "base16 spelling unexpectedly matched - widen this pin" - else Pass, - runTest "push gate still refuses different digests" $ - if narHashMatches - "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" - (Hash.formatNixHash (Hash.hashBytes "different")) - then Fail "distinct digests must not match" - else Pass - ] - where - pathInfoFor recordedHash = - PathInfo - { piPath = "/nix/store/" <> T.replicate 32 "a" <> "-hello-1.0", - piNarHash = recordedHash, - piNarSize = 1234, - piDeriver = Nothing, - piRegTime = 0 - } - --- | Closure computation against a real (temp) store database. -testPushClosureIO :: IO [Bool] -testPushClosureIO = do - putStrLn "push/closure" - withTempStore $ \store -> do - let spTop = StorePath (T.replicate 32 "1") "top" - spMid = StorePath (T.replicate 32 "2") "mid" - spLeaf = StorePath (T.replicate 32 "3") "leaf" - regFor sp refs = - PathRegistration - { prPath = sp, - prNarHash = "sha256:" <> T.replicate 52 "0", - prNarSize = 1, - prDeriver = Nothing, - prReferences = refs - } - registerPaths (stDB store) [regFor spTop [spMid], regFor spMid [spLeaf], regFor spLeaf []] - fromTop <- computeClosure store [spTop] - fromBoth <- computeClosure store [spTop, spLeaf] - sequence - [ runTest "closure walks transitive references" $ - assertRight "fromTop" fromTop $ \closure -> - assertEqual - "hashes" - (Set.fromList (map spHash [spTop, spMid, spLeaf])) - (Set.fromList (map spHash closure)), - runTest "closure deduplicates across roots" $ - assertRight "fromBoth" fromBoth $ \closure -> - assertEqual "count" (3 :: Int) (length closure), - -- loadApiKeyFile: keys copied through Windows editors arrive with - -- a BOM and CRLF; skipping the normalization turns every push - -- into an auth rejection with no visible cause. - runTestM "loadApiKeyFile strips BOM and CRLF" $ do - tmpBase <- getTemporaryDirectory - let keyFile = tmpBase "nova-nix-test-api-key" - BS.writeFile keyFile (BS.pack [0xEF, 0xBB, 0xBF] <> "the-secret-key\r\n") - loaded <- loadApiKeyFile keyFile - Dir.removeFile keyFile - pure (assertEqual "normalized key" (Right "the-secret-key") loaded), - runTestM "loadApiKeyFile rejects an effectively-empty key file" $ do - tmpBase <- getTemporaryDirectory - let keyFile = tmpBase "nova-nix-test-api-key-empty" - BS.writeFile keyFile (BS.pack [0xEF, 0xBB, 0xBF] <> " \r\n") - loaded <- loadApiKeyFile keyFile - Dir.removeFile keyFile - pure $ case loaded of - Left err | "empty" `T.isInfixOf` err -> Pass - other -> Fail ("expected empty-key rejection, got: " <> T.pack (show other)), - runTestM "loadApiKeyFile reports a missing file" $ do - tmpBase <- getTemporaryDirectory - loaded <- loadApiKeyFile (tmpBase "nova-nix-test-no-such-key-file") - pure $ case loaded of - Left err | "cannot read key file" `T.isInfixOf` err -> Pass - other -> Fail ("expected read error, got: " <> T.pack (show other)) - ] - --- | The case sensitivity of the suite's temp directory, so a test --- materializing a NAR there keys sibling names the way a store on that --- volume would. -tempCaseSensitivity :: IO CaseSensitivity -tempCaseSensitivity = getTemporaryDirectory >>= probeCaseSensitivity - --- | Helper: create a fresh temp store for IO tests. -withTempStore :: (Store -> IO [Bool]) -> IO [Bool] -withTempStore action = do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-store-ops" - forceRemoveIfExists tmpStore - createDirectoryIfMissing True tmpStore - store <- openStore (StoreDir tmpStore) - results <- action store - closeStore store - forceRemoveIfExists tmpStore - pure results - --- | Recursively restore writable permissions then remove. --- Needed because addToStore/setReadOnly makes paths read-only. -forceRemoveIfExists :: FilePath -> IO () -forceRemoveIfExists path = do - exists <- doesDirectoryExist path - when exists $ do - restoreWritable path - removeDirectoryRecursive path - -restoreWritable :: FilePath -> IO () -restoreWritable path = do - isDir <- doesDirectoryExist path - when isDir $ do - perms <- getPermissions path - Dir.setPermissions path (Dir.setOwnerWritable True perms) - entries <- Dir.listDirectory path - mapM_ (restoreWritable . (path )) entries - isFile <- Dir.doesFileExist path - when isFile $ do - perms <- getPermissions path - Dir.setPermissions path (Dir.setOwnerWritable True perms) - --- | Step 1 of the Windows-stdenv ladder: prove the Builder can run a --- trivial derivation end-to-end natively - a recipe that writes to @$out@, --- with the output landing in the store. No stdenv, no dependencies: just --- the raw build path (process spawn, output capture, addToStore), --- exercised on the host platform (@cmd.exe@ on Windows, @\/bin\/sh@ elsewhere). -testTrivialBuildIO :: IO [Bool] -testTrivialBuildIO = do - putStrLn "builder/trivial-native-build" - withTempStore $ \store -> do - let storeDir = stDir store - outPath = StorePath (T.replicate 31 "0" <> "1") "trivial" - (builder, args) - | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo hi>%out%"]) - | otherwise = ("/bin/sh", ["-c", "echo hi > $out"]) - drv = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = outPath, - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = builder, - drvArgs = args, - drvEnv = Map.empty - } - buildTmp <- ( "nova-nix-test-trivial-build-tmp") <$> getTemporaryDirectory - forceRemoveIfExists buildTmp - createDirectoryIfMissing True buildTmp - let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} - result <- buildDerivation config store drv - forceRemoveIfExists buildTmp - case result of - BuildSuccess sp -> do - let outFile = storePathToFilePath storeDir sp - landed <- Dir.doesFileExist outFile - content <- if landed then TIO.readFile outFile else pure "" - narInfo <- queryPathInfo (stDB store) sp - let realNarHash = case narInfo of - Just info -> - piNarSize info > 0 - && T.isPrefixOf "sha256:" (piNarHash info) - && T.any (/= '0') (T.drop 7 (piNarHash info)) - Nothing -> False - sequence - [ runTest "trivial build succeeds" Pass, - runTest "trivial build output landed in store" $ - if landed then Pass else Fail ("missing output file: " <> T.pack outFile), - runTest "trivial build actually ran the command" $ - if "hi" `T.isInfixOf` content - then Pass - else Fail ("unexpected output content: " <> T.pack (show content)), - runTest "trivial build records a real NAR hash + size" $ - if realNarHash - then Pass - else Fail ("NAR hash/size not real: " <> T.pack (show narInfo)) - ] - BuildFailure msg code -> - sequence - [ runTest "trivial build succeeds" $ - Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) - ] - --- | The builder hands every build a fixed SOURCE_DATE_EPOCH (1980-01-01), --- the reproducible-builds.org convention that determinism-aware tools --- (ld's PE timestamp, gcc's __DATE__) honor. Proven behaviorally: a build --- that echoes the variable into $out must see the pinned value. -testSourceDateEpochIO :: IO [Bool] -testSourceDateEpochIO = do - putStrLn "builder/source-date-epoch" - withTempStore $ \store -> do - let storeDir = stDir store - outPath = StorePath (T.replicate 31 "0" <> "5") "sde-probe" - (builder, args) - | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo %SOURCE_DATE_EPOCH%>%out%"]) - | otherwise = ("/bin/sh", ["-c", "echo $SOURCE_DATE_EPOCH > $out"]) - drv = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = outPath, - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = builder, - drvArgs = args, - drvEnv = Map.empty - } - buildTmp <- ( "nova-nix-test-sde-build-tmp") <$> getTemporaryDirectory - forceRemoveIfExists buildTmp - createDirectoryIfMissing True buildTmp - let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} - result <- buildDerivation config store drv - forceRemoveIfExists buildTmp - case result of - BuildFailure msg code -> - sequence - [ runTest "SOURCE_DATE_EPOCH build succeeds" $ - Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) - ] - BuildSuccess sp -> do - content <- TIO.readFile (storePathToFilePath storeDir sp) - sequence - [ runTest "builder pins SOURCE_DATE_EPOCH to 1980-01-01" $ - if "315532800" `T.isInfixOf` content - then Pass - else Fail ("unexpected content: " <> T.pack (show content)) - ] - --- | The child's environment is the build environment plus the ambient --- allowlist, nothing else. Proven behaviorally at both ends: an ambient --- canary set in the test process must not reach a build, and the four --- temp-directory names must all point at the same build-owned directory. -testScrubbedBuildEnvIO :: IO [Bool] -testScrubbedBuildEnvIO = do - putStrLn "builder/scrubbed-env" - withTempStore $ \store -> do - let storeDir = stDir store - probeDrv name suffix (builder, args) = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = StorePath (T.replicate 31 "0" <> suffix) name, - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = builder, - drvArgs = args, - drvEnv = Map.empty - } - canaryDrv = - probeDrv "env-canary" "6" $ - if SI.os == "mingw32" - then ("cmd.exe", ["/c", "echo %NOVA_NIX_TEST_CANARY%>%out%"]) - else ("/bin/sh", ["-c", "echo \"${NOVA_NIX_TEST_CANARY-scrubbed}\" > $out"]) - quartetDrv = - probeDrv "temp-quartet" "7" $ - if SI.os == "mingw32" - then ("cmd.exe", ["/c", "if \"%TMPDIR%\"==\"%TEMPDIR%\" if \"%TMPDIR%\"==\"%TMP%\" if \"%TMPDIR%\"==\"%TEMP%\" if not \"%TMPDIR%\"==\"\" echo quartet-ok>%out%"]) - else ("/bin/sh", ["-c", "[ -n \"$TMPDIR\" ] && [ \"$TMPDIR\" = \"$TEMPDIR\" ] && [ \"$TMPDIR\" = \"$TMP\" ] && [ \"$TMPDIR\" = \"$TEMP\" ] && echo quartet-ok > $out"]) - buildTmp <- ( "nova-nix-test-scrub-build-tmp") <$> getTemporaryDirectory - forceRemoveIfExists buildTmp - createDirectoryIfMissing True buildTmp - let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} - setEnv "NOVA_NIX_TEST_CANARY" "ambient-leak" - canaryResult <- buildDerivation config store canaryDrv - unsetEnv "NOVA_NIX_TEST_CANARY" - quartetResult <- buildDerivation config store quartetDrv - forceRemoveIfExists buildTmp - sequence - [ runTestM "an undeclared ambient variable does not reach a build" $ - case canaryResult of - BuildFailure msg code -> pure (Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg)) - BuildSuccess sp -> do - content <- TIO.readFile (storePathToFilePath storeDir sp) - pure $ - if "ambient-leak" `T.isInfixOf` content - then Fail ("ambient canary leaked into the build: " <> T.pack (show content)) - else Pass, - runTestM "all four temp names point at the build directory" $ - case quartetResult of - BuildFailure msg code -> pure (Fail ("quartet disagreed or build failed (exit " <> T.pack (show code) <> "): " <> msg)) - BuildSuccess sp -> do - content <- TIO.readFile (storePathToFilePath storeDir sp) - pure $ - if "quartet-ok" `T.isInfixOf` content - then Pass - else Fail ("unexpected content: " <> T.pack (show content)) - ] - --- | Zstd compression level for test archives (zstd's own default). -testZstdCompressionLevel :: Int -testZstdCompressionLevel = 3 - --- | Build a @.tar.zst@ archive from tar entries, MSYS2-package style. -compressArchive :: [TarEntry.Entry] -> BL.ByteString -compressArchive = ZstdL.compress testZstdCompressionLevel . Tar.write - --- | Test-setup helpers: the paths and link targets below are short literals, --- so encoding them cannot fail; 'error' marks setup bugs, not test failures. -tarPathOrDie :: Bool -> FilePath -> TarEntry.TarPath -tarPathOrDie isDir p = - either (error . ("test tar path: " ++)) id (TarEntry.toTarPath isDir p) - -linkOrDie :: FilePath -> TarEntry.LinkTarget -linkOrDie t = - fromMaybe (error ("test link target: " ++ t)) (TarEntry.toLinkTarget t) - -tarDir :: FilePath -> TarEntry.Entry -tarDir p = TarEntry.directoryEntry (tarPathOrDie True p) - -tarFile :: FilePath -> BL.ByteString -> TarEntry.Entry -tarFile p = TarEntry.fileEntry (tarPathOrDie False p) - -tarExecFile :: FilePath -> BL.ByteString -> TarEntry.Entry -tarExecFile p content = (tarFile p content) {TarEntry.entryPermissions = 0o755} - -tarHardLink :: FilePath -> FilePath -> TarEntry.Entry -tarHardLink p target = - TarEntry.simpleEntry (tarPathOrDie False p) (Tar.HardLink (linkOrDie target)) - -tarSymLink :: FilePath -> FilePath -> TarEntry.Entry -tarSymLink p target = - TarEntry.simpleEntry (tarPathOrDie False p) (Tar.SymbolicLink (linkOrDie target)) - --- | Step 3 of the ladder: @builtin:unpack@, the stage-0 seed extractor. --- Two zstd-compressed tar archives sharing a top-level prefix (the MSYS2 --- @mingw64\/@ shape) are extracted into ONE output: regular files, an --- executable, a hardlink and a relative symlink (both materialized as --- copies), with pacman metadata (@.PKGINFO@\/@.MTREE@) skipped. A second --- build proves cross-archive file collisions fail loudly, and further builds --- that a parent-climbing (..) entry and drive-rooted file, symlink, and --- hardlink paths are all rejected. -testUnpackBuildIO :: IO [Bool] -testUnpackBuildIO = do - putStrLn "builder/unpack-seed-archives" - tmpBase0 <- getTemporaryDirectory - if ' ' `elem` tmpBase0 - then do - -- The srcs env is space-separated by the derivation contract (store - -- paths never contain spaces), but these test archives live under - -- TEMP: a spaced TEMP would fragment the paths and fail spuriously. - putStrLn " SKIP unpack archive tests need a space-free TEMP dir" - pure [] - else withTempStore $ \store -> do - let storeDir = stDir store - -- Archives live in the temp store under store-path names: the srcs - -- env is store paths by contract, and runBuiltinUnpack insists on - -- that now (#101) - each entry is parsed and rendered through the - -- build's store dir, which for these builds is the temp store. - let archiveFile name = storePathToFilePath storeDir (StorePath (T.replicate 32 "0") name) - archiveTools = archiveFile "pkg-tools.tar.zst" - archiveData = archiveFile "pkg-data.tar.zst" - archiveCollide = archiveFile "pkg-collide.tar.zst" - archiveEscape = archiveFile "pkg-escape.tar.zst" - archiveRootFile = archiveFile "pkg-root-file.tar.zst" - archiveEscapeSymlink = archiveFile "pkg-escape-symlink.tar.zst" - archiveEscapeHardlink = archiveFile "pkg-escape-hardlink.tar.zst" - archiveDirLink = archiveFile "pkg-dirlink.tar.zst" - archiveDirLinkBase = archiveFile "pkg-dirlink-base.tar.zst" - archiveDirLinkCollide = archiveFile "pkg-dirlink-collide.tar.zst" - archiveHardLinkCollide = archiveFile "pkg-hardlink-collide.tar.zst" - archiveManyEntries = archiveFile "pkg-many-entries.tar.zst" - archiveBigFile = archiveFile "pkg-big-file.tar.zst" - archiveAmplify = archiveFile "pkg-amplify.tar.zst" - BL.writeFile archiveTools $ - compressArchive - [ tarDir "pkg", - tarDir "pkg/bin", - tarExecFile "pkg/bin/tool.exe" "tool-payload", - tarHardLink "pkg/bin/tool-link.exe" "pkg/bin/tool.exe", - tarSymLink "pkg/bin/sh.exe" "tool.exe", - tarFile ".PKGINFO" "pkgname = tools" - ] - BL.writeFile archiveData $ - compressArchive - [ tarDir "pkg", - tarDir "pkg/share", - tarFile "pkg/share/data.txt" "shared-data", - tarFile ".MTREE" "mtree-bytes" - ] - BL.writeFile archiveCollide $ - compressArchive [tarFile "pkg/bin/tool.exe" "conflicting"] - BL.writeFile archiveEscape $ - compressArchive [tarFile "../evil.txt" "escape"] - -- A leading '/' entry: rooted at the current drive. tar stores paths with - -- '/', so this is the on-disk form even of a Windows-native "\..." name. - BL.writeFile archiveRootFile $ - compressArchive [tarFile "/planted-abs.txt" "rooted-file"] - -- Escaping link targets: '..' climbs above the archive root. Unlike a - -- rooted ('/') target, this builds portably - tar's toLinkTarget accepts a - -- relative path on every host - so the real unpacker is exercised end to end. - BL.writeFile archiveEscapeSymlink $ - compressArchive [tarSymLink "sneaky-link.txt" "../escape-link-target.txt"] - BL.writeFile archiveEscapeHardlink $ - compressArchive [tarHardLink "sneaky-hardlink.txt" "../escape-hardlink-target.txt"] - -- A directory symlink entry with a fresh destination: materialized - -- by copying its target tree. - BL.writeFile archiveDirLink $ - compressArchive - [ tarDir "realdir", - tarFile "realdir/g.txt" "dir-link-payload", - tarSymLink "dirlink" "realdir" - ] - -- Collisions: the first archive already provides pkg/, and a later - -- archive's directory symlink/hardlink also lands at pkg. The - -- tree copy must hit the same collision guard as a regular entry, - -- not silently merge - the merged result would depend on entry - -- order. - BL.writeFile archiveDirLinkBase $ - compressArchive [tarDir "pkg", tarFile "pkg/original.txt" "original"] - BL.writeFile archiveDirLinkCollide $ - compressArchive - [ tarDir "smuggle", - tarFile "smuggle/extra.txt" "smuggled", - tarSymLink "pkg" "smuggle" - ] - BL.writeFile archiveHardLinkCollide $ - compressArchive - [ tarDir "smuggle", - tarFile "smuggle/extra.txt" "smuggled", - tarHardLink "pkg" "smuggle" - ] - -- Budget probes, built against tiny caps injected via BuildConfig. - BL.writeFile archiveManyEntries $ - compressArchive [tarFile ("e" <> show i <> ".txt") "x" | i <- [1 :: Int .. 6]] - BL.writeFile archiveBigFile $ - compressArchive [tarFile "big.bin" (BL.replicate 100 55)] - -- Two directory symlinks each re-copy the 40-byte payload: the - -- copies must charge the budget like first-class content. - BL.writeFile archiveAmplify $ - compressArchive - [ tarDir "base", - tarFile "base/blob.bin" (BL.replicate 40 55), - tarSymLink "dup1" "base", - tarSymLink "dup2" "base" - ] - let -- srcs carries the canonical /nix/store spelling, as eval writes - -- it; the physical archives live under the temp store dir. - canonicalSrc file = case parseStorePath storeDir (T.pack file) of - Just sp -> storePathToText defaultStoreDir sp - Nothing -> T.pack file - mkUnpackDrv outP srcFiles = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = outP, - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = builtinUnpackBuilder, - drvArgs = [], - drvEnv = - Map.fromList - [(envSrcs, TE.encodeUtf8 (T.intercalate " " (map canonicalSrc srcFiles)))] - } - seedOut = StorePath (T.replicate 31 "0" <> "2") "unpack-seed" - collideOut = StorePath (T.replicate 31 "0" <> "3") "unpack-collide" - escapeOut = StorePath (T.replicate 31 "0" <> "4") "unpack-escape" - rootFileOut = StorePath (T.replicate 31 "0" <> "5") "unpack-root-file" - escapeSymlinkOut = StorePath (T.replicate 31 "0" <> "6") "unpack-escape-symlink" - escapeHardlinkOut = StorePath (T.replicate 31 "0" <> "7") "unpack-escape-hardlink" - dirLinkOut = StorePath (T.replicate 31 "0" <> "8") "unpack-dirlink" - dirLinkCollideOut = StorePath (T.replicate 31 "0" <> "9") "unpack-dirlink-collide" - hardLinkCollideOut = StorePath (T.replicate 30 "0" <> "10") "unpack-hardlink-collide" - manyEntriesOut = StorePath (T.replicate 30 "0" <> "11") "unpack-entry-budget" - bigFileOut = StorePath (T.replicate 30 "0" <> "12") "unpack-size-budget" - amplifyOut = StorePath (T.replicate 30 "0" <> "13") "unpack-amplify-budget" - buildTmp <- ( "nova-nix-test-unpack-build-tmp") <$> getTemporaryDirectory - forceRemoveIfExists buildTmp - createDirectoryIfMissing True buildTmp - let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} - seedResult <- buildDerivation config store (mkUnpackDrv seedOut [archiveTools, archiveData]) - collideResult <- buildDerivation config store (mkUnpackDrv collideOut [archiveTools, archiveCollide]) - escapeResult <- buildDerivation config store (mkUnpackDrv escapeOut [archiveEscape]) - rootFileResult <- buildDerivation config store (mkUnpackDrv rootFileOut [archiveRootFile]) - escapeSymlinkResult <- buildDerivation config store (mkUnpackDrv escapeSymlinkOut [archiveEscapeSymlink]) - escapeHardlinkResult <- buildDerivation config store (mkUnpackDrv escapeHardlinkOut [archiveEscapeHardlink]) - dirLinkResult <- buildDerivation config store (mkUnpackDrv dirLinkOut [archiveDirLink]) - dirLinkCollideResult <- buildDerivation config store (mkUnpackDrv dirLinkCollideOut [archiveDirLinkBase, archiveDirLinkCollide]) - hardLinkCollideResult <- buildDerivation config store (mkUnpackDrv hardLinkCollideOut [archiveDirLinkBase, archiveHardLinkCollide]) - let tinyBudget bytes entries = - config {bcUnpackLimits = UnpackLimits {ulMaxBytes = bytes, ulMaxEntries = entries}} - manyEntriesResult <- buildDerivation (tinyBudget 1000000 4) store (mkUnpackDrv manyEntriesOut [archiveManyEntries]) - bigFileResult <- buildDerivation (tinyBudget 64 1000) store (mkUnpackDrv bigFileOut [archiveBigFile]) - amplifyResult <- buildDerivation (tinyBudget 100 1000) store (mkUnpackDrv amplifyOut [archiveAmplify]) - forceRemoveIfExists buildTmp - seedChecks <- case seedResult of - BuildFailure msg code -> - sequence - [ runTest "unpack seed build succeeds" $ - Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) - ] - BuildSuccess sp -> do - let outRoot = storePathToFilePath storeDir sp - readOut rel = do - let path = outRoot rel - exists <- Dir.doesFileExist path - if exists then Just <$> TIO.readFile path else pure Nothing - tool <- readOut ("pkg" "bin" "tool.exe") - toolLink <- readOut ("pkg" "bin" "tool-link.exe") - shLink <- readOut ("pkg" "bin" "sh.exe") - dataFile <- readOut ("pkg" "share" "data.txt") - pkgInfo <- Dir.doesFileExist (outRoot ".PKGINFO") - mtree <- Dir.doesFileExist (outRoot ".MTREE") - execBitOk <- - if SI.os == "mingw32" - then pure True -- NTFS has no exec bit; PATHEXT decides - else Dir.executable <$> getPermissions (outRoot "pkg" "bin" "tool.exe") - narInfo <- queryPathInfo (stDB store) sp - let realNarHash = case narInfo of - Just info -> - piNarSize info > 0 && T.isPrefixOf "sha256:" (piNarHash info) - Nothing -> False - sequence - [ runTest "unpack seed build succeeds" Pass, - runTest "unpack: file extracted with content" $ - assertEqual "tool.exe" (Just "tool-payload") tool, - runTest "unpack: hardlink materialized as copy" $ - assertEqual "tool-link.exe" (Just "tool-payload") toolLink, - runTest "unpack: relative symlink materialized as copy" $ - assertEqual "sh.exe" (Just "tool-payload") shLink, - runTest "unpack: second archive merged into shared prefix" $ - assertEqual "data.txt" (Just "shared-data") dataFile, - runTest "unpack: pacman metadata skipped" $ - if pkgInfo || mtree - then Fail ".PKGINFO/.MTREE leaked into the output" - else Pass, - runTest "unpack: executable bit materialized (unix)" $ - if execBitOk then Pass else Fail "tool.exe not executable", - runTest "unpack: real NAR hash registered" $ - if realNarHash then Pass else Fail (T.pack (show narInfo)) - ] - collideChecks <- - sequence - [ runTest "unpack: cross-archive file collision fails loudly" $ - case collideResult of - BuildFailure msg _ - | "file collision" `T.isInfixOf` msg -> Pass - | otherwise -> Fail ("wrong failure: " <> msg) - BuildSuccess _ -> Fail "collision build unexpectedly succeeded" - ] - escapeChecks <- - sequence - [ runTest "unpack: path traversal rejected" $ - case escapeResult of - BuildFailure msg _ - | "escapes archive root" `T.isInfixOf` msg -> Pass - | otherwise -> Fail ("wrong failure: " <> msg) - BuildSuccess _ -> Fail "escape build unexpectedly succeeded" - ] - let rejectedWith needle res = case res of - BuildFailure msg _ - | needle `T.isInfixOf` msg -> Pass - | otherwise -> Fail ("wrong failure: " <> msg) - BuildSuccess _ -> Fail "malicious entry unexpectedly built" - -- Integration: the real unpacker rejects a rooted entry path and an - -- escaping ('..') symlink/hardlink target, end to end. - maliciousChecks <- - sequence - [ runTest "unpack: rooted file entry rejected" $ - rejectedWith "planted-abs.txt" rootFileResult, - runTest "unpack: escaping symlink target rejected" $ - rejectedWith "escape-link-target.txt" escapeSymlinkResult, - runTest "unpack: escaping hardlink target rejected" $ - rejectedWith "escape-hardlink-target.txt" escapeHardlinkResult - ] - dirLinkChecks <- case dirLinkResult of - BuildFailure msg code -> - sequence - [ runTest "unpack: directory symlink materialized as copied tree" $ - Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) - ] - BuildSuccess sp -> do - let outRoot = storePathToFilePath storeDir sp - linkedFile = outRoot "dirlink" "g.txt" - linkedExists <- Dir.doesFileExist linkedFile - outcome <- - if not linkedExists - then pure (Fail "dirlink/g.txt missing from the output") - else do - linked <- TIO.readFile linkedFile - -- The copy contract: a real directory, never a link (a - -- store link would need privilege and be machine-dependent). - isLink <- Dir.pathIsSymbolicLink (outRoot "dirlink") - pure $ - if linked == "dir-link-payload" && not isLink - then Pass - else Fail ("content=" <> linked <> " isLink=" <> T.pack (show isLink)) - sequence [runTest "unpack: directory symlink materialized as copied tree" outcome] - collisionGuardChecks <- - sequence - [ runTest "unpack: directory symlink onto existing content fails loudly" $ - rejectedWith "file collision" dirLinkCollideResult, - runTest "unpack: directory hardlink onto existing content fails loudly" $ - rejectedWith "file collision" hardLinkCollideResult - ] - budgetChecks <- - sequence - [ runTest "unpack: entry budget breach fails loudly" $ - rejectedWith "entry budget" manyEntriesResult, - runTest "unpack: size budget breach fails loudly" $ - rejectedWith "size budget" bigFileResult, - runTest "unpack: directory link copies charge the budget" $ - rejectedWith "size budget" amplifyResult - ] - -- Unit: the rooted (drive-relative) case is the Blocker-4 Windows vuln. - -- tar's toLinkTarget refuses an absolute payload on POSIX, so exercise the - -- guard predicate directly - portable and exact on every host. - guardChecks <- - sequence - [ runTest "unpack guard: rooted entry path rejected" $ - assertLeft "rooted entry" (entryComponents "/planted-abs.txt"), - runTest "unpack guard: rooted symlink target rejected" $ - assertLeft "rooted symlink" (resolveLinkTarget [] "/planted-link-target.txt"), - runTest "unpack guard: rooted hardlink target rejected" $ - assertLeft "rooted hardlink" (entryComponents "/planted-hardlink-target.txt") - ] - pure (seedChecks ++ collideChecks ++ escapeChecks ++ maliciousChecks ++ dirLinkChecks ++ collisionGuardChecks ++ budgetChecks ++ guardChecks) - --- | Step 2 of the ladder: a dependency-aware build end-to-end. A root --- derivation depends on a leaf; both @.drv@ files are pre-written to the store --- (as the build driver's closure-writing does), and 'buildWithDeps' must read --- the closure, topologically order it, build the leaf first, then the root - --- whose 'validateInputs' requires the leaf's realized output to be valid. --- --- This is the regression guard for the input-@.drv@-closure fix: before it, no --- derivation with a non-empty @drvInputDrvs@ could be realized (the closure was --- never on disk, so the dependency graph could not be read). -testDependentBuildIO :: IO [Bool] -testDependentBuildIO = do - putStrLn "builder/dependent-native-build" - withTempStore $ \store -> do - let storeDir = stDir store - depOut = StorePath (T.replicate 31 "c" <> "0") "dep" - depDrvSP = StorePath (T.replicate 31 "c" <> "1") "dep.drv" - rootOut = StorePath (T.replicate 31 "a" <> "0") "root" - rootDrvSP = StorePath (T.replicate 31 "a" <> "1") "root.drv" - mkBuilder word - | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo " <> word <> ">%out%"]) - | otherwise = ("/bin/sh", ["-c", "echo " <> word <> " > $out"]) - (depBuilder, depArgs) = mkBuilder "leaf" - (rootBuilder, rootArgs) = mkBuilder "root" - depDrv = - Derivation - { drvOutputs = [DerivationOutput {doName = "out", doPath = depOut, doHashAlgo = "", doHash = ""}], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = depBuilder, - drvArgs = depArgs, - drvEnv = Map.singleton "name" "dep" - } - rootDrv = - Derivation - { drvOutputs = [DerivationOutput {doName = "out", doPath = rootOut, doHashAlgo = "", doHash = ""}], - drvInputDrvs = Map.singleton depDrvSP ["out"], - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = rootBuilder, - drvArgs = rootArgs, - drvEnv = Map.singleton "name" "root" - } - -- The build driver writes the full .drv closure before building; emulate - -- that here by writing both recipes to the store. - writeDrv store depDrv depDrvSP - writeDrv store rootDrv rootDrvSP - buildTmp <- ( "nova-nix-test-dep-build-tmp") <$> getTemporaryDirectory - forceRemoveIfExists buildTmp - createDirectoryIfMissing True buildTmp - let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} - result <- buildWithDeps config store rootDrv rootDrvSP - depValid <- isValid store depOut - rootValid <- isValid store rootOut - forceRemoveIfExists buildTmp - case result of - BuildSuccess sp -> - sequence - [ runTest "dependent build succeeds with root output" $ - assertEqual "root output path" rootOut sp, - runTest "leaf dependency built and registered first" $ - if depValid then Pass else Fail "leaf output not valid after build", - runTest "root output built and registered" $ - if rootValid then Pass else Fail "root output not valid after build" - ] - BuildFailure msg code -> - sequence - [ runTest "dependent build succeeds with root output" $ - Fail ("dependency-aware build failed (exit " <> T.pack (show code) <> "): " <> msg) - ] - --- | Upstream value-conformance tests: each pins exact output bytes (hash --- decode, number formatting) that must match what upstream Nix computes for --- the same input, because these values can reach names, derivations, and --- hashes. -testUpstreamConformance :: IO [Bool] -testUpstreamConformance = do - putStrLn "eval/conformance" - let xmlDocument body = mkStr ("\n\n" <> body <> "\n") - sequence - [ -- Hash decode is length-keyed per algorithm, never first-format-wins: - -- a 52-char all-hex-digit string is a nix32 sha256 hash (64 hex chars - -- after conversion), not a 26-byte hex string echoed back. - runTest "hash decode keys on nix32 length" $ - assertEval - "hash-nix32-length" - "builtins.stringLength (builtins.convertHash { hash = \"0aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"; hashAlgo = \"sha256\"; toHashFormat = \"base16\"; })" - (VInt 64), - runTest "hash hex to nix32 round-trips" $ - assertEval - "hash-roundtrip" - "builtins.convertHash { hash = builtins.convertHash { hash = \"sha256:e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855\"; toHashFormat = \"nix32\"; }; hashAlgo = \"sha256\"; toHashFormat = \"base16\"; }" - (mkStr "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), - runTest "hash base64 spelling decodes by length" $ - assertEval - "hash-base64" - "builtins.convertHash { hash = \"sha256:47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; toHashFormat = \"base16\"; }" - (mkStr "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), - runTest "truncated hash is rejected" $ - assertEvalFail - "hash-truncated" - "builtins.convertHash { hash = \"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b85\"; hashAlgo = \"sha256\"; toHashFormat = \"base16\"; }", - runTest "unknown hash algorithm is rejected" $ - assertEvalFail - "hash-bad-algo" - "builtins.convertHash { hash = \"00\"; hashAlgo = \"sha3\"; toHashFormat = \"base16\"; }", - -- SRI digests get the same decoded-length check as every other - -- spelling (upstream checks SRI too), at all three decode sites: - -- convertHash, fixed-output outputHash, and the fetch/path pins. - runTest "valid SRI digest converts" $ - assertEval - "hash-sri-valid" - "builtins.convertHash { hash = \"sha256-47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; toHashFormat = \"base16\"; }" - (mkStr "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), - runTest "convertHash rejects a truncated SRI digest" $ - case evalNix "builtins.convertHash { hash = \"sha256-YWJj\"; toHashFormat = \"base16\"; }" of - Left err - | "wrong length" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected an SRI length error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - runTest "fixed-output outputHash rejects a truncated SRI digest" $ - case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha256-YWJj\"; }).drvPath" of - Left err - | "wrong length" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected an SRI length error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - -- An SRI or prefixed outputHash carries its own algorithm tag; a - -- non-empty outputHashAlgo must agree with it (hash.cc parseAny - -- with an expected type), and an unknown declared algorithm is an - -- error even when the spelling carries a valid tag of its own. - runTest "fixed-output SRI algorithm must match outputHashAlgo" $ - case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha1-2jmj7l5rSw0yVb/vlWAYkK/YBwk=\"; outputHashAlgo = \"sha256\"; }).drvPath" of - Left err - | "should have type 'sha256'" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected a hash-type error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - runTest "fixed-output prefixed algorithm must match outputHashAlgo" $ - case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"md5:d41d8cd98f00b204e9800998ecf8427e\"; outputHashAlgo = \"sha256\"; }).drvPath" of - Left err - | "should have type 'sha256'" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected a hash-type error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - runTest "fixed-output SRI agreeing with outputHashAlgo accepted" $ - case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha256-47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; outputHashAlgo = \"sha256\"; }).drvPath" of - Right _ -> Pass - Left err -> Fail ("expected success, got: " <> err), - runTest "fixed-output unknown outputHashAlgo rejected despite SRI tag" $ - case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha256-47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; outputHashAlgo = \"sha3\"; }).drvPath" of - Left err - | "unknown hash algorithm" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected an unknown-algorithm error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - runTest "builtins.path pin rejects a truncated SRI digest" $ - case evalNix "builtins.path { path = ./x; sha256 = \"sha256-YWJj\"; }" of - Left err - | "wrong length" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected an SRI length error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - runTest "builtins.path pin rejects a non-sha256 SRI digest" $ - case evalNix ("builtins.path { path = ./x; sha256 = \"sha512-" <> T.replicate 86 "A" <> "==\"; }") of - Left err - | "should have type 'sha256'" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected a hash-type error, got: " <> err) - Right val -> Fail ("expected failure, got: " <> T.pack (show val)), - -- toJSON floats: nlohmann's layout - shortest round-trip digits, .0 - -- kept on integral values, scientific outside point positions (-4, 15]. - runTest "toJSON float shortest digits" $ - assertEval "json-float-third" "builtins.toJSON (1.0 / 3.0)" (mkStr "0.3333333333333333"), - runTest "toJSON integral float keeps .0" $ - assertEval "json-float-integral" "builtins.toJSON 100.0" (mkStr "100.0"), - runTest "toJSON float plain decimal" $ - assertEval "json-float-tenth" "builtins.toJSON 0.1" (mkStr "0.1"), - runTest "toJSON float zero" $ - assertEval "json-float-zero" "builtins.toJSON 0.0" (mkStr "0.0"), - runTest "toJSON float widest plain integral" $ - assertEval "json-float-e14" "builtins.toJSON 1.0e14" (mkStr "100000000000000.0"), - runTest "toJSON float first scientific integral" $ - assertEval "json-float-e15" "builtins.toJSON 1.0e15" (mkStr "1e+15"), - runTest "toJSON float large exponent" $ - assertEval "json-float-e21" "builtins.toJSON 1.0e21" (mkStr "1e+21"), - runTest "toJSON float negative exponent" $ - assertEval "json-float-e-5" "builtins.toJSON 1.0e-5" (mkStr "1e-05"), - runTest "toJSON float smallest plain" $ - assertEval "json-float-e-4" "builtins.toJSON 1.0e-4" (mkStr "0.0001"), - runTest "toJSON non-finite float is null" $ - assertEval "json-float-inf" "builtins.toJSON (1.0e308 * 10.0)" (mkStr "null"), - -- fromJSON integers: int64 range stays int, wider falls back to float. - runTest "fromJSON promotes past-64-bit integer to float" $ - assertEval "json-bigint-type" "builtins.typeOf (builtins.fromJSON \"999999999999999999999\")" (mkStr "float"), - runTest "fromJSON past-64-bit integer value" $ - assertEval "json-bigint-val" "builtins.fromJSON \"999999999999999999999\" == 999999999999999999999.0" (VBool True), - runTest "fromJSON int64 max stays an int" $ - assertEval "json-int64-max" "builtins.fromJSON \"9223372036854775807\"" (VInt 9223372036854775807), - -- toXML floats: C++ default ostream formatting, 6 significant digits. - runTest "toXML float 6 significant digits" $ - assertEval - "xml-float-third" - "builtins.toXML (1.0 / 3.0)" - (xmlDocument " \n"), - runTest "toXML float plain decimal" $ - assertEval - "xml-float-centi" - "builtins.toXML 0.01" - (xmlDocument " \n"), - runTest "toXML integral float drops the point" $ - assertEval - "xml-float-integral" - "builtins.toXML 100.0" - (xmlDocument " \n"), - runTest "toXML float large exponent" $ - assertEval - "xml-float-e21" - "builtins.toXML 1.0e21" - (xmlDocument " \n"), - runTest "toXML float small exponent" $ - assertEval - "xml-float-e-5" - "builtins.toXML 2.5e-5" - (xmlDocument " \n"), - -- The document is upstream's XMLWriter output (value-to-xml.cc and - -- xml-writer.cc at 2.24.9): every element two spaces deeper than the - -- one around it, a newline in a value written as a character - -- reference. Each expected document is nix-instantiate 2.24.9's and - -- 2.33.2's (#221). - runTest "toXML indents each element under the one around it" $ - assertEval - "xml-nesting" - "builtins.toXML { s = \"a&\\\"q'\\n\\tz\"; l = [ 1 { } ]; }" - ( xmlDocument - ( " \n \n \n \n" - <> " \n \n \n \n" - <> " \n \n" - <> " \n \n" - ) - ), - runTest "toXML writes a lambda's argument pattern and leaves a primop unevaluated" $ - assertEval - "xml-functions" - "builtins.toXML [ (x: x) (args@{ z, ... }: 1) ({ b, a }: a) builtins.map (builtins.map (x: x)) ]" - ( xmlDocument - ( " \n \n \n \n" - <> " \n \n \n" - <> " \n \n" - <> " \n \n \n \n" - <> " \n \n" - <> " \n \n \n" - ) - ), - runTest "toXML writes a derivation in full once and repeated after" $ - assertEval - "xml-derivations" - "builtins.toXML [ { type = \"derivation\"; drvPath = \"/p\"; outPath = \"/o\"; a = 1; } { type = \"derivation\"; drvPath = \"/p\"; } { type = \"derivation\"; outPath = 2; } ]" - ( xmlDocument - ( " \n \n" - <> " \n \n \n" - <> " \n \n \n" - <> " \n \n \n" - <> " \n \n \n" - <> " \n" - <> " \n \n \n" - <> " \n \n \n \n" - ) - ), - runTest "toXML keeps the contexts of the strings it writes" $ - assertEval - "xml-context" - "let d = derivation { name = \"x\"; system = \"s\"; builder = \"b\"; }; in builtins.getContext (builtins.toXML { s = \"${d}\"; }) == builtins.getContext \"${d}\"" - (VBool True), - -- fromTOML integers: 64-bit signed range enforced, no silent wrap. - runTest "fromTOML rejects past-64-bit integer" $ - assertEvalFail "toml-int-overflow" "builtins.fromTOML \"v = 99999999999999999999\"", - runTest "fromTOML rejects past-64-bit hex integer" $ - assertEvalFail "toml-hex-overflow" "builtins.fromTOML \"v = 0xffffffffffffffff\"", - runTest "fromTOML int64 max parses" $ - assertEval "toml-int64-max" "(builtins.fromTOML \"v = 9223372036854775807\").v" (VInt 9223372036854775807), - runTest "fromTOML int64 min parses" $ - assertEval "toml-int64-min" "(builtins.fromTOML \"v = -9223372036854775808\").v == (0 - 9223372036854775807 - 1)" (VBool True), - -- drv3: pure eval cannot read the store, so hashing a dependent - -- derivation fails loudly rather than emitting a guessed input hash. - runTest "dependent derivation drvPath fails loudly in pure eval" $ - assertEvalFail - "drv-modulo-pure-miss" - "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; src = dep.outPath; }; in main.drvPath", - -- Path values canonicalize lexically (CanonPath): no dot segment or - -- doubled separator survives into a path value's text, so different - -- spellings of the same path compare equal. - runTest "path literal canonicalizes dot segments" $ - assertEval "path-canon-dot" "builtins.toString ./. == builtins.toString ./x/.." (VBool True), - runTest "path literal collapses inner dot" $ - assertEval "path-canon-inner" "builtins.toString ./a/./b == builtins.toString ./a/b" (VBool True), - runTest "path plus string canonicalizes" $ - assertEval "path-canon-plus" "./a + \"/../b\" == ./b" (VBool True), - runTest "toPath canonicalizes" $ - assertEval "path-canon-topath" "builtins.toString (builtins.toPath \"/a/../b\")" (mkStr "/b"), - runTest "toPath collapses inner dot" $ - assertEval "path-canon-topath-dot" "builtins.toString (builtins.toPath \"/a/./b\")" (mkStr "/a/b"), - runTest "toPath preserves forward-slash root" $ - assertEval "path-canon-topath-root" "builtins.toString (builtins.toPath \"//nix//store\")" (mkStr "/nix/store") - ] - --- | Eval-fidelity regression tests: each pins a semantic where the evaluator --- must match upstream Nix. All are parity-safe - none affects a derivation --- or store-path hash. -testEvalFidelity :: IO [Bool] -testEvalFidelity = do - putStrLn "eval/fidelity" - sequence - [ -- builtins.match: a non-participating capture group is null, not "" - runTest "match null capture group" $ - assertEval "match-null" "builtins.isNull (builtins.elemAt (builtins.match \"(a)(b)?\" \"a\") 1)" (VBool True), - runTest "match participating group value" $ - assertEval "match-val" "builtins.elemAt (builtins.match \"(a)(b)\" \"ab\") 1" (mkStr "b"), - -- builtins.split: a non-participating group is null too - runTest "split null capture group" $ - assertEval "split-null" "builtins.isNull (builtins.elemAt (builtins.elemAt (builtins.split \"(a)|(b)\" \"a\") 1) 1)" (VBool True), - -- builtins.match is whole-string like regex_match: top-level - -- alternation must not decay into a prefix/suffix match. - runTest "match alternation is whole-string" $ - assertEval "match-alt" "builtins.match \"a|b\" \"ab\"" VNull, - runTest "match alternation positive" $ - assertEval "match-alt-pos" "builtins.match \"a|b\" \"a\" == [ ]" (VBool True), - -- No multiline mode: ^/$ anchor only at the string boundaries and - -- '.' matches a newline, as POSIX ERE whole-string matching does. - runTest "match does not anchor at inner newlines" $ - assertEval "match-nl" "builtins.match \"foo\" \"bar\\nfoo\"" VNull, - runTest "match dot spans newline" $ - assertEval "match-dot-nl" "builtins.match \"(.*)\" \"a\\nb\" == [ \"a\\nb\" ]" (VBool True), - runTest "split dot spans newline" $ - assertEval "split-dot-nl" "builtins.split \"a.b\" \"xa\\nby\" == [ \"x\" [ ] \"y\" ]" (VBool True), - -- Derivations compare by outPath alone (C++ eqValues special case) - - -- even when the rest of the attrs (or the key sets) differ. - runTest "derivation eq by outPath" $ - assertEval - "drv-eq" - "{ type = \"derivation\"; outPath = \"/nix/store/a\"; f = (x: x); } == { type = \"derivation\"; outPath = \"/nix/store/a\"; f = (y: y); extra = 1; }" - (VBool True), - runTest "derivation neq by outPath" $ - assertEval - "drv-neq" - "{ type = \"derivation\"; outPath = \"/a\"; } == { type = \"derivation\"; outPath = \"/b\"; }" - (VBool False), - runTest "derivation-tagged sets without outPath deep-compare" $ - assertEval - "drv-no-outpath" - "{ type = \"derivation\"; n = 1; } == { type = \"derivation\"; n = 1; }" - (VBool True), - -- A throwing derivation attr fails evaluation - never a silent drop - -- (a dropped attr once produced an empty no-input .drv that "built"). - runTest "derivation attr throw propagates" $ - assertEvalFail "drv-throw" "(derivation { name = \"x\"; system = \"s\"; builder = \"/b\"; src = throw \"boom\"; }).drvPath", - -- __ignoreNulls drops null attrs; without it null coerces to "". - runTest "derivation ignoreNulls drops null" $ - assertEval "drv-ignore-nulls" "builtins.isString (derivation { name = \"x\"; system = \"s\"; builder = \"/b\"; src = null; __ignoreNulls = true; }).drvPath" (VBool True), - runTest "derivation null coerces without ignoreNulls" $ - assertEval "drv-null-empty" "builtins.isString (derivation { name = \"x\"; system = \"s\"; builder = \"/b\"; foo = null; }).drvPath" (VBool True), - -- A literal string key is static, as in upstream's parser: legal in - -- let, referenceable as a rec sibling. - runTest "let with literal string key" $ - assertEval "let-string-key" "let \"x\" = 1; in x" (VInt 1), - runTest "rec string key is a referenceable sibling" $ - assertEval "rec-string-key" "(rec { \"a\" = 1; b = a; }).b" (VInt 1), - -- A dynamic TOP-LEVEL key in let is a parse error upstream; nested - -- dynamic keys live in a nested attrset and stay legal. - runTest "dynamic key in let rejected" $ - assertParseFail "let-dyn-key" "let k = \"y\"; in let ${k} = 1; in y", - runTest "interpolated string key in let rejected" $ - assertParseFail "let-interp-key" "let k = \"y\"; in let \"${k}\" = 1; in y", - runTest "nested dynamic key in let allowed" $ - assertEval "let-nested-dyn" "let k = \"q\"; in let a.${k} = 1; in a.q" (VInt 1), - -- Nested interpolated strings inside braces: the lexer's brace-depth - -- stack must restore the enclosing count when an interpolation - -- closes, or the outer attrset's '}' mislexes as TokInterpClose. - runTest "nested interpolated string inside attrset braces" $ - assertEval "nested-interp" "let y = \"v\"; in \"${ { a = \"${y}\"; }.a }\"" (mkStr "v"), - runTest "nested interpolation in indented string" $ - assertEval "nested-interp-ind" "let y = \"w\"; in ''pre ${ { a = ''${y}''; }.a } post''" (mkStr "pre w post"), - runTest "doubly nested interpolated strings" $ - assertEval "nested-interp-2" "let y = \"z\"; in \"${ { a = \"${ { b = \"${y}\"; }.b }\"; }.a }\"" (mkStr "z"), - -- Attrpath merging (upstream parser.y addAttr): a literal set and a - -- nested path under the same key merge; genuine duplicates error. - runTest "literal set merges with attrpath (kept attr)" $ - assertEval "merge-keep" "{ a = { b = 1; }; a.c = 2; }.a.b" (VInt 1), - runTest "literal set merges with attrpath (added attr)" $ - assertEval "merge-add" "{ a = { b = 1; }; a.c = 2; }.a.c" (VInt 2), - runTest "duplicate plain key is a parse error" $ - assertParseFail "dup-key" "{ a = 1; a = 2; }", - runTest "duplicate formal is rejected" $ - assertParseFail "dup-formal" "{ a, a }: a", - runTest "duplicate formal with defaults is rejected" $ - assertParseFail "dup-formal-default" "{ a ? 1, a ? 2 }: a", - runTest "duplicate inner key on merge is an error" $ - assertParseFail "dup-inner" "{ a.b = 1; a = { b = 2; }; }", - runTest "inherit conflicting with a definition is an error" $ - assertParseFail "dup-inherit" "let q = 1; in { inherit q; q = 2; }", - runTest "attrpath into a non-set is an error" $ - assertParseFail "merge-non-set" "{ a = 1; a.b = 2; }", - -- rec markers in attrpath merging follow upstream's addAttr: the - -- existing set's marker governs the result; the new set's marker is - -- discarded. - runTest "merge into rec literal keeps rec (sibling visible)" $ - assertEval "merge-rec-keep" "{ a = rec { b = 1; }; a.c = b; }.a.c" (VInt 1), - runTest "merged-in rec marker is discarded (outer binding wins)" $ - assertEval "merge-rec-discard" "let d = 7; in { a = { x = 1; }; a = rec { c = d; }; }.a.c" (VInt 7), - -- Exactly upstream's unprefixed global surface: fetchurl and toFile - -- exist only under builtins. - runTest "bare fetchurl is not a global" $ - assertEvalFail "no-bare-fetchurl" "fetchurl", - runTest "bare toFile is not a global" $ - assertEvalFail "no-bare-tofile" "toFile", - -- Dynamic keys colliding with an existing attr are an eval error, - -- never a silent last-win merge. - runTest "dynamic key colliding with static errors" $ - assertEvalFail "dyn-collide" "{ b = 1; ${\"b\"} = 2; }", - runTest "rec dynamic key colliding with static errors" $ - assertEvalFail "dyn-collide-rec" "rec { b = 1; p.q = 1; ${\"b\"} = 2; }", - -- Higher-order list builtins pass elements as unforced thunks: an - -- element the function never inspects may throw without failing. - runTest "filter does not force elements" $ - assertEval "filter-lazy" "builtins.length (builtins.filter (x: true) [ (builtins.throw \"never\") ])" (VInt 1), - runTest "any does not force undecided elements" $ - assertEval "any-lazy" "builtins.any (x: x) [ true (builtins.throw \"never\") ]" (VBool True), - runTest "foldl' passes elements unforced" $ - assertEval "foldl-lazy" "builtins.foldl' (a: b: a) 0 [ (builtins.throw \"never\") ]" (VInt 0), - -- Attrset equality stops at the first mismatch; later pairs are - -- never forced. - runTest "attrset eq short-circuits" $ - assertEval "eq-short" "{ a = 1; b = builtins.throw \"never\"; } == { a = 2; b = builtins.throw \"never\"; }" (VBool False), - -- toString of a float is std::to_string's fixed 6 decimals; value - -- printing and toJSON keep the trimmed form. - runTest "toString float has fixed 6 decimals" $ - assertEval "tostr-float" "builtins.toString 1.5" (mkStr "1.500000"), - runTest "toJSON float stays trimmed" $ - assertEval "tojson-float" "builtins.toJSON 1.5" (mkStr "1.5"), - -- path + string-with-context is an error (a store-path reference - -- cannot survive inside a path value). - runTest "path plus string with context errors" $ - assertEvalFail "path-ctx" "./x + (derivation { name = \"q\"; system = \"s\"; builder = \"/b\"; }).drvPath", - -- builtins.toJSON honors __toString, preferring it over outPath - runTest "toJSON __toString" $ - assertEval "tojson-tostr" "builtins.toJSON { __toString = self: \"x\"; }" (mkStr "\"x\""), - runTest "toJSON __toString beats outPath" $ - assertEval "tojson-tostr-out" "builtins.toJSON { __toString = self: \"a\"; outPath = \"/b\"; }" (mkStr "\"a\""), - runTest "toJSON outPath still works" $ - assertEval "tojson-out" "builtins.toJSON { outPath = \"/b\"; }" (mkStr "\"/b\""), - -- String interpolation is strict (coerceMore = False): scalars error - runTest "interp rejects int" $ - assertEvalFail "interp-int" "\"v${1}\"", - runTest "interp rejects bool" $ - assertEvalFail "interp-bool" "\"${true}\"", - runTest "interp rejects null" $ - assertEvalFail "interp-null" "\"${null}\"", - runTest "concatStringsSep rejects int" $ - assertEvalFail "ccs-int" "builtins.concatStringsSep \",\" [ 1 2 ]", - -- builtins.toString stays permissive - runTest "toString still coerces int" $ - assertEval "tostr-int" "builtins.toString 1" (mkStr "1"), - runTest "interp via toString works" $ - assertEval "interp-tostr" "\"v${builtins.toString 1}\"" (mkStr "v1"), - -- builtins.substring rejects a negative start position - runTest "substring negative start errors" $ - assertEvalFail "substr-neg" "builtins.substring (0 - 1) 3 \"hello\"", - -- an integer literal that overflows Int64 is a parse error, not a wrap - runTest "integer literal overflow errors" $ - assertParseFail "int-overflow" "99999999999999999999", - -- float exponents and leading-dot floats lex per the Nix grammar - runTest "float exponent lexes as float" $ - assertEval "float-exp-type" "builtins.typeOf 6.022e23" (mkStr "float"), - runTest "float negative exponent lexes" $ - assertEval "float-negexp-type" "builtins.typeOf 1.0e-3" (mkStr "float"), - runTest "float exponent value" $ - assertEval "float-exp-val" "1.5e1 == 15.0" (VBool True), - runTest "leading-dot float lexes as float" $ - assertEval "leading-dot-type" "builtins.typeOf .5" (mkStr "float"), - runTest "leading-dot float value" $ - assertEval "leading-dot-val" ".5 == 0.5" (VBool True), - -- PureEval tryEval must NOT catch abort - it propagates (matches C++ Nix) - runTest "tryEval does not catch abort" $ - assertEvalFail "tryeval-abort" "(builtins.tryEval (builtins.abort \"x\")).success", - -- every builtin in the registry (the source of builtinNames/builtinArity) - -- is actually exposed in the builtins set - guards against builtinRegistry - -- drifting from the exposed builtins - runTest "every registered builtin is exposed" $ - let missing = [n | n <- builtinNames, evalNix ("builtins ? \"" <> n <> "\"") /= Right (VBool True)] - in if null missing then Pass else Fail ("not exposed: " <> T.intercalate ", " missing) - ] - --- | Pure hash decode/digest helpers shared by eval (fixed-output paths) and --- the builder (builtin:fetchurl verification). -testHashHelpers :: IO [Bool] -testHashHelpers = do - putStrLn "hash/decode-helpers" - sequence - [ -- The incremental digest is the streaming twin of the one-shot: - -- chunked input must produce identical bytes for every algorithm. - runTest "incremental digest matches one-shot across algorithms" $ - let chunks = ["nova", "-", "nix", " streams", BS.replicate 1000 55] - agrees algo = case (Hash.hashInitWithAlgo algo, Hash.rawHashWithAlgo algo (BS.concat chunks)) of - (Just ctx0, Just expected) -> - Hash.hashFinalizeBytes (foldl' Hash.hashUpdateChunk ctx0 chunks) == expected - _ -> False - in if all agrees ["sha256", "sha512", "sha1", "md5"] - then Pass - else Fail "incremental and one-shot digests disagree", - runTest "incremental digest rejects an unknown algorithm" $ - case Hash.hashInitWithAlgo "blake3" of - Nothing -> Pass - Just _ -> Fail "unknown algorithm accepted", - runTest "hexToBytes empty" $ assertEqual "empty" (Just BS.empty) (Hash.hexToBytes ""), - runTest "hexToBytes deadbeef" $ - assertEqual "deadbeef" (Just (BS.pack [0xde, 0xad, 0xbe, 0xef])) (Hash.hexToBytes "deadbeef"), - runTest "hexToBytes uppercase" $ - assertEqual "DEADBEEF" (Just (BS.pack [0xde, 0xad, 0xbe, 0xef])) (Hash.hexToBytes "DEADBEEF"), - runTest "hexToBytes odd length rejected" $ assertEqual "odd" Nothing (Hash.hexToBytes "abc"), - runTest "hexToBytes non-hex rejected" $ assertEqual "nonhex" Nothing (Hash.hexToBytes "zz"), - runTest "rawHashWithAlgo sha256 empty == known vector" $ - assertEqual - "sha256-empty" - (Hash.hexToBytes "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855") - (Hash.rawHashWithAlgo "sha256" BS.empty), - runTest "rawHashWithAlgo unknown algo rejected" $ - assertEqual "unknown" Nothing (Hash.rawHashWithAlgo "sha3-256" (BS.pack [1, 2, 3])), - -- verifyFetchHash: the composed builtin:fetchurl integrity gate that - -- guards every fixed-output seed fetch - runTest "verifyFetchHash accepts a matching flat hash" $ - assertEqual - "fetch-hash-ok" - (Right ()) - (verifyFetchHash "https://x/f.tar.gz" (fetchOut "sha256" sha256Hello) "hello"), - runTest "verifyFetchHash rejects mismatched bytes" $ - case verifyFetchHash "https://x/f.tar.gz" (fetchOut "sha256" sha256Hello) "world" of - Left (_, msg) | "hash mismatch" `T.isInfixOf` msg -> Pass - other -> Fail ("expected mismatch rejection, got: " <> T.pack (show other)), - runTest "verifyFetchHash rejects a malformed expected hash" $ - case verifyFetchHash "https://x/f" (fetchOut "sha256" "zz-not-hex") "hello" of - Left (_, msg) | "malformed expected hash" `T.isInfixOf` msg -> Pass - other -> Fail ("expected malformed-hash rejection, got: " <> T.pack (show other)), - runTest "verifyFetchHash rejects an unsupported algorithm" $ - case verifyFetchHash "https://x/f" (fetchOut "sha3-256" "00") "hello" of - Left (_, msg) | "unsupported hash algorithm" `T.isInfixOf` msg -> Pass - other -> Fail ("expected unsupported-algo rejection, got: " <> T.pack (show other)), - runTest "verifyFetchHash rejects recursive mode rather than comparing flat" $ - case verifyFetchHash "https://x/f" (fetchOut "r:sha256" sha256Hello) "hello" of - Left (_, msg) | "recursive" `T.isInfixOf` msg -> Pass - other -> Fail ("expected recursive-mode rejection, got: " <> T.pack (show other)) - ] - where - -- sha256 of the ASCII bytes "hello". - sha256Hello = "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824" - fetchOut algo hash = - DerivationOutput - { doName = "out", - doPath = StorePath (T.replicate 32 "f") "fetched", - doHashAlgo = algo, - doHash = hash - } - --- --------------------------------------------------------------------------- --- Tests: NAR and hash known-answer vectors --- --------------------------------------------------------------------------- - --- | Encode one NAR string per the spec: little-endian u64 length, the --- bytes, zero-padding to the next 8-byte boundary. Written here from the --- format definition, deliberately independent of nova-cache's encoder, so --- these vectors pin the wire layout rather than the library against --- itself. -narSpecStr :: BS.ByteString -> BS.ByteString -narSpecStr s = lenLE <> s <> padding - where - n = BS.length s - lenLE = BS.pack [fromIntegral ((n `shiftR` (8 * i)) .&. 0xff) | i <- [0 .. 7]] - padding = BS.replicate ((8 - n `mod` 8) `mod` 8) 0 - --- | Hand-encoded NAR of a directory holding an executable, a plain file, --- and a symlink - covering entry ordering, the executable marker, content --- padding, and all node kinds. -narSpecVector :: BS.ByteString -narSpecVector = - BS.concat $ - map - narSpecStr - [ "nix-archive-1", - "(", - "type", - "directory", - "entry", - "(", - "name", - "bin", - "node", - "(", - "type", - "directory", - "entry", - "(", - "name", - "tool", - "node", - "(", - "type", - "regular", - "executable", - "", - "contents", - "#!x", - ")", - ")", - ")", - ")", - "entry", - "(", - "name", - "data.txt", - "node", - "(", - "type", - "regular", - "contents", - "hello\n", - ")", - ")", - "entry", - "(", - "name", - "link", - "node", - "(", - "type", - "symlink", - "target", - "data.txt", - ")", - ")", - ")" - ] - --- | The in-memory tree 'narSpecVector' encodes. -narSpecTree :: NAR.NarEntry -narSpecTree = - NAR.NarDirectory - [ ("bin", NAR.NarDirectory [("tool", NAR.NarRegular True "#!x")]), - ("data.txt", NAR.NarRegular False "hello\n"), - ("link", NAR.NarSymlink "data.txt") - ] - --- | Hand-encoded NAR of just @data.txt@, for the on-disk addToStore vector. --- No executable entry, so the vector stays a fixture for addToStore rather --- than for the exec bit; 'testExecBit' covers that on both platforms. -narSpecFileVector :: BS.ByteString -narSpecFileVector = - BS.concat $ - map - narSpecStr - [ "nix-archive-1", - "(", - "type", - "directory", - "entry", - "(", - "name", - "data.txt", - "node", - "(", - "type", - "regular", - "contents", - "hello\n", - ")", - ")", - ")" - ] - --- | fromTOML: multi-line values (the Cargo.lock shapes) and comment --- placement relative to strings. -testFromTOML :: IO [Bool] -testFromTOML = do - putStrLn "eval/fromTOML" - sequence - [ -- Key splitting and logical-line joining accumulate in chunks, so - -- cost is linear in the input (per-character/per-line append was - -- quadratic). The watchdog turns a cost regression into a FAIL - -- rather than a stuck suite. - runTestM "fromTOML long key parses in linear time" $ do - let source = - "builtins.length (builtins.attrNames (builtins.fromTOML \"" - <> T.replicate 200000 "k" - <> " = 1\"))" - counted = evalNix source == Right (VInt 1) - outcome <- timeout walkWatchdogMicros (evaluate counted) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong parse for a long key" - Nothing -> Fail "long key did not parse promptly", - runTestM "fromTOML many continued lines join in linear time" $ do - -- 4000 physical lines of 50 elements each: one ~400KB logical - -- line, one 200000-element array. - let line = T.intercalate " " (replicate 50 "1,") - body = "x = [\n" <> T.intercalate "\n" (replicate 4000 line) <> "\n]" - source = "builtins.length (builtins.fromTOML \"" <> body <> "\").x" - counted = evalNix source == Right (VInt 200000) - outcome <- timeout walkWatchdogMicros (evaluate counted) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong parse for continued lines" - Nothing -> Fail "continued lines did not join promptly", - runTest "multi-line array" $ - assertEval - "toml-ml-array" - "builtins.concatStringsSep \",\" (builtins.fromTOML \"deps = [\\n \\\"bar\\\",\\n \\\"baz\\\",\\n]\\n\").deps" - (mkStr "bar,baz"), - runTest "Cargo.lock package shape" $ - assertEval - "toml-cargo-lock" - "(builtins.elemAt (builtins.fromTOML \"[[package]]\\nname = \\\"foo\\\"\\ndependencies = [\\n \\\"bar\\\",\\n]\\n\").package 0).name" - (mkStr "foo"), - runTest "multi-line basic string" $ - assertEval - "toml-ml-string" - "(builtins.fromTOML \"s = \\\"\\\"\\\"\\nline1\\nline2\\\"\\\"\\\"\").s" - (mkStr "line1\nline2"), - runTest "multi-line literal string" $ - assertEval - "toml-ml-literal" - "(builtins.fromTOML \"s = '''\\nkeep'''\").s" - (mkStr "keep"), - runTest "comment inside a multi-line array" $ - assertEval - "toml-ml-comment" - "builtins.concatStringsSep \",\" (builtins.fromTOML \"deps = [ # opening\\n \\\"bar\\\", # trailing\\n]\").deps" - (mkStr "bar"), - runTest "hash inside a string is content" $ - assertEval - "toml-hash-content" - "(builtins.fromTOML \"s = \\\"\\\"\\\"a#b\\\"\\\"\\\"\").s" - (mkStr "a#b"), - runTest "single-line values still parse" $ - assertEval - "toml-single-line" - "(builtins.fromTOML \"x = 4\\ny = \\\"z\\\" # cmt\").y" - (mkStr "z") - ] - -testAttrPath :: IO [Bool] -testAttrPath = do - putStrLn "\n-- Attribute paths (build -A) --" - sequence - [ runTest "a bare name is one component" $ - assertEqual "single" (Right ["hello"]) (parseAttrPath "hello"), - runTest "dots separate components" $ - assertEqual "dotted" (Right ["a", "b", "c"]) (parseAttrPath "a.b.c"), - runTest "a quoted component carries a dot" $ - assertEqual "quoted" (Right ["a", "b.c", "d"]) (parseAttrPath "a.\"b.c\".d"), - -- Upstream's quotes concatenate rather than delimit, so a quoted run - -- glues onto whatever sits beside it instead of standing alone. - runTest "quotes concatenate onto the surrounding name" $ - assertEqual - "glued" - [Right ["foobar"], Right ["foobar"]] - [parseAttrPath "\"foo\"bar", parseAttrPath "foo\"bar\""], - -- The last component is kept only when non-empty, so these three - -- select nothing at all rather than naming an empty attribute. - runTest "an empty path selects nothing" $ - assertEqual - "nothing" - [Right [], Right [], Right ["a"]] - [parseAttrPath "", parseAttrPath "\"\"", parseAttrPath "a."], - -- An interior empty component survives tokenizing; selection rejects - -- it, and only after checking the type of what it would index. - runTest "an interior empty component survives tokenizing" $ - assertEqual - "interior" - [Right ["", "a"], Right ["a", "", "b"]] - [parseAttrPath ".a", parseAttrPath "a..b"], - runTest "an unclosed quote is an error" $ - assertEqual - "unclosed" - (Left "missing closing quote in selection path \'a.\"b\'") - (parseAttrPath "a.\"b") - ] - --- | The remembered-fetch record, on its own. All three functions are pure, --- and every property that keeps a warm cache honest is decided here: what --- shares an entry, what round-trips, and what a torn file decodes to. -testFetchCache :: IO [Bool] -testFetchCache = do - putStrLn "eval/fetch-cache" - sequence - [ runTest "the key separates every input that decides the answer" $ - let base = fetchCacheKey "https://example.com/r" "source" "abc" False False - variants = - [ fetchCacheKey "https://example.com/s" "source" "abc" False False, - fetchCacheKey "https://example.com/r" "other" "abc" False False, - fetchCacheKey "https://example.com/r" "source" "def" False False, - fetchCacheKey "https://example.com/r" "source" "abc" True False, - -- shallow decides revCount, so it cannot share an entry - -- with a full clone of the same revision. - fetchCacheKey "https://example.com/r" "source" "abc" False True - ] - in assertEqual "collisions with the base key" [] (filter (== base) variants), - runTest "the same fetch keys the same both times" $ - assertEqual - "repeat" - (fetchCacheKey "https://example.com/r" "source" "abc" True True) - (fetchCacheKey "https://example.com/r" "source" "abc" True True), - runTest "an entry round-trips through encode and decode" $ - assertEqual "decode . encode" (Just sampleFetchCache) (decodeFetchCache (encodeFetchCache sampleFetchCache)), - runTest "a torn entry decodes to nothing" $ - let whole = encodeFetchCache sampleFetchCache - -- Every prefix, so the cut lands in each field in turn. The - -- last field is the one that matters: a cut before it leaves - -- fewer than five lines and is rejected on shape alone, while - -- a cut inside narHash still leaves five. - torn = [T.take n whole | n <- [0 .. T.length whole - 1]] - in assertEqual "prefixes that decoded" [] (filter (isJust . decodeFetchCache) torn), - runTest "a non-decimal count is not an entry" $ - assertEqual - "revCount" - Nothing - (decodeFetchCache (replaceCount (encodeFetchCache sampleFetchCache) "12x")), - -- The hit path itself, end to end through builtins.fetchGit. Nothing - -- here can reach the network: the stub's createScratchDir throws, so - -- a Right at all proves the fetch was skipped, and every field comes - -- from the entry rather than from git. - runTest "a warm entry answers builtins.fetchGit without fetching" $ - case evalWarmFetchGit sampleFetchCache (Set.singleton (fcStorePath sampleFetchCache)) of - Left err -> Fail ("a warm cache still tried to fetch: " <> err) - Right val -> - assertEqual - "fields" - [ ("outPath", VPath (fcStorePath sampleFetchCache)), - ("rev", mkStr (fcRev sampleFetchCache)), - ("revCount", VInt 1234), - ("narHash", mkStr ("sha256-" <> fcNarHash sampleFetchCache)) - ] - (fetchGitFields val ["outPath", "rev", "revCount", "narHash"]), - -- The guard on the hit, on the axis that matters. doesPathExist is - -- False throughout the stub and adoptStorePath is what decides, so a - -- hit that consulted mere existence would fail this and a hit that - -- adopts the path passes the case above. Adoption is what records - -- the store write, and a hit that skipped it would hand back an - -- outPath no derivation naming it could be built against. - runTest "an entry whose path cannot be adopted refetches" $ - case evalWarmFetchGit sampleFetchCache Set.empty of - Right _ -> Fail "an unadoptable entry was served from the cache" - Left err - | "createScratchDir" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected a refetch, got: " <> err), - runTest "a bare ref is never served from the cache" $ - -- Whatever the cache holds, a ref means "wherever this branch - -- points now", so the entry must not be consulted at all. - case evalNixStubWith - (warmEnv sampleFetchCache (Set.singleton (fcStorePath sampleFetchCache))) - "builtins.fetchGit { url = \"https://example.com/r\"; ref = \"main\"; }" of - Right _ -> Fail "a bare ref was served from the cache" - Left err - | "createScratchDir" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected a fetch, got: " <> err), - runTest "a hash that is not base64 sha256 is not an entry" $ - assertEqual - "narHash" - [Nothing, Nothing, Nothing] - ( map - (decodeFetchCache . encodeFetchCache) - [ sampleFetchCache {fcNarHash = T.take 43 (fcNarHash sampleFetchCache)}, - sampleFetchCache {fcNarHash = T.replicate 44 "="}, - sampleFetchCache {fcNarHash = T.take 43 (fcNarHash sampleFetchCache) <> "A"} - ] - ) - ] - where - -- Swap the encoded revCount line, which encodeFetchCache cannot - -- produce: the field is an Integer on the way in. - replaceCount encoded replacement = case T.splitOn "\n" encoded of - [storePath, rev, _, lastModified, narHash] -> - T.intercalate "\n" [storePath, rev, replacement, lastModified, narHash] - _ -> encoded - --- | A stub store whose cache is warm for 'evalWarmFetchGit'\'s fetch, and --- which will adopt exactly the given store paths. -warmEnv :: FetchCache -> Set.Set Text -> StubEnv -warmEnv fields adoptable = - (stubEnv Map.empty) - { seFetchCache = - Map.singleton - (fetchCacheKey "https://example.com/r" "source" warmFetchGitRev False False) - (encodeFetchCache fields), - seAdoptable = adoptable - } - --- | The pinned revision 'evalWarmFetchGit' asks for. -warmFetchGitRev :: Text -warmFetchGitRev = T.replicate 40 "b" - --- | Evaluate a pinned @builtins.fetchGit@ against a warm cache. -evalWarmFetchGit :: FetchCache -> Set.Set Text -> Either Text NixValue -evalWarmFetchGit fields adoptable = - evalNixStubWith - (warmEnv fields adoptable) - ("builtins.fetchGit { url = \"https://example.com/r\"; rev = \"" <> warmFetchGitRev <> "\"; }") - --- | Read the named attributes off a @fetchGit@ result, in the order asked. -fetchGitFields :: NixValue -> [Text] -> [(Text, NixValue)] -fetchGitFields val names = case val of - VAttrs attrs -> - [ (name, value) - | name <- names, - Just thunk <- [attrSetLookup name attrs], - Just value <- [readThunkValue thunk] - ] - _ -> [] - --- | One recorded fetch, with a real 44-character base64 sha256. -sampleFetchCache :: FetchCache -sampleFetchCache = - FetchCache - { fcStorePath = "/nix/store/" <> T.replicate 32 "a" <> "-source", - fcRev = T.replicate 40 "b", - fcRevCount = 1234, - fcLastModified = 1700000000, - fcNarHash = T.replicate 43 "A" <> "=" - } - --- | Which derivations this machine will spawn, and how. --- --- The distinction that matters is between the two answers that used to be --- one: a derivation for this platform needs no launcher, and a derivation --- for another platform with no launcher configured is not the same thing. -testExecWrapper :: IO [Bool] -testExecWrapper = do - putStrLn "builder/exec-wrapper" - sequence - [ runTest "a derivation for this platform is spawned directly" $ - assertEqual - "native" - SpawnNative - (execWrapperFor (wrapperConfig [(platformToText foreignPlatform, "/usr/bin/wine")]) (drvFor currentPlatform)), - runTest "a configured foreign system spawns through its launcher" $ - assertEqual - "wrapped" - (SpawnThrough "/usr/bin/wine") - (execWrapperFor (wrapperConfig [(platformToText foreignPlatform, "/usr/bin/wine")]) (drvFor foreignPlatform)), - -- The finding this exists for: without a distinct answer here, a - -- foreign builder was spawned natively and failed in the loader, - -- after the whole closure had already been realized. - runTest "an unconfigured foreign system is refused, not spawned" $ - assertEqual - "unsupported" - (SpawnUnsupported (platformToText foreignPlatform)) - (execWrapperFor (wrapperConfig []) (drvFor foreignPlatform)), - -- A 32-bit derivation on a 64-bit host of the same OS is native, as - -- upstream's extra-platforms makes it, launcher or no launcher; on - -- any other host it is as foreign as anything else. - runTest "an i686 derivation spawns natively on its x86_64 host, whatever is configured" $ - assertEqual - "wow64" - [SpawnNative, SpawnNative, SpawnNative, SpawnNative] - [ spawnFor X86_64_Windows (wrapperConfig []) (drvFor I686_Windows), - spawnFor X86_64_Windows (wrapperConfig [("i686-windows", "/usr/bin/wine")]) (drvFor I686_Windows), - spawnFor X86_64_Linux (wrapperConfig []) (drvFor I686_Linux), - spawnFor X86_64_Linux (wrapperConfig [("i686-linux", "/opt/qemu")]) (drvFor I686_Linux) - ], - runTest "an i686 derivation elsewhere is refused or launched like any foreign system" $ - assertEqual - "elsewhere" - [SpawnUnsupported "i686-windows", SpawnThrough "/usr/bin/wine", SpawnUnsupported "i686-linux"] - [ spawnFor X86_64_Linux (wrapperConfig []) (drvFor I686_Windows), - spawnFor X86_64_Linux (wrapperConfig [("i686-windows", "/usr/bin/wine")]) (drvFor I686_Windows), - spawnFor Aarch64_Darwin (wrapperConfig []) (drvFor I686_Linux) - ], - -- The system string is the derivation's own spelling, matched - -- exactly. The documentation once named a different one, which - -- parsed, stored, and then never matched anything. - runTest "SYSTEM=PATH splits at the first separator" $ - assertEqual - "specs" - (Right (Map.fromList [("x86_64-windows", "/usr/bin/wine"), ("aarch64-linux", "/opt/qemu=static/qemu")])) - (execWrapperConfig ["x86_64-windows=/usr/bin/wine", "aarch64-linux=/opt/qemu=static/qemu"]), - runTest "no specs is an empty map, not an error" $ - assertEqual "empty" (Right Map.empty) (execWrapperConfig []), - runTest "a spec missing either half is rejected" $ - assertEqual - "malformed" - (replicate 4 True) - (map (either (const True) (const False) . execWrapperConfig . pure) ["wine", "=wine", "x86_64-windows=", ""]), - -- Last-one-wins would run a build through a launcher the operator - -- did not think they had asked for. - runTest "naming one system twice is rejected" $ - assertEqual - "duplicate" - (Left "--exec-wrapper names x86_64-windows twice") - (execWrapperConfig ["x86_64-windows=/usr/bin/wine", "x86_64-windows=/usr/bin/wine64"]), - runTest "a launcher keyed on any other spelling does not match" $ - assertEqual - "near-miss keys" - (replicate 3 (SpawnUnsupported (platformToText foreignPlatform))) - ( [ execWrapperFor (wrapperConfig [(key, "/usr/bin/wine")]) (drvFor foreignPlatform) - | key <- ["x86-windows", "windows", T.toUpper (platformToText foreignPlatform)] - ] - ) - ] - where - -- Some platform this test is not running on, so "foreign" is foreign - -- whichever host runs the suite. - foreignPlatform = - if currentPlatform == X86_64_Windows then X86_64_Linux else X86_64_Windows - wrapperConfig entries = - (defaultBuildConfig (StoreDir "/nix/store")) {bcExecWrappers = Map.fromList entries} - drvFor platform = - Derivation - { drvOutputs = [DerivationOutput "out" (StorePath (T.replicate 32 "a") "spawn") "" ""], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = platform, - drvBuilder = "/bin/sh", - drvArgs = [], - drvEnv = Map.empty - } - -testFetchMirrors :: IO [Bool] -testFetchMirrors = do - putStrLn "builder/fetch-mirrors" - sequence - [ runTest "fetch URLs preserve the legacy single URL" $ - assertEqual - "url" - (Right ("https://a/file%20name" :| [])) - (fetchUrlsFromEnv (Map.singleton "url" "https://a/file%20name")), - runTest "fetch URLs prefer the explicit ordered list" $ - assertEqual - "urls" - (Right ("https://a" :| ["https://b"])) - (fetchUrlsFromEnv (Map.fromList [("url", "https://ignored"), ("urls", " https://a\t https://b\n")])), - runTest "fetch URLs preserve non-ASCII whitespace within a URL" $ - let url = "https://a/has\xA0space" - in assertEqual - "non-ASCII URL" - (Right (url :| ["https://b"])) - (fetchUrlsFromEnv (Map.singleton "urls" (TE.encodeUtf8 (url <> " https://b")))), - runTest "fetch URLs reject missing, empty and invalid UTF-8 inputs" $ - assertEqual - "invalid" - (replicate 5 True) - ( map - (either (const True) (const False) . fetchUrlsFromEnv) - [Map.empty, Map.singleton "url" "", Map.fromList [("urls", " "), ("url", "https://ignored")], Map.singleton "url" (BS.pack [255]), Map.singleton "urls" (BS.pack [255])] - ), - runTestM "mirror policy retries timeout and hash failures in order" $ do - calls <- newIORef [] - let attempt url = do - atomicModifyIORef' calls (\seen -> (seen ++ [url], ())) - pure $ case url of - "slow" -> Left "download timeout" - "corrupt" -> Left "hash mismatch" - _ -> Right ("verified" :: Text) - result <- tryFetchUrlsWith attempt ("slow" :| ["corrupt", "good", "unused"]) - seen <- readIORef calls - pure (assertEqual "ordered attempts" (Right "verified", ["slow", "corrupt", "good"]) (result, seen)), - runTestM "mirror policy returns every failure in order" $ do - result <- tryFetchUrlsWith (pure . Left) ("first failure" :| ["second failure"]) - pure (assertEqual "failures" (Left "first failure\nsecond failure" :: Either Text ()) result), - runTestM "mirror policy does not evaluate candidates after success" $ do - let attempt "good" = pure (Right "good") - attempt _ = fail "unused mirror attempted" - result <- tryFetchUrlsWith attempt ("good" :| ["unused"]) - pure (assertEqual "first success" (Right "good" :: Either Text Text) result), - -- The per-URL retry policy, with its effects injected: upstream's five - -- attempts and doubling delay from 250 ms, spent on transient failures - -- only. - runTest "retry delay is upstream's 250 ms doubling, with jitter on the exponent" $ - assertEqual - "delays" - ([250, 500, 1000, 2000], 353, 2828) - ( map (\retry -> retryDelayMs defaultFetchRetryPolicy retry 0) [1 .. 4], - retryDelayMs defaultFetchRetryPolicy 1 0.5, - retryDelayMs defaultFetchRetryPolicy 4 0.5 - ), - runTestM "retry policy retries a transient failure with backoff until it succeeds" $ do - calls <- newIORef (0 :: Int) - sleeps <- newIORef [] - warnings <- newIORef [] - let effects = - RetryEffects - { reSleepMs = \ms -> atomicModifyIORef' sleeps (\seen -> (seen ++ [ms], ())), - reJitter = pure 0, - reWarn = \msg -> atomicModifyIORef' warnings (\seen -> (seen ++ [msg], ())) - } - attempt = do - n <- atomicModifyIORef' calls (\c -> (c + 1, c + 1)) - pure (if n < 3 then Left (Subst.TransientFailure "HTTP 503 fetching u") else Right ("verified" :: Text)) - result <- retryTransient defaultFetchRetryPolicy effects attempt - seenSleeps <- readIORef sleeps - seenWarnings <- readIORef warnings - pure - ( assertEqual - "two retries" - (Right "verified", [250, 500], ["HTTP 503 fetching u; retrying in 250 ms", "HTTP 503 fetching u; retrying in 500 ms"]) - (result, seenSleeps, seenWarnings) - ), - runTestM "retry policy gives up after five attempts" $ do - calls <- newIORef (0 :: Int) - sleeps <- newIORef [] - let effects = RetryEffects {reSleepMs = \ms -> atomicModifyIORef' sleeps (\seen -> (seen ++ [ms], ())), reJitter = pure 0, reWarn = \_ -> pure ()} - attempt = atomicModifyIORef' calls (\c -> (c + 1, ())) >> pure (Left (Subst.TransientFailure "timeout") :: Either Subst.AttemptFailure ()) - result <- retryTransient defaultFetchRetryPolicy effects attempt - seenCalls <- readIORef calls - seenSleeps <- readIORef sleeps - pure (assertEqual "spent" (Left (Subst.TransientFailure "timeout"), 5, [250, 500, 1000, 2000]) (result, seenCalls, seenSleeps)), - runTestM "retry policy does not retry a fatal failure" $ do - calls <- newIORef (0 :: Int) - let effects = RetryEffects {reSleepMs = \_ -> fail "slept on a fatal failure", reJitter = pure 0, reWarn = \_ -> fail "warned on a fatal failure"} - attempt = atomicModifyIORef' calls (\c -> (c + 1, ())) >> pure (Left (Subst.FatalFailure "HTTP 404") :: Either Subst.AttemptFailure ()) - result <- retryTransient defaultFetchRetryPolicy effects attempt - seenCalls <- readIORef calls - pure (assertEqual "once" (Left (Subst.FatalFailure "HTTP 404"), 1) (result, seenCalls)), - -- The classification tables, against upstream's (filetransfer.cc at - -- 2.24.9): which statuses and which client failures a retry can outlive. - runTest "status classification matches upstream's transfer layer" $ - let transient status = case fetchStatusFailure "u" status of - Subst.TransientFailure _ -> True - Subst.FatalFailure _ -> False - in assertEqual - "classes" - (replicate 6 True, replicate 10 False) - ( map transient [HTTP.status408, HTTP.status429, HTTP.status500, HTTP.status502, HTTP.status503, HTTP.status504], - map transient [HTTP.status404, HTTP.status410, HTTP.status401, HTTP.status403, HTTP.status407, HTTP.status400, HTTP.status418, HTTP.status501, HTTP.status505, HTTP.status511] - ), - runTest "status verdicts follow upstream's FileTransfer::Error, in its order" $ - assertEqual - "verdicts" - (replicate 2 NotFound ++ replicate 3 Forbidden ++ replicate 5 Misc ++ replicate 6 Transient) - ( map - statusError - [ HTTP.status404, - HTTP.status410, - HTTP.status401, - HTTP.status403, - HTTP.status407, - HTTP.status400, - HTTP.status418, - HTTP.status501, - HTTP.status505, - HTTP.status511, - HTTP.status408, - HTTP.status429, - HTTP.status500, - HTTP.status502, - HTTP.status503, - HTTP.status504 - ] - ), - runTest "exception classification retries transport failures only" $ - let transient err = case fetchExceptionFailure "u" err of - Subst.TransientFailure _ -> True - Subst.FatalFailure _ -> False - request = HTTP.defaultRequest - in assertEqual - "classes" - (replicate 4 True, replicate 4 False) - ( map - transient - [ HTTP.HttpExceptionRequest request HTTP.ConnectionTimeout, - HTTP.HttpExceptionRequest request (HTTP.ResponseBodyTooShort 100 5), - HTTP.HttpExceptionRequest request HTTP.ResponseTimeout, - HTTP.HttpExceptionRequest request (HTTP.InternalException (toException connectionReset)) - ], - map - transient - [ HTTP.InvalidUrlException "ftp://x" "Invalid scheme", - HTTP.HttpExceptionRequest request (HTTP.InvalidDestinationHost ""), - HTTP.HttpExceptionRequest request HTTP.TlsNotSupported, - HTTP.HttpExceptionRequest request (HTTP.TooManyRedirects []) - ] - ), - -- The attempt boundary: an IOException there is a failure writing - -- the output, and an asynchronous exception is never caught. - runTestM "a failure writing the download is fatal" $ do - outcome <- throwIO (userError "disk full") `catches` transferFailureHandlers "u" :: IO (Either Subst.AttemptFailure ()) - pure $ case outcome of - Left (Subst.FatalFailure _) -> Pass - other -> Fail ("expected a fatal failure, got: " <> T.pack (show other)), - runTestM "an interrupt passes through the attempt boundary untouched" $ do - outcome <- try (throwIO ThreadKilled `catches` transferFailureHandlers "u" :: IO (Either Subst.AttemptFailure ())) - pure $ case outcome of - Left err | fromException err == Just ThreadKilled -> Pass - other -> Fail ("expected ThreadKilled to propagate, got: " <> T.pack (show other)), - -- The body reader: the HTTP client wraps a failure opening the - -- response but not one reading its body, where a reset mid-body - -- arrives as a bare IOException. Read through transferBodyReader it - -- is a transport failure, retried like any other. - runTestM "a connection reset mid-body is a transport failure, not a failed write" $ do - let reader = transferBodyReader HTTP.defaultRequest (throwIO connectionReset) - outcome <- (Right <$> reader) `catches` transferFailureHandlers "u" - pure $ case outcome of - Left (Subst.TransientFailure _) -> Pass - other -> Fail ("expected a transient failure, got: " <> T.pack (show other)), - runTestM "the body reader passes the client's own failures and an interrupt through unchanged" $ do - let tooShort = HTTP.HttpExceptionRequest HTTP.defaultRequest (HTTP.ResponseBodyTooShort 100 5) - clientFailure <- try (transferBodyReader HTTP.defaultRequest (throwIO tooShort)) - interrupt <- try (transferBodyReader HTTP.defaultRequest (throwIO ThreadKilled)) - chunk <- transferBodyReader HTTP.defaultRequest (pure "bytes") - pure $ case (clientFailure, interrupt) of - (Left (HTTP.HttpExceptionRequest _ (HTTP.ResponseBodyTooShort 100 5)), Left ThreadKilled) - | chunk == "bytes" -> Pass - other -> Fail ("unexpected body reader outcomes: " <> T.pack (show (other, chunk))), - -- End to end against the loopback fixture, under a policy with a 1 ms - -- base delay: a torn transfer and a server error spend all five - -- attempts before the next mirror; a 404 and a hash mismatch spend one. - runTestM "HTTP mirrors retry a torn transfer, skip a missing or corrupt one, and stop on success" $ - httpCase "fallback" False ["/missing", "/bad", "/partial", "/good", "/unused"] True (["/missing", "/bad"] ++ replicate 5 "/partial" ++ ["/good"]), - runTestM "HTTP fetch retains single-url compatibility" $ - httpCase "legacy" True ["/good"] True ["/good"], - runTestM "a server error is retried five times before the next mirror" $ - httpCase "retried" False ["/error", "/good"] True (replicate 5 "/error" ++ ["/good"]), - runTestM "HTTP failure leaves no output or registration" $ - httpCase "errors" False ["/error", "/missing"] False (replicate 5 "/error" ++ ["/missing"]), - runTestM "hash failure leaves no corrupt output or registration" $ - httpCase "corrupt" False ["/bad", "/partial"] False ("/bad" : replicate 5 "/partial"), - runTestM "cancelling a download releases its lock and does not try another mirror" $ - withFetchurlServer $ \base requests requested -> - withStore "cancel" $ \store config sp -> do - let drv = fixtureDrv sp (Map.singleton "urls" (TE.encodeUtf8 (base <> "/slow " <> base <> "/good"))) - outcome <- timeout 10000000 $ - withAsync (buildDerivation config store drv) $ \worker -> do - requested - cancel worker - waitCatch worker - seen <- requests - valid <- isValid store sp - present <- Dir.doesPathExist (storePathToFilePath (stDir store) sp) - lock <- tryAcquirePathLock (stDir store) sp - mapM_ releasePathLock lock - pure $ case outcome of - Just (Left _) | seen == ["/slow"] && not valid && not present && isJust lock -> Pass - _ -> Fail ("cancellation failed: " <> T.pack (show (outcome, seen, valid, present, isJust lock))) - ] - where - hash = "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824" - -- What http-client 0.7's body reader raises when the server resets - -- the connection mid-body. - connectionReset = mkIOError resourceVanishedErrorType "Network.Socket.recvBuf" Nothing Nothing - withStore label action = do - tmpBase <- getTemporaryDirectory - let root = tmpBase ("nova-nix-test-mirrors-" ++ label) - dir = StoreDir (root "store") - config = (defaultBuildConfig dir) {bcTmpDir = root "build", bcFetchRetry = defaultFetchRetryPolicy {frpBaseDelayMs = 1}} - sp <- either (fail . show) pure (makeFixedOutputPath "mirrors" "sha256" "flat" (sha256Digest "hello")) - bracket_ (forceRemoveIfExists root) (forceRemoveIfExists root) $ - bracket (openStore dir) closeStore $ - \store -> action store config sp - fixtureDrv sp env = - Derivation - { drvOutputs = [DerivationOutput "out" sp "sha256" hash], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = "builtin:fetchurl", - drvArgs = [], - drvEnv = env - } - httpCase label legacy paths succeeds expectedRequests = - withFetchurlServer $ \base requests _ -> - withStore label $ \store config sp -> do - let urls = T.unwords (map (base <>) paths) - env = Map.singleton (if legacy then "url" else "urls") (TE.encodeUtf8 urls) - result <- buildDerivation config store (fixtureDrv sp env) - seen <- requests - valid <- isValid store sp - present <- Dir.doesPathExist (storePathToFilePath (stDir store) sp) - case result of - BuildSuccess _ - | succeeds && valid && present && seen == expectedRequests -> - assertEqual "verified output" "hello" <$> BS.readFile (storePathToFilePath (stDir store) sp) - BuildFailure msg _ | not succeeds && not valid && not present && seen == expectedRequests && not (T.null msg) -> pure Pass - _ -> pure (Fail (T.pack (show (result, seen, valid, present)))) - --- | The substituter's narinfo and NAR requests under the transfer --- layer's retry policy, against a loopback cache. The policy's effects --- are recorded rather than slept, so each case states the requests the --- cache saw and the backoff the policy chose. -testSubstituterRetry :: IO [Bool] -testSubstituterRetry = do - putStrLn "substituter/retry" - case signedNarInfo of - Left err -> (: []) <$> runTest "substituter retry setup" (Fail (T.pack err)) - Right (publicKey, narInfoText) -> - let narInfoOk = Send (httpResponse "200 OK" (TE.encodeUtf8 narInfoText)) - narOk = Send (httpResponse "200 OK" nar) - unavailable = Send (httpResponse "503 Service Unavailable" "") - substitute label narInfoReply narReply = - withHttpServer (route narInfoReply narReply) $ \base requests _ -> do - tmpBase <- getTemporaryDirectory - sleeps <- newIORef [] - warnings <- newIORef [] - let root = tmpBase ("nova-nix-test-subst-retry-" ++ label) - cache = Subst.CacheConfig base [publicKey] 40 - effects = - RetryEffects - { reSleepMs = \ms -> atomicModifyIORef' sleeps (\seen -> (seen ++ [ms], ())), - reJitter = pure 0, - reWarn = \msg -> atomicModifyIORef' warnings (\seen -> (seen ++ [msg], ())) - } - bracket_ (forceRemoveIfExists root) (forceRemoveIfExists root) $ - bracket (openStore (StoreDir root)) closeStore $ \store -> do - result <- Subst.trySubstituteWith defaultFetchRetryPolicy effects store [cache] sp - outcome <- case result of - Subst.SubstSuccess _ lock -> do - releasePathLock lock - Right <$> BS.readFile (storePathToFilePath (stDir store) sp "data") - other -> pure (Left other) - (,,,,) base outcome <$> requests <*> readIORef sleeps <*> readIORef warnings - in sequence $ - [ runTestM "a narinfo that fails once with a 503 is fetched on the retry" $ do - (base, outcome, seen, sleeps, warnings) <- - substitute "narinfo-503" (\earlier -> if earlier == 0 then unavailable else narInfoOk) (const narOk) - pure - ( assertEqual - "substituted after one retry" - (Right payload, [narInfoPath, narInfoPath, narPath], [250], ["HTTP 503 fetching " <> base <> "/" <> hash <> ".narinfo; retrying in 250 ms"]) - (outcome, seen, sleeps, warnings) - ), - runTestM "a narinfo that keeps failing spends upstream's five attempts and doubling delay" $ do - (_, outcome, seen, sleeps, _) <- substitute "narinfo-down" (const unavailable) (const narOk) - pure $ case outcome of - Left (Subst.SubstError _) -> assertEqual "attempts" (replicate 5 narInfoPath, [250, 500, 1000, 2000]) (seen, sleeps) - other -> Fail ("expected a substitution error, got: " <> T.pack (show other)), - runTestM "a NAR download answering 501 stops after one request" $ do - (_, outcome, seen, sleeps, _) <- - substitute "nar-501" (const narInfoOk) (const (Send (httpResponse "501 Not Implemented" ""))) - pure $ case outcome of - Left (Subst.SubstError err) - | "HTTP 501" `T.isInfixOf` err -> assertEqual "one request" ([narInfoPath, narPath], []) (seen, sleeps) - other -> Fail ("expected an HTTP 501 substitution error, got: " <> T.pack (show other)), - -- One attempt follows the client's redirect limit, then stops. - runTestM "a NAR redirect loop stops after one attempt" $ do - (_, outcome, seen, sleeps, _) <- - substitute "nar-redirect" (const narInfoOk) (const (Send "HTTP/1.1 302 Found\r\nLocation: /nar/retry.nar\r\nContent-Length: 0\r\nConnection: close\r\n\r\n")) - pure $ case outcome of - Left (Subst.SubstError err) - | "too many redirects" `T.isInfixOf` err -> - assertEqual "one attempt" (narInfoPath : replicate (HTTP.redirectCount HTTP.defaultRequest + 1) narPath, []) (seen, sleeps) - other -> Fail ("expected a redirect-loop substitution error, got: " <> T.pack (show other)), - runTestM "a torn NAR transfer is retried from its first byte" $ do - let torn = "HTTP/1.1 200 OK\r\nContent-Length: " <> TE.encodeUtf8 (T.pack (show (BS.length nar))) <> "\r\nConnection: close\r\n\r\n" <> BS.take 10 nar - (base, outcome, seen, sleeps, warnings) <- - substitute "nar-torn" (const narInfoOk) (\earlier -> if earlier == 0 then Send torn else narOk) - let warnedTorn = case warnings of - [warning] -> ("download error fetching " <> base <> "/nar/retry.nar: ResponseBodyTooShort") `T.isPrefixOf` warning - _ -> False - pure $ - if warnedTorn - then assertEqual "substituted after one retry" (Right payload, [narInfoPath, narPath, narPath], [250]) (outcome, seen, sleeps) - else Fail ("unexpected warnings: " <> T.pack (show warnings)) - ] - -- Upstream's NotFound and Forbidden: a binary cache store - -- reads both as the file not being in that cache. - ++ [ runTestM ("a narinfo answered " <> status <> " is a miss, not retried") $ do - (_, outcome, seen, sleeps, _) <- - substitute ("narinfo-" ++ statusCode status) (const (Send (httpResponse (TE.encodeUtf8 status) ""))) (const narOk) - pure (assertEqual "miss" (Left Subst.SubstNotFound, [narInfoPath], []) (outcome, seen, sleeps)) - | status <- notInCache - ] - -- A NAR the narinfo named and the cache no longer holds is - -- upstream's SubstituteGone: one request, never retried. - ++ [ runTestM ("a NAR answered " <> status <> " stops after one request") $ do - (_, outcome, seen, sleeps, _) <- - substitute ("nar-" ++ statusCode status) (const narInfoOk) (const (Send (httpResponse (TE.encodeUtf8 status) ""))) - pure $ case outcome of - Left (Subst.SubstError _) -> assertEqual "one request" ([narInfoPath, narPath], []) (seen, sleeps) - other -> Fail ("expected a substitution error, got: " <> T.pack (show other)) - | status <- notInCache - ] - where - notInCache :: [Text] - notInCache = ["404 Not Found", "410 Gone", "401 Unauthorized", "403 Forbidden", "407 Proxy Authentication Required"] - statusCode = T.unpack . T.take 3 - hash = T.replicate 32 "b" - sp = StorePath hash "retry" - narInfoPath = "/" <> TE.encodeUtf8 hash <> ".narinfo" - narPath = "/nar/retry.nar" - payload = "retried payload\n" - nar = NAR.serialise (NAR.NarDirectory [("data", NAR.NarRegular False payload)]) - unsigned = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/" <> hash <> "-retry", - NarInfo.niUrl = "nar/retry.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, - NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes nar), - NarInfo.niNarSize = fromIntegral (BS.length nar), - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - signedNarInfo = do - secretKey <- Signing.parseSecretKey sigTestKeyText - publicKey <- Signing.toPublicKey secretKey - sig <- Signing.sign secretKey unsigned - pure (Signing.renderPublicKey publicKey, NarInfo.renderNarInfo unsigned {NarInfo.niSigs = [sig]}) - route narInfoReply narReply path earlier - | path == narInfoPath = narInfoReply earlier - | path == narPath = narReply earlier - | otherwise = Send (httpResponse "500 Internal Server Error" "unexpected request") - --- | @pkgs/windows/fetchurl.nix@ evaluated from the checkout. The --- @mirror://@ expansion is what a source derivation records, so a --- mirrors.nix refresh or a regex edit moves every drvPath built on it; --- these pin the list against nixpkgs' order and the eval-time errors. -testPkgsFetchurl :: IO [Bool] -testPkgsFetchurl = do - putStrLn "pkgs/fetchurl" - cwd <- Dir.getCurrentDirectory - let fetchurl = "(import " <> nixQuotedPath (cwd "pkgs" "windows" "fetchurl.nix") <> ")" - urlsOf source = "builtins.concatStringsSep \"\\n\" (" <> fetchurl <> " { " <> source <> " sha256 = \"" <> hash <> "\"; }).urls" - failsWith expected result = case result of - Left err - | expected `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected an error naming " <> expected <> ", got: " <> err) - Right val -> Fail ("expected an eval error, got: " <> T.pack (show val)) - sequence - [ runTestIO - "mirror://gnu expands to the https hosts of mirrors.nix, in nixpkgs' order" - cwd - (urlsOf "url = \"mirror://gnu/hello/hello-2.12.3.tar.gz\";") - (mkStr (T.intercalate "\n" (map (<> "hello/hello-2.12.3.tar.gz") gnuHosts))), - runTestIO - "a plain URL in urls passes through beside an expanded one" - cwd - (urlsOf "urls = [ \"https://example.invalid/sed-4.10.tar.xz\" \"mirror://gnu/sed/sed-4.10.tar.xz\" ];") - (mkStr (T.intercalate "\n" ("https://example.invalid/sed-4.10.tar.xz" : map (<> "sed/sed-4.10.tar.xz") gnuHosts))), - runTestM "an unknown mirror site is an eval error naming the recipe's URL" $ - failsWith "fetchurl: unknown mirror site 'nope' in 'mirror://nope/x'" <$> evalNixIO cwd (urlsOf "url = \"mirror://nope/x\";"), - runTestM "a mirror URL with no path is an eval error" $ - failsWith "fetchurl: malformed mirror URL 'mirror://gnu'" <$> evalNixIO cwd (urlsOf "url = \"mirror://gnu\";") - ] - where - hash :: Text - hash = "0d5f60154382fee10b114a1c34e785d8b1f492073ae2d3a6f7b147687b366aa0" - -- The gnu set of pkgs/windows/mirrors.nix without its ftp:// host. - gnuHosts :: [Text] - gnuHosts = - [ "https://ftpmirror.gnu.org/", - "https://ftp.nluug.nl/pub/gnu/", - "https://mirrors.kernel.org/gnu/", - "https://mirror.ibcp.fr/pub/gnu/", - "https://mirror.dogado.de/gnu/", - "https://mirror.tochlab.net/pub/gnu/", - "https://ftp.gnu.org/pub/gnu/" - ] - -testFetchGitTransport :: IO [Bool] -testFetchGitTransport = do - putStrLn "eval/fetchgit-transport" - sequence - [ runTest "allowed schemes pass" $ - assertEqual - "schemes" - [ Right "https://example.com/repo.git", - Right "http://example.com/repo.git", - Right "ssh://git@example.com/repo.git", - Right "git://example.com/repo.git", - Right "file:///srv/repo" - ] - ( map - checkGitUrl - [ "https://example.com/repo.git", - "http://example.com/repo.git", - "ssh://git@example.com/repo.git", - "git://example.com/repo.git", - "file:///srv/repo" - ] - ), - runTest "scheme match is case-insensitive" $ - assertEqual "upper" (Right "HTTPS://example.com/r") (checkGitUrl "HTTPS://example.com/r"), - runTest "scp-like remotes and local paths pass" $ - assertEqual - "plain" - [ Right "git@github.com:owner/repo.git", - Right "user@[::1]:repo", - Right "/srv/repo", - Right "./repo", - Right "C:\\src\\repo" - ] - ( map - checkGitUrl - [ "git@github.com:owner/repo.git", - "user@[::1]:repo", - "/srv/repo", - "./repo", - "C:\\src\\repo" - ] - ), - runTest "helper transports are rejected" $ - let rejected = ["ext::sh -c 'printf x'", "fd::17", "my-helper_2::payload", "::payload"] - in case [url | url <- rejected, either (const False) (const True) (checkGitUrl url)] of - [] -> Pass - slipped -> Fail ("helper urls accepted: " <> T.pack (show slipped)), - runTest "an unknown explicit scheme is rejected" $ - assertLeft "hg scheme" (checkGitUrl "hg://example.com/repo"), - runTest "the empty url is rejected" $ - assertLeft "empty" (checkGitUrl ""), - runTestM "fetchGit refuses a helper transport at eval time" $ do - outcome <- evalNixIO "." "builtins.fetchGit { url = \"ext::printf x\"; }" - pure $ case outcome of - Left err - | "transport" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "helper transport url evaluated", - -- A ref reaching git as an option is command execution: git parses - -- options after the remote name, and --upload-pack names the - -- transport command. The leading-character class is what stops it. - runTest "a ref that git would read as an option is rejected" $ - let rejected = - [ "--upload-pack=touch /tmp/pwned", - "-o", - "--exec=sh", - "", - "branch with spaces", - "semi;colon", - "back\\slash" - ] - in case [ref | ref <- rejected, either (const False) (const True) (checkGitRef ref)] of - [] -> Pass - slipped -> Fail ("refs accepted: " <> T.pack (show slipped)), - runTest "ordinary ref names are accepted" $ - let accepted = ["main", "HEAD", "release/1.0", "v2.3.4", "user/topic-1", "@", "a+b"] - in case [ref | ref <- accepted, either (const True) (const False) (checkGitRef ref)] of - [] -> Pass - refused -> Fail ("refs refused: " <> T.pack (show refused)), - runTest "a rev must be a full SHA-1" $ - let rejected = - [ "--upload-pack=touch /tmp/pwned", - "dcb93b58", - "v1.0", - "main", - "", - T.replicate 40 "g", - T.replicate 41 "a" - ] - in case [rev | rev <- rejected, either (const False) (const True) (checkGitRev rev)] of - [] -> Pass - slipped -> Fail ("revs accepted: " <> T.pack (show slipped)), - runTest "a full SHA-1 is accepted in either case" $ - let accepted = [T.replicate 40 "a", T.replicate 40 "F", "dcb93b58bd982ab64323bac2a8c11b138d6b55e5"] - in case [rev | rev <- accepted, either (const True) (const False) (checkGitRev rev)] of - [] -> Pass - refused -> Fail ("revs refused: " <> T.pack (show refused)), - runTestM "fetchGit refuses an option-shaped ref at eval time" $ do - outcome <- evalNixIO "." "builtins.fetchGit { url = \"/srv/repo\"; ref = \"--upload-pack=id\"; }" - pure $ case outcome of - Left err - | "ref is not a valid git ref name" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "option-shaped ref evaluated" - ] - --- --------------------------------------------------------------------------- --- builtins.fetchGit against a real repository --- --------------------------------------------------------------------------- - --- | One git command against a fixture repository, identity and signing --- pinned so no host configuration participates. Nonzero exit throws --- with git's stderr, failing the calling test loudly. -fixtureGit :: FilePath -> [String] -> IO Text -fixtureGit dir args = do - (code, out, errOut) <- - Proc.readCreateProcessWithExitCode - (Proc.proc "git" (["-C", dir, "-c", "user.name=nova-nix-test", "-c", "user.email=test@nova-nix.invalid", "-c", "commit.gpgsign=false", "-c", "core.autocrlf=false"] ++ args)) - "" - case code of - ExitSuccess -> pure (T.strip (T.pack out)) - ExitFailure n -> fail ("fixture git " ++ unwords args ++ " exited " ++ show n ++ ": " ++ errOut) - --- | A repository whose history is one commit per given file, oldest --- first; returns the commit SHAs in that order. SHA wants are enabled --- up front: a pinned rev that is no branch tip is only fetchable when --- the serving side allows it, the same opt-in real servers use. -makeGitFixture :: FilePath -> [(FilePath, Text)] -> IO [Text] -makeGitFixture dir files = do - Dir.createDirectoryIfMissing True dir - _ <- fixtureGit dir ["init", "--quiet"] - _ <- fixtureGit dir ["config", "uploadpack.allowAnySHA1InWant", "true"] - mapM commitOne files - where - commitOne (name, contents) = do - BS.writeFile (dir name) (TE.encodeUtf8 contents) - _ <- fixtureGit dir ["add", "-A"] - _ <- fixtureGit dir ["commit", "--quiet", "-m", name] - fixtureGit dir ["rev-parse", "HEAD"] - --- | 'evalNixIO' against an explicit store directory, for expressions --- whose evaluation writes store objects. -evalNixIOStore :: StoreDir -> FilePath -> Text -> IO (Either Text NixValue) -evalNixIOStore storeDir baseDir source = case parseNix baseDir "" source of - Left err -> pure (Left (T.pack (show err))) - Right expr -> do - st <- newEvalState storeDir baseDir - runEvalIO st (eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr) - -testFetchGitShallow :: IO [Bool] -testFetchGitShallow = do - tmpBase <- getTemporaryDirectory - let repoDir = tmpBase "nova-nix-test-fetchgit-repo" - tmpStore = tmpBase "nova-nix-test-fetchgit-store" - cacheHome = tmpBase "nova-nix-test-fetchgit-cache" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - urlAttr = "url = \"" <> nixEscape (T.pack repoDir) <> "\"; " - evalFetch extra = evalNixIOStore (StoreDir tmpStore) "." ("builtins.fetchGit { " <> urlAttr <> extra <> "}") - forceRemoveIfExists repoDir - forceRemoveIfExists tmpStore - forceRemoveIfExists cacheHome - -- The fetch cache writes under XdgCache; point it at the scratch area - -- for the duration so the suite never touches the developer's cache. - savedCacheHome <- lookupEnv "XDG_CACHE_HOME" - setEnv "XDG_CACHE_HOME" cacheHome - shas <- makeGitFixture repoDir [("first.txt", "one\n"), ("second.txt", "two\n"), ("third.txt", "three\n")] - results <- - sequence - [ -- Upstream reports revCount 0 under shallow, not an absent - -- attribute and not the fetch depth: observed from - -- nix-instantiate 2.33.2, where '.revCount or "ABSENT"' is 0. - -- The tree itself is depth-independent, so both fetches must - -- agree on narHash and outPath. - runTestM "a shallow fetch reports revCount 0 for the same tree" $ do - fullOutcome <- evalFetch "" - shallowOutcome <- evalFetch "shallow = true; " - pure $ case (fullOutcome, shallowOutcome) of - (Left err, _) -> Fail ("full fetch failed: " <> err) - (_, Left err) -> Fail ("shallow fetch failed: " <> err) - (Right fullVal, Right shallowVal) -> - let fullFields = fetchGitFields fullVal ["revCount", "narHash", "outPath"] - shallowFields = fetchGitFields shallowVal ["revCount", "narHash", "outPath"] - in case (fullFields, shallowFields) of - ([("revCount", VInt 3), ("narHash", fullHash), ("outPath", fullPath)], [("revCount", VInt 0), ("narHash", shallowHash), ("outPath", shallowPath)]) - | fullHash == shallowHash && fullPath == shallowPath -> Pass - | otherwise -> Fail "shallow and full fetches disagree about the tree" - _ -> Fail (T.pack (show (fullFields, shallowFields))), - -- The rev itself is the refspec, so a depth-1 fetch of a rev - -- that is not the branch tip still lands on exactly that rev. - runTestM "a shallow fetch of a pinned rev checks out that rev" $ case shas of - (firstSha : _) -> do - outcome <- evalFetch ("shallow = true; rev = \"" <> firstSha <> "\"; ") - case outcome of - Left err -> pure (Fail err) - Right val -> case fetchGitFields val ["rev", "revCount", "outPath"] of - [("rev", revVal), ("revCount", VInt 0), ("outPath", VPath outText)] - | revVal == mkStr firstSha -> do - let outDir = storeTextToFilePath (StoreDir tmpStore) outText - firstThere <- Dir.doesFileExist (outDir "first.txt") - thirdThere <- Dir.doesFileExist (outDir "third.txt") - pure $ - if firstThere && not thirdThere - then Pass - else Fail "outPath does not hold the pinned rev's tree" - fields -> pure (Fail (T.pack (show fields))) - [] -> pure (Fail "fixture returned no commits"), - -- Pinned and unpinned differ in where counting starts: from the - -- rev, the root commit counts 1 (upstream 2.33.2 agrees), not - -- the branch's 3. - runTestM "a pinned rev fetch counts from the rev" $ case shas of - (firstSha : _) -> do - outcome <- evalFetch ("rev = \"" <> firstSha <> "\"; ") - pure $ case outcome of - Left err -> Fail err - Right val -> case fetchGitFields val ["rev", "revCount"] of - [("rev", revVal), ("revCount", VInt 1)] - | revVal == mkStr firstSha -> Pass - fields -> Fail (T.pack (show fields)) - [] -> pure (Fail "fixture returned no commits") - ] - maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome - forceRemoveIfExists repoDir - forceRemoveIfExists tmpStore - forceRemoveIfExists cacheHome - pure results - --- | The fetchGit completeness remainder (#77): unsupported attributes --- refuse, a declared narHash pins the tree on hit and fresh paths --- alike, allRefs widens the fetch, and a failing fetch leaves no --- scratch clone behind. -testFetchGitPins :: IO [Bool] -testFetchGitPins = do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-pins-store" - repoDir = tmpBase "nova-nix-test-pins-repo" - cacheHome = tmpBase "nova-nix-test-pins-cache" - urlText = T.concatMap (\c -> if c == '\\' then "\\\\" else T.singleton c) (T.pack repoDir) - evalHere = evalNixIOStore (StoreDir tmpStore) "." - fetchWith extra = evalHere ("builtins.fetchGit { url = \"" <> urlText <> "\"; " <> extra <> "}") - forceRemoveIfExists tmpStore - forceRemoveIfExists repoDir - forceRemoveIfExists cacheHome - savedCacheHome <- lookupEnv "XDG_CACHE_HOME" - setEnv "XDG_CACHE_HOME" cacheHome - shas <- makeGitFixture repoDir [("a.txt", "one\n")] - baseBranch <- fixtureGit repoDir ["rev-parse", "--abbrev-ref", "HEAD"] - _ <- fixtureGit repoDir ["checkout", "-q", "-b", "side"] - BS.writeFile (repoDir "side.txt") (TE.encodeUtf8 "side\n") - _ <- fixtureGit repoDir ["add", "-A"] - _ <- fixtureGit repoDir ["commit", "--quiet", "-m", "side"] - sideSha <- fixtureGit repoDir ["rev-parse", "HEAD"] - _ <- fixtureGit repoDir ["checkout", "-q", T.unpack baseBranch] - results <- - sequence - [ runTestM "an unsupported fetchGit attribute is refused" $ do - outcome <- fetchWith "bogus = 1; " - pure $ case outcome of - Left err - | "attribute 'bogus' not supported" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "an unsupported attribute was silently dropped", - runTestM "a mismatched narHash pin is an error" $ case shas of - (sha : _) -> do - outcome <- fetchWith ("rev = \"" <> sha <> "\"; narHash = \"sha256-" <> T.replicate 43 "A" <> "=\"; ") - pure $ case outcome of - Left err - | "NAR hash mismatch" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "a bogus narHash pin was silently ignored" - [] -> pure (Fail "fixture returned no commits"), - -- The second fetch of the same rev is a cache hit, so a matching - -- pin passing here proves the check runs on the hit path too. - runTestM "a matching narHash pin passes, including on a cache hit" $ case shas of - (sha : _) -> do - first <- fetchWith ("rev = \"" <> sha <> "\"; ") - case first of - Left err -> pure (Fail err) - Right val -> case fetchGitFields val ["narHash"] of - [("narHash", VStr hashBytes _)] -> do - let hash = TE.decodeUtf8Lenient hashBytes - second <- fetchWith ("rev = \"" <> sha <> "\"; narHash = \"" <> hash <> "\"; ") - pure $ case second of - Right _ -> Pass - Left err -> Fail ("a correct pin was refused: " <> err) - other -> pure (Fail (T.pack (show other))) - [] -> pure (Fail "fixture returned no commits"), - runTestM "allRefs finds a rev on an unfetched branch" $ do - outcome <- fetchWith ("rev = \"" <> sideSha <> "\"; allRefs = true; ") - pure $ case outcome of - Left err -> Fail err - Right val -> case fetchGitFields val ["rev"] of - [("rev", revVal)] | revVal == mkStr sideSha -> Pass - other -> Fail (T.pack (show other)), - runTestM "a failing fetch leaves no scratch clone behind" $ do - before <- filter ("nova-nix-fetchgit-" `T.isPrefixOf`) . map T.pack <$> Dir.listDirectory tmpBase - outcome <- evalHere ("builtins.fetchGit { url = \"" <> urlText <> "-no-such-repo\"; }") - after <- filter ("nova-nix-fetchgit-" `T.isPrefixOf`) . map T.pack <$> Dir.listDirectory tmpBase - pure $ case outcome of - Right _ -> Fail "a fetch of a missing repo succeeded" - Left _ - | length after == length before -> Pass - | otherwise -> Fail ("scratch clones leaked: " <> T.pack (show (length after - length before))) - ] - maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome - forceRemoveIfExists tmpStore - forceRemoveIfExists repoDir - forceRemoveIfExists cacheHome - pure results - --- | String interpolation inside path literals (#178), the construct --- nixpkgs uses 89 times on modern trees. Every rule here is pinned to --- nix-instantiate 2.33.2's observed behavior: the result is a path, --- pieces concatenate with no separator and canonicalize textually, a --- path segment coerces without a store copy, context is refused, and --- a trailing slash is a parse error. -testPathInterp :: IO [Bool] -testPathInterp = do - tmpBase <- getTemporaryDirectory - let fixtureDir = tmpBase "nova-nix-test-path-interp" - tmpStore = tmpBase "nova-nix-test-path-interp-store" - forceRemoveIfExists fixtureDir - forceRemoveIfExists tmpStore - Dir.createDirectoryIfMissing True (fixtureDir "sub") - BS.writeFile (fixtureDir "sub" "f.nix") (TE.encodeUtf8 "42") - let evalHere = evalNixIO fixtureDir - baseText = canonPathValue (T.pack fixtureDir) - results <- - sequence - [ runTestM "an interpolated path literal is a path" $ do - outcome <- evalHere "let v = \"sub\"; in builtins.typeOf ./${v}" - pure (assertRightValue outcome (mkStr "path")), - runTestM "a runtime dot-dot canonicalizes textually" $ do - outcome <- evalHere "let v = \"sub/..\"; in toString ./${v}" - pure (assertRightValue outcome (mkStr baseText)), - runTestM "pieces concatenate with no separator, mid-segment included" $ do - outcome <- evalHere "let v = \"a\"; in toString ./pre${v}${v}post" - pure (assertRightValue outcome (mkStr (baseText <> "/preaapost"))), - runTestM "an empty segment after the root is the root" $ do - outcome <- evalHere "toString /${\"\"}" - pure (assertRightValue outcome (mkStr "/")), - runTestM "a dotless relative literal interpolates" $ do - outcome <- evalHere "let v = \"f.nix\"; in toString sub/${v}" - pure (assertRightValue outcome (mkStr (baseText <> "/sub/f.nix"))), - runTestM "a path segment must coerce to a string" $ do - outcome <- evalHere "./${1}" - pure $ case outcome of - Left err - | "cannot coerce an integer to a string" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "an integer segment was accepted", - -- A path INSIDE a path interpolation appends its absolute text - -- with no store copy (string interpolation would copy) - - -- upstream's exact, odd, observable behavior. The expected text - -- goes through the canonicalizer because the separator between - -- the two halves is platform-shaped: on POSIX the inner path's - -- own leading slash serves, on Windows (C:...) the head's slash - -- survives instead. - runTestM "a path segment appends textually without a store copy" $ do - outcome <- evalHere "toString ./${./sub}" - pure (assertRightValue outcome (mkStr (canonPathValue (baseText <> "/" <> baseText <> "/sub")))), - runTestM "a context-carrying segment is refused" $ do - outcome <- evalNixIOStore (StoreDir tmpStore) fixtureDir "./${builtins.toFile \"n\" \"x\"}" - pure $ case outcome of - Left err - | "cannot be appended to a path" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "a store-path segment was accepted", - runTestM "a trailing slash is a parse error" $ do - outcome <- evalHere "let v = \"a\"; in ./sub/${v}/" - pure $ case outcome of - Left err - | "path has a trailing slash" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "a trailing slash parsed", - runTestM "a plain trailing-slash literal is a parse error" $ do - outcome <- evalHere "./sub/" - pure $ case outcome of - Left err - | "path has a trailing slash" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("wrong error: " <> err) - Right _ -> Fail "a trailing slash parsed", - runTestM "import resolves an interpolated dot-dot path" $ do - outcome <- evalHere "let v = \"sub\"; in import ./${v}/../sub/f.nix" - pure (assertRightValue outcome (VInt 42)), - -- An spath followed by /${...} is NOT one literal: it parses as - -- application of the search path to a path, which fails at - -- eval - upstream's exact shape. - runTestM "a search path does not absorb an interpolation" $ do - outcome <- evalHere "let v = \"a\"; in /${v}" - pure $ case outcome of - Left _ -> Pass - Right val -> Fail ("spath absorbed the interpolation: " <> T.pack (show val)) - ] - forceRemoveIfExists fixtureDir - forceRemoveIfExists tmpStore - pure results - where - assertRightValue outcome expected = case outcome of - Right val | val == expected -> Pass - other -> Fail (T.pack (show other)) - --- | A path reached through an attrset's @outPath@ (or a @__toString@ --- result) coerces exactly as the same path written directly: copied to --- the store, with the store path in the string context. The broken --- shape rendered the raw filesystem path with no copy and no context, --- so @src = builtins.fetchGit { ... }@ produced empty inputSrcs and a --- drvPath diverging from upstream, while the @.outPath@ spelling --- worked. Verified against nix-instantiate 2.33.2: the attrset form's --- drvPath now matches upstream byte for byte. -testOutPathCoercion :: IO [Bool] -testOutPathCoercion = do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-outpath-store" - srcDir = tmpBase "nova-nix-test-outpath-src" - cacheHome = tmpBase "nova-nix-test-outpath-cache" - repoDir = tmpBase "nova-nix-test-outpath-repo" - -- A RELATIVE path literal resolved against the eval's base dir: an - -- absolute Windows path (C:/...) is not a path literal at all - it - -- matches the URI rule (scheme:rest) and lexes as a string, which - -- correctly never copies. Relative spelling lexes as a path on - -- every platform. - srcLiteral = "./nova-nix-test-outpath-src" :: Text - drvPathWith srcExpr = - "(derivation { name = \"ctx-probe\"; system = \"x86_64-linux\"; " - <> "builder = \"/bin/sh\"; args = [\"-c\" \"echo ok > $out\"]; " - <> "src = " - <> srcExpr - <> "; }).drvPath" - evalHere = evalNixIOStore (StoreDir tmpStore) tmpBase - storeStr result = case result of - Right (VStr s _) -> Just (TE.decodeUtf8Lenient s) - _ -> Nothing - forceRemoveIfExists tmpStore - forceRemoveIfExists srcDir - forceRemoveIfExists cacheHome - forceRemoveIfExists repoDir - Dir.createDirectoryIfMissing True srcDir - BS.writeFile (srcDir "f.txt") (TE.encodeUtf8 "content\n") - savedCacheHome <- lookupEnv "XDG_CACHE_HOME" - setEnv "XDG_CACHE_HOME" cacheHome - gitShas <- makeGitFixture repoDir [("g.txt", "tracked\n")] - results <- - sequence - [ runTestM "an outPath attrset src derives the same drv as its path" $ do - attrForm <- evalHere (drvPathWith ("{ outPath = " <> srcLiteral <> "; }")) - pathForm <- evalHere (drvPathWith srcLiteral) - pure $ case (attrForm, pathForm) of - (Right a, Right b) - | a == b -> Pass - | otherwise -> Fail (T.pack (show (a, b))) - other -> Fail (T.pack (show other)), - runTestM "a fetchGit src derives the same drv as its outPath" $ case gitShas of - (sha : _) -> do - let fetch = "builtins.fetchGit { url = \"" <> T.concatMap (\c -> if c == '\\' then "\\\\" else T.singleton c) (T.pack repoDir) <> "\"; rev = \"" <> sha <> "\"; }" - attrForm <- evalHere (drvPathWith fetch) - outPathForm <- evalHere (drvPathWith ("(" <> fetch <> ").outPath")) - pure $ case (attrForm, outPathForm) of - (Right a, Right b) - | a == b -> Pass - | otherwise -> Fail (T.pack (show (a, b))) - other -> Fail (T.pack (show other)) - [] -> pure (Fail "fixture returned no commits"), - -- Text-only assertions here and below: a source copy is - -- materialized by the build driver, not by a bare eval, so the - -- observable at eval time is the store-path spelling. The two - -- drvPath tests above cover the context end (an uncontexted src - -- would derive a different drv). - runTestM "interpolating an outPath attrset coerces to its store path" $ do - outcome <- evalHere ("\"${ { outPath = " <> srcLiteral <> "; } }\"") - pure $ case storeStr outcome of - Just text | isCanonicalStoreText text -> Pass - _ -> Fail (T.pack (show outcome)), - runTestM "a __toString path result coerces to its store path" $ do - outcome <- evalHere ("\"${ { __toString = self: " <> srcLiteral <> "; } }\"") - pure $ case storeStr outcome of - Just text | isCanonicalStoreText text -> Pass - _ -> Fail (T.pack (show outcome)), - runTestM "adding an outPath attrset to a string coerces to its store path" $ do - outcome <- evalHere ("\"src: \" + { outPath = " <> srcLiteral <> "; }") - pure $ case storeStr outcome of - Just text | Just rest <- T.stripPrefix "src: " text, isCanonicalStoreText rest -> Pass - _ -> Fail (T.pack (show outcome)), - runTestM "toJSON of an outPath attrset is its store path" $ do - outcome <- evalHere ("builtins.toJSON { outPath = " <> srcLiteral <> "; }") - pure $ case storeStr outcome of - Just text - | Just inner <- T.stripPrefix "\"" text >>= T.stripSuffix "\"", - isCanonicalStoreText inner -> - Pass - _ -> Fail (T.pack (show outcome)) - ] - maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome - forceRemoveIfExists tmpStore - forceRemoveIfExists srcDir - forceRemoveIfExists cacheHome - forceRemoveIfExists repoDir - pure results - -testScratchDirs :: IO [Bool] -testScratchDirs = do - putStrLn "eval/scratch-dirs" - st <- newEvalState platformStoreDir "." - sequence - [ runTestM "scratch dirs are distinct, real, and removable" $ do - createdA <- runEvalIO st (createScratchDir "nova-nix-test-scratch-") - createdB <- runEvalIO st (createScratchDir "nova-nix-test-scratch-") - case (createdA, createdB) of - (Right dirA, Right dirB) - | dirA == dirB -> pure (Fail "two scratch dirs share a name") - | otherwise -> do - existedA <- Dir.doesDirectoryExist (T.unpack dirA) - existedB <- Dir.doesDirectoryExist (T.unpack dirB) - removed <- runEvalIO st (removeScratchDir dirA >> removeScratchDir dirB) - goneA <- not <$> Dir.doesDirectoryExist (T.unpack dirA) - goneB <- not <$> Dir.doesDirectoryExist (T.unpack dirB) - pure $ case removed of - Left err -> Fail ("removeScratchDir failed: " <> err) - Right () - | existedA && existedB && goneA && goneB -> Pass - | otherwise -> Fail "scratch dir lifecycle out of order" - (Left err, _) -> pure (Fail ("createScratchDir failed: " <> err)) - (_, Left err) -> pure (Fail ("createScratchDir failed: " <> err)), - runTestM "scratch names carry the requested prefix" $ do - created <- runEvalIO st (createScratchDir "nova-nix-test-scratch-") - case created of - Left err -> pure (Fail ("createScratchDir failed: " <> err)) - Right dir -> do - removed <- runEvalIO st (removeScratchDir dir) - pure $ case removed of - Left err -> Fail ("removeScratchDir failed: " <> err) - Right () - | "nova-nix-test-scratch-" `T.isInfixOf` dir -> Pass - | otherwise -> Fail ("prefix missing from: " <> dir) - ] - -testNarKnownAnswer :: IO [Bool] -testNarKnownAnswer = do - putStrLn "nar/known-answer" - sequence - [ runTest "serialise matches the hand-written spec vector" $ - if NAR.serialise narSpecTree == narSpecVector - then Pass - else Fail "NAR encoder no longer matches the spec byte layout", - runTest "deserialise reads the spec vector back" $ - case NAR.deserialise narSpecVector of - Right entry - | NAR.serialise entry == narSpecVector -> Pass - | otherwise -> Fail "spec vector round-trips to different bytes" - Left err -> Fail ("spec vector rejected: " <> T.pack err), - -- The empty-input SHA-256 in nix-base32: pins digest, alphabet, and - -- bit order against the value real Nix computes. - runTest "sha256 empty formats to the known nix-base32 vector" $ - assertEqual - "nix32-empty" - "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" - (CHash.formatNixHash (CHash.hashBytes BS.empty)), - -- addToStore must record exactly the hash of the spec bytes for the - -- same tree, or interop with every real cache silently breaks. - runTestM "addToStore records the externally-computed NAR hash" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-nar-vector-src" - tmpStore = tmpBase "nova-nix-test-nar-vector-store" - forceRemoveIfExists srcDir - forceRemoveIfExists tmpStore - createDirectoryIfMissing True srcDir - createDirectoryIfMissing True tmpStore - BS.writeFile (srcDir "data.txt") "hello\n" - store <- openStore (StoreDir tmpStore) - let sp = StorePath (T.replicate 32 "e") "nar-vector" - addToStore store srcDir sp Nothing [] - recorded <- queryPathInfo (stDB store) sp - closeStore store - forceRemoveIfExists tmpStore - let expected = CHash.formatNixHash (CHash.hashBytes narSpecFileVector) - pure $ case recorded of - Just info -> assertEqual "recorded NarHash" expected (piNarHash info) - Nothing -> Fail "path not registered" - ] - --- | store delete: row-and-tree removal with referrer refusal. The raw --- basename channel exists for rows the current name rules reject; the --- legacy-row case plants one over SQL exactly as a pre-name-rules store --- carries it. -testStoreDelete :: IO [Bool] -testStoreDelete = do - putStrLn "store/delete" - withTempStore $ \store -> do - let sd = stDir store - basenameOf sp = spHash sp <> "-" <> spName sp - dep = StorePath (T.replicate 32 "a") "del-dep" - user = StorePath (T.replicate 32 "b") "del-user" - sequence - [ runTestM "referenced path is refused with its referrers listed" $ do - registerPaths - (stDB store) - [ PathRegistration dep "sha256:d" 1 Nothing [], - PathRegistration user "sha256:u" 1 Nothing [dep] - ] - outcome <- deleteStorePathRaw store (basenameOf dep) - stillValid <- isValid store dep - pure $ case outcome of - Left err - | "referenced by" `T.isInfixOf` err, - T.pack (storePathToFilePath sd user) `T.isInfixOf` err, - stillValid -> - Pass - | otherwise -> Fail ("wrong refusal: " <> err) - Right removed -> Fail ("deleted a referenced path: " <> T.pack (show removed)), - runTestM "a reference chain deletes leaf-first" $ do - userGone <- deleteStorePathRaw store (basenameOf user) - depGone <- deleteStorePathRaw store (basenameOf dep) - depValid <- isValid store dep - userValid <- isValid store user - pure $ case (userGone, depGone) of - (Right _, Right _) - | not depValid && not userValid -> Pass - | otherwise -> Fail "rows survived deletion" - other -> Fail ("chain deletion failed: " <> T.pack (show other)), - runTestM "a registered row without a tree deletes (repair case)" $ do - let ghost = StorePath (T.replicate 32 "c") "del-ghost" - registerPath (stDB store) (PathRegistration ghost "sha256:g" 1 Nothing []) - outcome <- deleteStorePathRaw store (basenameOf ghost) - pure $ case outcome of - Right removed - | doRowRemoved removed && not (doTreeRemoved removed) -> Pass - | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) - Left err -> Fail err, - runTestM "an unregistered tree deletes (repair case)" $ do - let strayBase = T.replicate 32 "d" <> "-del-stray" - treePath = unStoreDir sd T.unpack strayBase - createDirectoryIfMissing True treePath - TIO.writeFile (treePath "junk.txt") "stray" - outcome <- deleteStorePathRaw store strayBase - gone <- not <$> Dir.doesPathExist treePath - pure $ case outcome of - Right removed - | not (doRowRemoved removed), doTreeRemoved removed, gone -> Pass - | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) - Left err -> Fail err, - runTestM "a read-only registered tree deletes fully" $ do - let solid = StorePath (T.replicate 32 "e") "del-solid" - treePath = storePathToFilePath sd solid - registerPath (stDB store) (PathRegistration solid "sha256:s" 1 Nothing []) - createDirectoryIfMissing True treePath - TIO.writeFile (treePath "data.txt") "content" - setReadOnly treePath - outcome <- deleteStorePathRaw store (basenameOf solid) - gone <- not <$> Dir.doesPathExist treePath - stillValid <- isValid store solid - pure $ case outcome of - Right removed - | doRowRemoved removed, doTreeRemoved removed, gone, not stillValid -> Pass - | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) - Left err -> Fail err, - runTestM "a self-referencing path deletes" $ do - let selfp = StorePath (T.replicate 32 "f") "del-self" - registerPath (stDB store) (PathRegistration selfp "sha256:f" 1 Nothing [selfp]) - outcome <- deleteStorePathRaw store (basenameOf selfp) - pure (assertEqual "self delete" (Right (DeleteOutcome True False)) outcome), - runTestM "a target with neither row nor tree is an error" $ do - outcome <- deleteStorePathRaw store (T.replicate 32 "9" <> "-del-nothing") - pure $ case outcome of - Left err | "not in this store" `T.isInfixOf` err -> Pass - other -> Fail ("expected not-in-store, got: " <> T.pack (show other)), - runTestM "a legacy row the validator rejects deletes by raw text" $ do - let legacyBase = T.replicate 32 "g" <> "-old~marker" - treePath = unStoreDir sd T.unpack legacyBase - legacyPathText = T.pack treePath - conn <- SQL.open (unStoreDir sd metaDirName dbFileName) - SQL.execute - conn - "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) VALUES (?, ?, 0, NULL, 0)" - (legacyPathText, "sha256:legacy" :: T.Text) - SQL.close conn - createDirectoryIfMissing True treePath - TIO.writeFile (treePath "seed.txt") "epoch" - let resolved = resolveDeleteTarget sd legacyPathText - outcome <- either (pure . Left) (deleteStorePathRaw store) resolved - remaining <- queryAllValidPaths (stDB store) - gone <- not <$> Dir.doesPathExist treePath - pure $ case outcome of - Right removed - | doRowRemoved removed, doTreeRemoved removed, gone, legacyPathText `notElem` remaining -> Pass - | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) - Left err -> Fail err, - runTest "resolveDeleteTarget accepts bare, store-dir, platform, and canonical spellings" $ - let nameBase = T.replicate 32 "h" <> "-name" - spellings = - [ nameBase, - T.pack (unStoreDir sd T.unpack nameBase), - T.pack (unStoreDir platformStoreDir) <> "\\" <> nameBase, - defaultStoreDirText <> "/" <> nameBase - ] - in assertEqual "all resolve" (replicate 4 (Right nameBase)) (map (resolveDeleteTarget sd) spellings), - runTest "resolveDeleteTarget refuses traversal shapes" $ - let refused = - [ ".nova-nix", - "..", - ".", - "", - T.pack (unStoreDir sd) <> "/", - "/somewhere/else/" <> T.replicate 32 "h" <> "-name", - T.replicate 32 "h" <> "-na:me" - ] - in case [t | t <- refused, either (const False) (const True) (resolveDeleteTarget sd t)] of - [] -> Pass - accepted -> Fail ("accepted: " <> T.pack (show accepted)), - -- Lock files are never deleted (the Nix.Store.Lock design), but - -- names like flake.lock are legal store-path names, so only the - -- registration rows can tell a lock file from a store object: - -- an unregistered lock-shaped file refuses, a registered object - -- of the same shape deletes, and lock-shaped junk whose - -- stripped prefix is not a store basename deletes as junk. - runTestM "delete refuses an unregistered lock file by name" $ do - let guarded = StorePath (T.replicate 32 "j") "del-guard" - lockBase = basenameOf guarded <> ".lock" - lockPath = storePathToFilePath sd guarded <> ".lock" - TIO.writeFile lockPath "" - outcome <- deleteStorePathRaw store lockBase - survived <- Dir.doesPathExist lockPath - pure $ case outcome of - Left err - | "never deleted" `T.isInfixOf` err -> - if survived then Pass else Fail "lock file removed despite refusal" - | otherwise -> Fail ("wrong refusal: " <> err) - Right _ -> Fail "unregistered lock file was deleted", - runTestM "delete removes a registered store object named like a lock file" $ do - let object = StorePath (T.replicate 32 "k") "flake.lock" - objectPath = storePathToFilePath sd object - registerPath (stDB store) (PathRegistration object "sha256:m" 1 Nothing []) - TIO.writeFile objectPath "pinned inputs" - outcome <- deleteStorePathRaw store (basenameOf object) - gone <- not <$> Dir.doesPathExist objectPath - pure $ case outcome of - Right removed - | doRowRemoved removed, doTreeRemoved removed, gone -> Pass - | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) - Left err -> Fail ("registered .lock-named object refused: " <> err), - runTestM "delete removes lock-shaped junk with no store-shaped prefix" $ do - let junkName = "not-a-store-path.lock" - junkPath = unStoreDir sd T.unpack junkName - TIO.writeFile junkPath "debris" - outcome <- deleteStorePathRaw store junkName - gone <- not <$> Dir.doesPathExist junkPath - pure $ case outcome of - Right removed - | doTreeRemoved removed, gone -> Pass - | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) - Left err -> Fail ("lock-shaped junk refused: " <> err), - -- Deletion and substitution contend on one per-path lock: a - -- delete must wait while another handle holds the path's lock - - -- otherwise it can tear a tree out between a substituter's - -- on-disk recheck and its registration commit - and proceed - -- once the holder releases. - runTestM "delete waits for a held path lock and proceeds on release" $ do - let guarded = StorePath (T.replicate 32 "i") "del-locked" - treePath = storePathToFilePath sd guarded - registerPath (stDB store) (PathRegistration guarded "sha256:l" 1 Nothing []) - createDirectoryIfMissing True treePath - TIO.writeFile (treePath "data.txt") "guarded" - holder <- acquirePathLock sd guarded - done <- newEmptyMVar - _ <- forkIO (deleteStorePathRaw store (basenameOf guarded) >>= putMVar done) - early <- timeout deleteLockProbeMicros (takeMVar done) - releasePathLock holder - outcome <- timeout raceWatchdogMicros (takeMVar done) - gone <- not <$> Dir.doesPathExist treePath - pure $ case (early, outcome) of - (Just finished, _) -> - Fail ("delete ignored the held lock: " <> T.pack (show finished)) - (Nothing, Just (Right removed)) - | doRowRemoved removed, doTreeRemoved removed, gone -> Pass - | otherwise -> Fail ("wrong outcome after release: " <> T.pack (show removed)) - (Nothing, other) -> - Fail ("delete never completed after release: " <> T.pack (show other)), - -- The eval-side materializer joins the same protocol (#21): its - -- check-then-act must wait while another handle holds the - -- path's lock - unlocked, the loser's removePathForcibly could - -- delete the tree the winner had just registered - and proceed - -- once the holder releases. - runTestM "materializeEvalSources waits for a held path lock" $ do - srcDir <- ( "nova-nix-test-mat-lock-src") <$> getTemporaryDirectory - forceRemoveIfExists srcDir - createDirectoryIfMissing True srcDir - TIO.writeFile (srcDir "f.txt") "locked source" - -- The address the source's content derives, as evaluation - -- would name it: a restore refuses any other. - entry <- NAR.serialiseFromPath srcDir - case makeFixedOutputPath "mat-locked" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right guarded -> do - let spText = storePathToText defaultStoreDir guarded - holder <- acquirePathLock sd guarded - done <- newEmptyMVar - _ <- forkIO (materializeEvalSources store (Map.singleton (T.pack srcDir) spText) >>= putMVar done) - early <- timeout deleteLockProbeMicros (takeMVar done) - releasePathLock holder - outcome <- timeout raceWatchdogMicros (takeMVar done) - registered <- isValid store guarded - forceRemoveIfExists srcDir - pure $ case (early, outcome) of - (Just _, _) -> Fail "materialize ignored the held lock" - (Nothing, Just ()) - | registered -> Pass - | otherwise -> Fail "proceeded after release but never registered" - (Nothing, Nothing) -> Fail "materialize never completed after release" - ] - --- | The collector's pure core: the reachability walk over the references --- map, and the sweep plan over the valid set, the live set, and the store --- directory's entries. No store is opened. -testGcPure :: IO [Bool] -testGcPure = do - putStrLn "store/gc-pure" - let sd = StoreDir "/s" - at name = T.pack (unStoreDir sd name) - refs = referencesMap [(at "a", at "b"), (at "b", at "c"), (at "d", at "c"), (at "e", at "e")] - hashOf c = T.unpack (T.replicate 32 c) - liveName = hashOf "a" <> "-gc-live" - deadOnDisk = hashOf "b" <> "-gc-dead" - deadNoTree = hashOf "c" <> "-gc-ghost" - stale = hashOf "d" <> "-gc-stale" - nix32Alphabet = "0123456789abcdfghijklmnpqrsvwxyz" :: String - sequence - [ runTest "reachableFrom closes over references transitively" $ - assertEqual "closure" (Set.fromList [at "a", at "b", at "c"]) (reachableFrom refs [at "a"]), - runTest "reachableFrom leaves paths the roots do not reach out" $ - assertEqual "d alone" (Set.fromList [at "c", at "d"]) (reachableFrom refs [at "d"]), - runTest "reachableFrom terminates on a cycle and a self-reference" $ - assertEqual - "cycle, self" - (Set.fromList [at "x", at "y"], Set.singleton (at "e")) - (reachableFrom (referencesMap [(at "x", at "y"), (at "y", at "x")]) [at "x"], reachableFrom refs [at "e"]), - runTest "reachableFrom keeps a root the map does not know as a dead end" $ - assertEqual "unknown root" (Set.singleton (at "z")) (reachableFrom refs [at "z"]), - runTest "reachableFrom of no roots is empty" $ - assertEqual "no roots" Set.empty (reachableFrom refs []), - -- Dead rows go whether or not a tree exists; every directory entry - -- that is not live goes too (a dead tree, a stale build, junk, a - -- dead path's lock file), while the live path, its lock file and - -- the metadata directory stay. - runTest "sweepPlan unregisters dead rows and removes every entry that is not live, keeping a live path's lock file" $ - let valid = Set.fromList [at liveName, at deadOnDisk, at deadNoTree] - live = Set.fromList [at liveName] - entries = map T.pack [liveName, liveName <> ".lock", deadOnDisk, deadOnDisk <> ".lock", metaDirName, stale, stale <> ".lock", "junk-file"] - in assertEqual - "plan" - SweepPlan - { spDeadRows = sort [at deadOnDisk, at deadNoTree], - spTrees = sort [at deadOnDisk, at (deadOnDisk <> ".lock"), at stale, at (stale <> ".lock"), at "junk-file"] - } - (sweepPlan sd valid live entries), - runTest "sweepPlan removes a dead registered object named like a live path's lock file" $ - let lockNamed = liveName <> ".lock" - valid = Set.fromList [at liveName, at lockNamed] - live = Set.fromList [at liveName] - in assertEqual - "plan" - SweepPlan {spDeadRows = [at lockNamed], spTrees = [at lockNamed]} - (sweepPlan sd valid live (map T.pack [liveName, lockNamed])), - runTest "parseStorePathPrefix names the path for itself, a trailing separator and anything beneath, and nothing outside" $ - let sp = StorePath (T.replicate 32 "a") "gc-live" - dirText = T.pack (unStoreDir sd) - named = map (parseStorePathPrefix sd) [at liveName, at liveName <> "/", at liveName <> "/bin/tool", at liveName <> "\\bin"] - unnamed = map (parseStorePathPrefix sd) [dirText, dirText <> "/", "/elsewhere/" <> T.pack liveName, dirText <> "/not-a-store-path"] - in assertEqual "prefixes" (replicate 4 (Just sp), replicate 4 Nothing) (named, unnamed), - runTest "showFreedBytes renders upstream's two-place MiB" $ - assertEqual "MiB" ["0.00 MiB", "1.00 MiB", "1.50 MiB"] (map showFreedBytes [0, 1048576, 1572864]), - runTest "gcSummaryLine is upstream's PrintFreed line" $ - assertEqual "summary" "2 store paths deleted, 1.00 MiB freed" (gcSummaryLine (GcResults [at "a", at "b"] 1048576)), - runTest "indirectRootRecordName is a nix-base32 digest keyed by the link path" $ - let name = indirectRootRecordName "/home/u/result" - in if length name == 52 && all (`elem` nix32Alphabet) name && name /= indirectRootRecordName "/home/u/result-2" - then Pass - else Fail ("unexpected record name: " <> T.pack name) - ] - --- | Garbage collection end to end against a temp store: a rooted closure --- survives and the orphan goes, the rooted path and what it reaches --- cannot be deleted, one directory keys one store however it is --- spelled while a foreign spelling is refused, a removed root lets the --- closure go, a dead cycle sweeps, a dead path's lock file goes with it, --- a second open handle holds the collector off, a failed lease renewal --- leaves a closable handle, and an out-link root behaves as nix-build's --- result link does. -testStoreGC :: IO [Bool] -testStoreGC = do - putStrLn "store/gc" - canLink <- symlinksAvailable - tmpBase <- getTemporaryDirectory - let linkDir = tmpBase "nova-nix-test-gc-links" - outLink = linkDir "result" - Dir.removePathForcibly linkDir - createDirectoryIfMissing True linkDir - withTempStore $ \store -> do - let sd = stDir store - basenameOf sp = spHash sp <> "-" <> spName sp - pathText sp = T.pack (storePathToFilePath sd sp) - lockOf sp = storePathToFilePath sd sp <> ".lock" - plant sp bytes = do - let tree = storePathToFilePath sd sp - createDirectoryIfMissing True tree - BS.writeFile (tree "data") bytes - dep = StorePath (T.replicate 32 "a") "gc-dep" - top = StorePath (T.replicate 32 "b") "gc-top" - orphan = StorePath (T.replicate 32 "c") "gc-orphan" - rootFile = gcRootsDir sd T.unpack (basenameOf top) - registerTrio = do - mapM_ (uncurry plant) [(dep, "dep"), (top, "top!"), (orphan, "orphan bytes")] - registerPaths - (stDB store) - [ PathRegistration dep "sha256:d" 1 Nothing [], - PathRegistration top "sha256:t" 1 Nothing [dep], - PathRegistration orphan "sha256:o" 1 Nothing [] - ] - -- A refused collection is a failure of the test, not a result. - collect = collectGarbage store >>= either (throwIO . userError . T.unpack) pure - permanent <- - sequence - [ -- A regular file named like the path, under gcroots: upstream's - -- own permanent-root form, the one that needs no symlink. - runTestM "a permanent root keeps its closure and the orphan is swept" $ do - registerTrio - createDirectoryIfMissing True (gcRootsDir sd) - BS.writeFile rootFile "" - results <- collect - validity <- mapM (isValid store) [dep, top, orphan] - orphanGone <- not <$> Dir.doesPathExist (storePathToFilePath sd orphan) - topKept <- Dir.doesPathExist (storePathToFilePath sd top "data") - pure $ - if results == GcResults [pathText orphan] 12 && validity == [True, True, False] && orphanGone && topKept - then Pass - else Fail ("wrong sweep: " <> T.pack (show (results, validity, orphanGone, topKept))), - runTestM "delete refuses the rooted path with upstream's words" $ do - outcome <- deleteStorePathRaw store (basenameOf top) - stillValid <- isValid store top - pure $ case outcome of - Left err - | "since it is still alive" `T.isInfixOf` err, pathText top `T.isInfixOf` err, stillValid -> Pass - | otherwise -> Fail ("wrong refusal: " <> err) - Right removed -> Fail ("deleted a rooted path: " <> T.pack (show removed)), - runTestM "delete refuses a path the root reaches through references" $ do - outcome <- deleteStorePathRaw store (basenameOf dep) - pure $ case outcome of - Left err | "since it is still alive" `T.isInfixOf` err -> Pass - other -> Fail ("expected the liveness refusal, got: " <> T.pack (show other)), - runTestM "findRoots reports the permanent root under its own path" $ do - roots <- findRoots store - pure (assertEqual "roots" [GcRoot rootFile (pathText top)] roots), - -- One directory keys one set of rows however it is spelled: the - -- handle canonicalises the spelling at open, so a second handle - -- opened through '.', '..' and a trailing separator (and, when - -- the temp store shares the working directory's drive, through - -- a relative path) is the same store with the same root. - runTestM "openStore keys the store by one spelling of its directory" $ do - cwd <- Dir.getCurrentDirectory - let dotted = unStoreDir sd "." "zig" ".." <> [pathSeparator] - relative = - [ joinPath (replicate (length (splitDirectories cwd) - 1) "..") dropDrive (unStoreDir sd) - | takeDrive cwd == takeDrive (unStoreDir sd) - ] - spellings = dotted : relative - inspect spelling = do - other <- openStore (StoreDir spelling) - roots <- findRoots other - closeStore other - pure (stDir other, roots) - outcomes <- mapM inspect spellings - pure (assertEqual "spellings" (map (const (sd, [GcRoot rootFile (pathText top)])) spellings) outcomes), - -- A row keyed under another spelling of the directory would - -- compare as dead; the collector and the checked delete refuse - -- instead of sweeping, and nothing changes. - runTestM "a collection and a checked delete refuse a database keyed under another spelling" $ do - let foreignRow = "/elsewhere/" <> T.replicate 32 "z" <> "-gc-foreign" - conn <- SQL.open (unStoreDir sd metaDirName dbFileName) - SQL.execute - conn - "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) VALUES (?, ?, 0, NULL, 0)" - (foreignRow, "sha256:z" :: T.Text) - collected <- collectGarbage store - deleted <- deleteStorePathRaw store (basenameOf dep) - SQL.execute conn "DELETE FROM ValidPaths WHERE path = ?" (SQL.Only foreignRow) - SQL.close conn - validity <- mapM (isValid store) [dep, top, orphan] - topKept <- Dir.doesPathExist (storePathToFilePath sd top "data") - pure $ case (collected, deleted) of - (Left gcErr, Left delErr) - | "another spelling" `T.isInfixOf` gcErr, - "another spelling" `T.isInfixOf` delErr, - validity == [True, True, False], - topKept -> - Pass - other -> Fail ("expected both refusals, got: " <> T.pack (show (other, validity, topKept))), - -- Upstream reports an entry it cannot read and carries on; a - -- directory with no permissions is the reproducible case, and - -- one that lists anyway (root, or Windows, where permissions - -- do not forbid a listing) proves nothing and is skipped. - runTestM "an unreadable entry under gcroots is reported and skipped" $ do - let locked = gcRootsDir sd "locked" - unlock = do - Dir.setPermissions locked (Dir.setOwnerReadable True (Dir.setOwnerSearchable True (Dir.setOwnerWritable True Dir.emptyPermissions))) - Dir.removePathForcibly locked - createDirectoryIfMissing True locked - Dir.setPermissions locked Dir.emptyPermissions - readable <- try (Dir.listDirectory locked) :: IO (Either SomeException [FilePath]) - -- Restored on every exit: a walk that throws here would - -- otherwise leave the directory unreadable for every later - -- root walk in the group. - roots <- findRoots store `finally` unlock - case readable of - Right _ -> Pass <$ putStrLn " SKIP an empty-permission directory is readable here" - Left _ -> pure (assertEqual "roots" [GcRoot rootFile (pathText top)] roots), - runTestM "removing the root lets the closure go in one sweep" $ do - Dir.removeFile rootFile - results <- collect - remaining <- queryAllValidPaths (stDB store) - depGone <- not <$> Dir.doesPathExist (storePathToFilePath sd dep) - pure $ - if gcrDeleted results == [pathText dep, pathText top] && null remaining && depGone - then Pass - else Fail ("closure survived: " <> T.pack (show (results, remaining, depGone))), - -- Cross-output references run both ways between the outputs of - -- one derivation, and no order of one-row deletes gets through - -- that; the batch delete does. - runTestM "a dead reference cycle is swept" $ do - let out = StorePath (T.replicate 32 "d") "gc-cycle-out" - dev = StorePath (T.replicate 32 "e") "gc-cycle-dev" - mapM_ (uncurry plant) [(out, "o"), (dev, "d")] - registerPaths - (stDB store) - [ PathRegistration out "sha256:x" 1 Nothing [dev], - PathRegistration dev "sha256:y" 1 Nothing [out] - ] - results <- collect - remaining <- queryAllValidPaths (stDB store) - pure (assertEqual "swept" ([pathText out, pathText dev], []) (gcrDeleted results, remaining)), - -- Every entry that is not live goes, a dead path's lock file - -- with it; a live path's lock file is the one lock file the - -- protocol keeps, and it goes once the path does. - runTestM "a dead path's lock file is swept with it and a live path's stays until the path goes" $ do - registerTrio - BS.writeFile rootFile "" - let stale = StorePath (T.replicate 32 "f") "gc-stale" - plant stale "stale" - BS.writeFile (lockOf stale) "" - BS.writeFile (lockOf top) "" - first <- collect - staleGone <- not <$> Dir.doesPathExist (storePathToFilePath sd stale) - staleLockGone <- not <$> Dir.doesPathExist (lockOf stale) - topLockKept <- Dir.doesPathExist (lockOf top) - Dir.removeFile rootFile - second <- collect - topLockGone <- not <$> Dir.doesPathExist (lockOf top) - remaining <- queryAllValidPaths (stDB store) - pure $ - if gcrDeleted first == sort [pathText orphan, pathText stale, T.pack (lockOf stale)] - && staleGone - && staleLockGone - && topLockKept - && gcrDeleted second == sort [pathText dep, pathText top, T.pack (lockOf top)] - && topLockGone - && null remaining - then Pass - else Fail ("wrong sweep: " <> T.pack (show (first, staleGone, staleLockGone, topLockKept, second, topLockGone, remaining))), - -- Every open handle holds the collector lock shared; the - -- collector needs it exclusive, so it waits for the other - -- handle to close and runs the moment it does. - runTestM "collectGarbage waits for another open handle to close" $ do - other <- openStore sd - done <- newEmptyMVar - _ <- forkIO (collect >>= putMVar done) - early <- timeout deleteLockProbeMicros (takeMVar done) - closeStore other - outcome <- timeout raceWatchdogMicros (takeMVar done) - pure $ case (early, outcome) of - (Just _, _) -> Fail "collector ignored the other handle's lease" - (Nothing, Just _) -> Pass - (Nothing, Nothing) -> Fail "collector never ran after the other handle closed", - -- A renewal that fails must not leave the handle without a - -- lease slot, or closeStore waits forever. The lock file is - -- replaced by a directory while the exclusive lock is held, so - -- the shared re-acquire cannot open it; Windows forbids - -- replacing a held file, so the case is POSIX-only. - runTestM "withCollectorLock leaves a closable handle when the lease cannot be renewed" $ - if SI.os == "mingw32" - then Pass <$ putStrLn " SKIP a held lock file cannot be replaced on Windows" - else do - let renewalStore = tmpBase "nova-nix-test-gc-renewal" - Dir.removePathForcibly renewalStore - other <- openStore (StoreDir renewalStore) - let lockPath = gcLockFilePath (stDir other) - swapped <- try (withCollectorLock other (Dir.removeFile lockPath >> Dir.createDirectory lockPath)) - closed <- timeout raceWatchdogMicros (closeStore other) - Dir.removePathForcibly renewalStore - pure $ case (swapped :: Either SomeException (), closed) of - (Left _, Just ()) -> Pass - (Right (), _) -> Fail "renewal succeeded against a directory" - (Left _, Nothing) -> Fail "closeStore hung after a failed renewal" - ] - linked <- - if not canLink - then do - putStrLn " SKIP out-link roots need symlink privilege" - pure [] - else - sequence - [ runTestM "an out-link root keeps the closure until the link is removed" $ do - registerTrio - rooted <- addOutLinkRoot store outLink top - case rooted of - Left err -> pure (Fail err) - Right link -> do - let record = autoRootsDir sd indirectRootRecordName link - recordThere <- Dir.doesFileExist record - roots <- findRoots store - first <- collect - Dir.removePathForcibly link - second <- collect - recordGone <- not <$> Dir.doesFileExist record - remaining <- queryAllValidPaths (stDB store) - pure $ - if roots == [GcRoot link (pathText top)] - && recordThere - && gcrDeleted first == [pathText orphan] - && gcrDeleted second == [pathText dep, pathText top] - && recordGone - && null remaining - then Pass - else Fail ("out-link root misbehaved: " <> T.pack (show (roots, recordThere, first, second, recordGone, remaining))), - -- upstream's findRoots takes toStorePath of the target, so a - -- link into a store path's subtree, or to the path with a - -- trailing separator, roots the path. - runTestM "a symlink root into a store path's subtree or with a trailing separator roots the path" $ do - plant top "top" - registerPath (stDB store) (PathRegistration top "sha256:t" 1 Nothing []) - let subLink = gcRootsDir sd "sub" - slashLink = gcRootsDir sd "slash" - Dir.createFileLink (storePathToFilePath sd top "data") subLink - Dir.createDirectoryLink (storePathToFilePath sd top <> [pathSeparator]) slashLink - roots <- findRoots store - mapM_ Dir.removePathForcibly [subLink, slashLink] - pure (assertEqual "roots" [GcRoot slashLink (pathText top), GcRoot subLink (pathText top)] roots), - -- upstream dedups through a set keyed by (link, path); an - -- operator's symlink to the out-link and the out-link's own - -- record name the same root. - runTestM "findRoots lists one link once when two records name it" $ do - rooted <- addOutLinkRoot store outLink top - case rooted of - Left err -> pure (Fail err) - Right link -> do - let mine = gcRootsDir sd "mine" - Dir.createFileLink link mine - roots <- findRoots store - mapM_ Dir.removePathForcibly [mine, link] - pure (assertEqual "roots" [GcRoot link (pathText top)] roots), - -- upstream's addPermRoot canonPaths the link and makeSymlink - -- creates its parents; a '..' that lands inside the store is - -- refused as inside. - runTestM "addOutLinkRoot collapses .. and creates missing parents, and .. cannot spell a link into the store" $ do - let expectedLink = T.unpack (canonPath (T.pack (linkDir "deep" "result"))) - dotted = linkDir "deep" "down" ".." "result" - insideViaDotDot = takeDirectory (unStoreDir sd) takeFileName linkDir ".." takeFileName (unStoreDir sd) "result" - collapsed <- addOutLinkRoot store dotted top - target <- Dir.getSymbolicLinkTarget expectedLink - recorded <- BS.readFile (autoRootsDir sd indirectRootRecordName expectedLink) - inside <- addOutLinkRoot store insideViaDotDot top - pure $ case (collapsed, inside) of - (Right link, Left insideErr) - | link == expectedLink, - target == storePathToFilePath sd top, - recorded == TE.encodeUtf8 (T.pack link), - "in the Nix store is forbidden" `T.isInfixOf` insideErr -> - Pass - other -> Fail ("wrong outcomes: " <> T.pack (show (other, target, recorded))), - -- upstream's addPermRoot: an existing store link is replaced, - -- anything else at the name is refused, and a link inside - -- the store is refused. - runTestM "addOutLinkRoot replaces a store link and refuses a file or a link inside the store" $ do - let replaceLink = linkDir "replace" - plainFile = linkDir "plain" - Dir.createFileLink (storePathToFilePath sd orphan) replaceLink - replaced <- addOutLinkRoot store replaceLink top - target <- Dir.getSymbolicLinkTarget replaceLink - BS.writeFile plainFile "not a link" - clobber <- addOutLinkRoot store plainFile top - inside <- addOutLinkRoot store (unStoreDir sd "result") top - pure $ case (replaced, clobber, inside) of - (Right _, Left clobberErr, Left insideErr) - | target == storePathToFilePath sd top, - "already exists" `T.isInfixOf` clobberErr, - "in the Nix store is forbidden" `T.isInfixOf` insideErr -> - Pass - other -> Fail ("wrong outcomes: " <> T.pack (show (other, target))) - ] - Dir.removePathForcibly linkDir - pure (permanent ++ linked) - -testStoreOps :: IO [Bool] -testStoreOps = do - putStrLn "store/ops" - withTempStore $ \store -> do - let sd = stDir store - sequence - [ -- computeClosure emits references before referrers (deps-first): - -- phase-2 narinfo publication then never announces a path whose - -- references are not yet visible. The dep is shared by both - -- roots and must precede both. - runTestM "computeClosure orders references first" $ do - let dep = StorePath "llllllllllllllllllllllllllllllll" "cl-dep" - p1 = StorePath "mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm" "cl-p1" - p2 = StorePath "nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn" "cl-p2" - registerPaths - (stDB store) - [ PathRegistration dep "sha256:cd" 1 Nothing [], - PathRegistration p1 "sha256:c1" 2 Nothing [dep], - PathRegistration p2 "sha256:c2" 3 Nothing [dep] - ] - result <- computeClosure store [p1, p2] - pure (assertEqual "closure order" (Right [dep, p1, p2]) result), - -- materializeEvalSources adoption is verified: a partial tree left - -- at the destination by an interrupted restore must be cleared - -- and restored again, never registered as-is. - runTestM "materializeEvalSources restores over a mismatched tree" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-adopt-src" - removeIfExists srcDir - createDirectoryIfMissing True srcDir - TIO.writeFile (srcDir "data.txt") "real content" - entry <- NAR.serialiseFromPath srcDir - case makeFixedOutputPath "nova-nix-test-adopt-src" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let spText = storePathToText defaultStoreDir sp - dest = storePathToFilePath (stDir store) sp - -- Fake an interrupted earlier copy: wrong partial content. - removeIfExists dest - createDirectoryIfMissing True dest - TIO.writeFile (dest "data.txt") "partial garbage" - materializeEvalSources store (Map.fromList [(T.pack srcDir, spText)]) - adopted <- TIO.readFile (dest "data.txt") - registered <- isValid store sp - removeIfExists srcDir - pure $ - if adopted == "real content" && registered - then Pass - else Fail ("expected re-copied content, got: " <> adopted), - -- Evaluation hashes a source well before the build driver - -- restores it. A source edited in between no longer reproduces - -- the address evaluation gave it, so it is refused and nothing - -- is left at the path, rather than its new bytes being sealed - -- and registered under the old address (#235). - runTestM "materializeEvalSources refuses a source changed since evaluation" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-changed-src" - removeIfExists srcDir - createDirectoryIfMissing True srcDir - TIO.writeFile (srcDir "data.txt") "evaluated content" - entry <- NAR.serialiseFromPath srcDir - case makeFixedOutputPath "nova-nix-test-changed-src" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let spText = storePathToText defaultStoreDir sp - dest = storePathToFilePath (stDir store) sp - forceRemoveIfExists dest - TIO.writeFile (srcDir "data.txt") "edited after evaluation" - outcome <- try (materializeEvalSources store (Map.fromList [(T.pack srcDir, spText)])) - registered <- isValid store sp - leftBehind <- Dir.doesPathExist dest - removeIfExists srcDir - pure $ case outcome of - Right () -> Fail "registered a source that changed after evaluation" - Left (e :: IOException) - | not ("changed after evaluation hashed it" `T.isInfixOf` T.pack (ioeGetErrorString e)) -> - Fail ("unexpected refusal: " <> T.pack (show e)) - | registered || leftBehind -> - Fail ("refused, but registered " <> T.pack (show registered) <> ", tree left " <> T.pack (show leftBehind)) - | otherwise -> Pass, - -- The registrar's half of the eval-write pair: content that does - -- not re-derive its store path under the recorded scheme must be - -- refused loudly, never registered valid under a hash its bytes - -- do not have and then sealed read-only. - runTestM "materializeEvalStoreWrites refuses content that does not reproduce its path" $ do - let goodBytes = TE.encodeUtf8 "the full flat content" - case makeFixedOutputPath "flat-verify" "sha256" "flat" (sha256Digest goodBytes) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let spText = storePathToText defaultStoreDir sp - dest = storePathToFilePath (stDir store) sp - removeIfExists dest - BS.writeFile dest (TE.encodeUtf8 "the full") - outcome <- try (materializeEvalStoreWrites store (Map.fromList [(spText, ([], WriteFlat))])) - stillInvalid <- not <$> isValid store sp - removeIfExists dest - pure $ case (outcome :: Either SomeException ()) of - Left _ | stillInvalid -> Pass - Left _ -> Fail "refused but registered anyway" - Right () -> Fail "registered a truncated write as valid", - runTestM "materializeEvalStoreWrites registers content that reproduces its path" $ do - let goodBytes = TE.encodeUtf8 "registered text content" - refs = [] - case makeTextPath "text-verify" (sha256Digest goodBytes) refs of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let spText = storePathToText defaultStoreDir sp - dest = storePathToFilePath (stDir store) sp - removeIfExists dest - BS.writeFile dest goodBytes - materializeEvalStoreWrites store (Map.fromList [(spText, (refs, WriteText))]) - registered <- isValid store sp - pure (assertEqual "registered" True registered), - -- A tree that DOES reproduce its store path is adopted untouched. - -- The source is deleted before the call: adoption never reads it, - -- so a wrongful re-copy attempt throws and fails the test. - runTestM "materializeEvalSources adopts a matching tree untouched" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-adopt-ok" - removeIfExists srcDir - createDirectoryIfMissing True srcDir - TIO.writeFile (srcDir "data.txt") "same bytes" - entry <- NAR.serialiseFromPath srcDir - case makeFixedOutputPath "nova-nix-test-adopt-ok" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let spText = storePathToText defaultStoreDir sp - dest = storePathToFilePath (stDir store) sp - removeIfExists dest - createDirectoryIfMissing True dest - TIO.writeFile (dest "data.txt") "same bytes" - removeIfExists srcDir - materializeEvalSources store (Map.fromList [(T.pack srcDir, spText)]) - registered <- isValid store sp - pure (if registered then Pass else Fail "matching tree was not adopted and registered"), - -- scanReferences finds the canonical /nix/store text eval injects - -- into builder envs, independent of the platform store dir (the - -- bare hash is the needle, matching upstream Nix). - runTestM "scanReferences finds canonical ref" $ do - tmpBase <- getTemporaryDirectory - let scanDir = tmpBase "nova-nix-test-scan" - removeIfExists scanDir - createDirectoryIfMissing True scanDir - let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" - refString = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-dep1" - BS.writeFile (scanDir "output.txt") (TE.encodeUtf8 (T.pack ("hello " <> refString <> " world"))) - refs <- scanReferences [candidate] scanDir - removeIfExists scanDir - pure $ - if candidate `elem` refs - then Pass - else Fail ("expected to find ref, got: " <> T.pack (show refs)), - -- scanReferences finds a Windows-form embedding too - runTestM "scanReferences finds windows-form ref" $ do - tmpBase <- getTemporaryDirectory - let scanDir = tmpBase "nova-nix-test-scan-win" - removeIfExists scanDir - createDirectoryIfMissing True scanDir - let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" - refString = "C:\\nix\\store\\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-dep1" - BS.writeFile (scanDir "output.txt") (TE.encodeUtf8 (T.pack ("exec " <> refString))) - refs <- scanReferences [candidate] scanDir - removeIfExists scanDir - pure $ - if candidate `elem` refs - then Pass - else Fail ("expected to find ref, got: " <> T.pack (show refs)), - -- scanReferences misses non-matching - runTestM "scanReferences misses non-match" $ do - tmpBase <- getTemporaryDirectory - let scanDir = tmpBase "nova-nix-test-scan2" - removeIfExists scanDir - createDirectoryIfMissing True scanDir - let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" - BS.writeFile (scanDir "output.txt") "no store paths here" - refs <- scanReferences [candidate] scanDir - removeIfExists scanDir - pure (assertEqual "no refs" [] refs), - -- scanReferences ignores partial match - runTestM "scanReferences ignores partial" $ do - tmpBase <- getTemporaryDirectory - let scanDir = tmpBase "nova-nix-test-scan3" - removeIfExists scanDir - createDirectoryIfMissing True scanDir - let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" - -- Only 20 chars of hash - should not match the 32-char needle - partialRef = "/nix/store/aaaaaaaaaaaaaaaaaaaa" - BS.writeFile (scanDir "output.txt") (TE.encodeUtf8 (T.pack partialRef)) - refs <- scanReferences [candidate] scanDir - removeIfExists scanDir - pure (assertEqual "no partial refs" [] refs), - -- scanTempReferences records the self/cross-output edges that the - -- store-prefix scan cannot see (outputs embedding their TEMP path) - runTestM "scanTempReferences finds temp-dir embedding" $ do - tmpBase <- getTemporaryDirectory - let scanDir = tmpBase "nova-nix-test-scan-temp" - fakeTempOut = tmpBase "nova-nix-build" "fake-out" - removeIfExists scanDir - createDirectoryIfMissing True scanDir - let selfSp = StorePath "cccccccccccccccccccccccccccccccc" "self" - BS.writeFile - (scanDir "wrapper.sh") - (TE.encodeUtf8 (T.pack ("exec " <> fakeTempOut <> "/bin/tool"))) - found <- scanTempReferences [(fakeTempOut, selfSp)] scanDir - removeIfExists scanDir - pure (assertEqual "self-ref found" [selfSp] found), - runTestM "scanTempReferences negative" $ do - tmpBase <- getTemporaryDirectory - let scanDir = tmpBase "nova-nix-test-scan-temp-neg" - removeIfExists scanDir - createDirectoryIfMissing True scanDir - let selfSp = StorePath "cccccccccccccccccccccccccccccccc" "self" - BS.writeFile (scanDir "clean.txt") "no temp paths embedded here" - found <- scanTempReferences [(tmpBase "nova-nix-build" "fake-out", selfSp)] scanDir - removeIfExists scanDir - pure (assertEqual "no refs" [] found), - -- addToStore moves dir + registers in DB - runTestM "addToStore moves + registers" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-add-src" - removeIfExists srcDir - createDirectoryIfMissing True srcDir - writeFile (srcDir "hello.txt") "hello world" - let sp = StorePath "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" "addtest" - addToStore store srcDir sp Nothing [] - valid <- isValid store sp - exists <- pathExists store sp - pure $ - if valid && exists - then Pass - else Fail ("valid=" <> T.pack (show valid) <> " exists=" <> T.pack (show exists)), - -- addToStore sets read-only - runTestM "addToStore sets read-only" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-add-ro" - removeIfExists srcDir - createDirectoryIfMissing True srcDir - writeFile (srcDir "data.txt") "data" - let sp = StorePath "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy" "rotest" - addToStore store srcDir sp Nothing [] - let destFile = storePathToFilePath sd sp "data.txt" - perms <- getPermissions destFile - pure $ - if not (writable perms) - then Pass - else Fail "expected read-only but file is writable", - -- setReadOnly works on a plain directory - runTestM "setReadOnly makes dir read-only" $ do - tmpBase <- getTemporaryDirectory - let roDir = tmpBase "nova-nix-test-readonly" - removeIfExists roDir - createDirectoryIfMissing True roDir - writeFile (roDir "f.txt") "content" - setReadOnly roDir - dirPerms <- getPermissions roDir - filePerms <- getPermissions (roDir "f.txt") - -- Cleanup: restore writable so removeIfExists works - Dir.setPermissions roDir (Dir.setOwnerWritable True dirPerms) - Dir.setPermissions (roDir "f.txt") (Dir.setOwnerWritable True filePerms) - removeIfExists roDir - pure $ - if not (writable dirPerms) && not (writable filePerms) - then Pass - else - Fail - ( "dir writable=" - <> T.pack (show (writable dirPerms)) - <> " file writable=" - <> T.pack (show (writable filePerms)) - ), - -- pathExists true after addToStore - runTestM "pathExists after addToStore" $ do - tmpBase <- getTemporaryDirectory - let srcDir = tmpBase "nova-nix-test-exists" - removeIfExists srcDir - createDirectoryIfMissing True srcDir - writeFile (srcDir "x.txt") "x" - let sp = StorePath "wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww" "existstest" - addToStore store srcDir sp Nothing [] - exists <- pathExists store sp - pure (assertEqual "exists" True exists) - ] - --- | Store walks treat a symlink as a leaf. Each fixture plants a link --- the walk must not follow - out of the tree or back into it (a cycle) - --- and asserts the walk neither reads nor mutates through the link, and --- still terminates. -testSymlinkWalksIO :: IO [Bool] -testSymlinkWalksIO = do - putStrLn "store/symlink-walks" - canLink <- symlinksAvailable - if not canLink - then do - putStrLn " SKIP cannot create symlinks here (Windows needs Developer Mode or elevation)" - pure [] - else - sequence - [ -- A link out of the tree must not have the read-only bit - -- pushed through to its target. - runTestM "setReadOnly does not mark link targets outside the tree" $ do - tmpBase <- getTemporaryDirectory - let base = tmpBase "nova-nix-test-ro-links" - outside = base "outside" - tree = base "tree" - Dir.removePathForcibly base - createDirectoryIfMissing True outside - createDirectoryIfMissing True tree - BS.writeFile (outside "victim.txt") "victim" - BS.writeFile (tree "inside.txt") "inside" - Dir.createFileLink (outside "victim.txt") (tree "file-link") - Dir.createDirectoryLink outside (tree "dir-link") - setReadOnly tree - victimWritable <- writable <$> getPermissions (outside "victim.txt") - insideWritable <- writable <$> getPermissions (tree "inside.txt") - Dir.removePathForcibly base - pure $ - if victimWritable && not insideWritable - then Pass - else - Fail - ( "victim writable=" - <> T.pack (show victimWritable) - <> " inside writable=" - <> T.pack (show insideWritable) - ), - -- A link cycle must not recurse the walk forever. - runTestM "setReadOnly terminates on a link cycle" $ do - tmpBase <- getTemporaryDirectory - let tree = tmpBase "nova-nix-test-ro-cycle" - Dir.removePathForcibly tree - createDirectoryIfMissing True (tree "sub") - BS.writeFile (tree "sub" "f.txt") "f" - Dir.createDirectoryLink tree (tree "sub" "loop") - outcome <- timeout walkWatchdogMicros (setReadOnly tree) - marked <- writable <$> getPermissions (tree "sub" "f.txt") - Dir.removePathForcibly tree - pure $ case outcome of - Nothing -> Fail "walk did not terminate on a link cycle" - Just () - | marked -> Fail "regular file next to the cycle link was not marked read-only" - | otherwise -> Pass, - -- The reference scan reads a link's TARGET STRING (the NAR - -- carries it) and never the bytes behind the link. - runTestM "scanReferences scans link targets, not linked bytes" $ do - tmpBase <- getTemporaryDirectory - let base = tmpBase "nova-nix-test-scan-links" - outside = base "outside" - scanDir = base "tree" - inTargetHash = T.replicate 32 "a" - outsideHash = T.replicate 32 "b" - inTarget = StorePath inTargetHash "dep1" - outsideOnly = StorePath outsideHash "dep2" - Dir.removePathForcibly base - createDirectoryIfMissing True outside - createDirectoryIfMissing True scanDir - -- outsideOnly's hash exists only in file bytes OUTSIDE the - -- tree, reachable through a link; inTarget's exists only in - -- a link's target string. - BS.writeFile - (outside "secret.txt") - (TE.encodeUtf8 ("/nix/store/" <> outsideHash <> "-dep2")) - Dir.createFileLink (outside "secret.txt") (scanDir "spy-link") - Dir.createFileLink - ("/nix/store/" <> T.unpack inTargetHash <> "-dep1/bin/tool") - (scanDir "dep-link") - Dir.createDirectoryLink scanDir (scanDir "loop") - found <- timeout walkWatchdogMicros (scanReferences [inTarget, outsideOnly] scanDir) - Dir.removePathForcibly base - pure $ case found of - Nothing -> Fail "scan did not terminate on a link cycle" - Just refs -> assertEqual "scanned refs" [inTarget] refs, - -- copyPathInto replicates every link kind, so the NAR bytes - - -- and the hash a cache signs - are identical whether an output - -- was renamed or copied across volumes. - runTestM "copyPathInto replicates links and preserves NAR bytes" $ do - tmpBase <- getTemporaryDirectory - let base = tmpBase "nova-nix-test-copy-links" - src = base "src" - dest = base "dest" - Dir.removePathForcibly base - createDirectoryIfMissing True (src "subdir") - BS.writeFile (src "file.txt") "payload" - BS.writeFile (src "subdir" "inner.txt") "inner" - Dir.createFileLink "file.txt" (src "rel-link") - Dir.createDirectoryLink "subdir" (src "dir-link") - Dir.createFileLink "missing.txt" (src "dangling") - copyPathInto src dest - relIsLink <- Dir.pathIsSymbolicLink (dest "rel-link") - relTarget <- Dir.getSymbolicLinkTarget (dest "rel-link") - dirIsLink <- Dir.pathIsSymbolicLink (dest "dir-link") - danglingIsLink <- Dir.pathIsSymbolicLink (dest "dangling") - srcNarHash <- CHash.formatNixHash . CHash.hashBytes . NAR.serialise <$> NAR.serialiseFromPath src - destNarHash <- CHash.formatNixHash . CHash.hashBytes . NAR.serialise <$> NAR.serialiseFromPath dest - Dir.removePathForcibly base - pure $ - if relIsLink && dirIsLink && danglingIsLink && relTarget == "file.txt" - then assertEqual "copied NAR hash" srcNarHash destNarHash - else - Fail - ( "rel-link/dir-link/dangling as links: " - <> T.pack (show (relIsLink, dirIsLink, danglingIsLink)) - <> ", rel target: " - <> T.pack (show relTarget) - ) - ] - --- | Pure ordering for the store's symlink second pass: each link --- follows the pending links its target resolves at or through, and --- cycle members fall out at the end in input order. -testLinkOrdering :: IO [Bool] -testLinkOrdering = do - putStrLn "store/link-ordering" - let root = "out" - -- The fixtures are ASCII: one path unit per character, both ways, - -- on every platform. - osPath = OP.pack . map OP.unsafeFromChar - fromOsPath = map OP.toChar . OP.unpack - orderedLinks pending = map (fromOsPath . fst) (orderLinks [(osPath link, osPath target) | (link, target) <- pending]) - sequence - [ runTest "chain orders targets first" $ - let pending = [(root "l1", "l2"), (root "l2", "l3"), (root "l3", "real")] - in assertEqual - "chain" - [root "l3", root "l2", root "l1"] - (orderedLinks pending), - runTest "already-ordered chain is stable" $ - let pending = [(root "l3", "real"), (root "l2", "l3"), (root "l1", "l2")] - in assertEqual - "stable" - [root "l3", root "l2", root "l1"] - (orderedLinks pending), - runTest "link through a linked directory follows it" $ - let pending = [(root "a", "dirlink/x"), (root "dirlink", "realdir")] - in assertEqual - "through-dir" - [root "dirlink", root "a"] - (orderedLinks pending), - runTest "parent-relative target orders after its link" $ - let pending = [(root "sub" "l", "../other"), (root "other", "real")] - in assertEqual - "dotdot" - [root "other", root "sub" "l"] - (orderedLinks pending), - runTest "cycle members keep input order at the end" $ - let pending = [(root "a", "b"), (root "b", "a"), (root "c", "real")] - in assertEqual - "cycle" - [root "c", root "a", root "b"] - (orderedLinks pending), - runTest "self-target link survives to the fallback" $ - assertEqual - "self" - [root "x"] - (orderedLinks [(root "x", "x")]), - runTestM "long chain orders in linear time" $ do - -- 20000 links each targeting the next: the ready-set rounds - -- this replaced were quadratic here. - let chain = - [ (root ("l" <> show i), "l" <> show (i + 1)) - | i <- [1 :: Int .. 20000] - ] - ++ [(root "l20001", "real")] - complete = length (orderedLinks chain) == length chain - outcome <- timeout walkWatchdogMicros (evaluate complete) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "ordering dropped links" - Nothing -> Fail "ordering did not return promptly" - ] - --- --------------------------------------------------------------------------- --- Tests: fromATerm + Derivation Output Population (Phase 2, Batch 3) --- --------------------------------------------------------------------------- - --- | A simple test derivation for round-trip testing. -simpleTestDrv :: Derivation -simpleTestDrv = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello-1.0", - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/nix/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-bash-5.2/bin/bash", - drvArgs = ["-e", "/nix/store/cccccccccccccccccccccccccccccccc-stdenv/setup"], - drvEnv = Map.fromList [("name", "hello-1.0"), ("system", "x86_64-linux")] - } - --- | A complex test derivation with multiple outputs, input drvs, and input srcs. -complexTestDrv :: Derivation -complexTestDrv = - Derivation - { drvOutputs = - [ DerivationOutput "dev" (StorePath "dddddddddddddddddddddddddddddddd" "pkg-2.0-dev") "" "", - DerivationOutput "out" (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "pkg-2.0") "" "" - ], - drvInputDrvs = - Map.fromList - -- Hash fixtures stay inside the nix-base32 alphabet (no e o u t): - -- fromATerm parses these through parseStorePath, which now - -- charset-checks the hash component. - [ (StorePath "cccccccccccccccccccccccccccccccc" "dep1.drv", ["out"]), - (StorePath "ffffffffffffffffffffffffffffffff" "dep2.drv", ["lib", "out"]) - ], - drvInputSrcs = [StorePath "gggggggggggggggggggggggggggggggg" "source.tar.gz"], - drvPlatform = Aarch64_Darwin, - drvBuilder = "/nix/store/hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh-bash/bin/bash", - drvArgs = ["-e", "build.sh"], - drvEnv = - Map.fromList - [ ("buildInputs", "/nix/store/cccccccccccccccccccccccccccccccc-dep1"), - ("name", "pkg-2.0"), - ("out", "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-pkg-2.0"), - ("system", "aarch64-darwin") - ] - } - -testFromATerm :: IO [Bool] -testFromATerm = do - putStrLn "derivation/fromATerm" - sequence - [ -- Round-trip: simple derivation - runTest "fromATerm round-trip simple" $ - assertEqual "simple round-trip" (Right simpleTestDrv) (fromATerm (toATerm simpleTestDrv)), - -- Round-trip: complex derivation - runTest "fromATerm round-trip complex" $ - assertEqual "complex round-trip" (Right complexTestDrv) (fromATerm (toATerm complexTestDrv)), - -- A .drv read from disk is input: an output name that violates the - -- store-name rules (here a traversal shape that would later join - -- the build dir) must refuse at parse. - runTest "fromATerm rejects a traversal-shaped output name" $ - let evil = - simpleTestDrv - { drvOutputs = - [DerivationOutput "../evil" (StorePath (T.replicate 32 "a") "pkg") "" ""] - } - in case fromATerm (toATerm evil) of - Left _ -> Pass - Right _ -> Fail "parsed a drv with a traversal output name", - -- drv4: the modulo-substitution section merges input-drv entries that - -- share a modulo-hash key, unioning their output-name sets, so it is - -- byte-identical to the already-merged form. (Just subs replaces the - -- whole input-drv section, so simpleTestDrv's own inputs are irrelevant.) - runTest "inputDrvsSubst merges equal modulo keys" $ - assertEqual - "subst-merge" - (toATermForHash False (Just [("00000000", ["dev", "out"])]) simpleTestDrv) - (toATermForHash False (Just [("00000000", ["out"]), ("00000000", ["dev"])]) simpleTestDrv), - runTest "inputDrvsSubst unions and dedups merged out-names" $ - assertEqual - "subst-union" - (toATermForHash False (Just [("aabbccdd", ["dev", "out"])]) simpleTestDrv) - (toATermForHash False (Just [("aabbccdd", ["out"]), ("aabbccdd", ["out", "dev"])]) simpleTestDrv), - -- Distinct keys are untouched: still one entry each, ascending by key. - runTest "inputDrvsSubst preserves distinct keys in order" $ - assertEqual - "subst-distinct" - (toATermForHash False (Just [("00000000", ["out"]), ("11111111", ["out"])]) simpleTestDrv) - (toATermForHash False (Just [("11111111", ["out"]), ("00000000", ["out"])]) simpleTestDrv), - -- Round-trip: empty derivation (no outputs, no inputs, no args, no env) - runTest "fromATerm round-trip empty" $ - let emptyDrv = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/true", - drvArgs = [], - drvEnv = Map.empty - } - in assertEqual "empty round-trip" (Right emptyDrv) (fromATerm (toATerm emptyDrv)), - -- Reject empty string - runTest "fromATerm rejects empty" $ - assertLeft "empty" (fromATerm ""), - -- Reject malformed - runTest "fromATerm rejects malformed" $ - assertLeft "malformed" (fromATerm "NotADerivation"), - -- Reject truncated - runTest "fromATerm rejects truncated" $ - assertLeft "truncated" (fromATerm "Derive(["), - -- Escaping round-trip: strings with special chars - runTest "fromATerm escaping round-trip" $ - let escapeDrv = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "esc-test", - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = X86_64_Linux, - drvBuilder = "/bin/bash", - drvArgs = ["-c", "echo \"hello\nworld\""], - drvEnv = Map.fromList [("msg", "line1\nline2\ttab\\slash")] - } - in assertEqual "escape round-trip" (Right escapeDrv) (fromATerm (toATerm escapeDrv)), - -- A non-standard escape keeps the byte and drops the backslash, - -- matching upstream's .drv string parser. - runTest "fromATerm drops the backslash on a non-standard escape" $ - let aterm = "Derive([(\"out\",\"/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x\",\"\",\"\")],[],[],\"x86_64-linux\",\"/bin/sh\",[],[(\"k\",\"a\\xb\")])" - in assertRight "nonstandard escape" (fromATerm aterm) $ \drv -> - assertEqual "escape dropped" (Just "axb") (Map.lookup "k" (drvEnv drv)), - -- writeDrv writes correct ATerm - runTestM "writeDrv writes correct ATerm" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-writeDrv" - removeIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "test.drv" - destFile = storePathToFilePath (stDir store) sp - writeDrv store simpleTestDrv sp - contents <- BS.readFile destFile - closeStore store - removeIfExists tmpStore - pure (assertEqual "writeDrv content" (toATerm simpleTestDrv) contents), - -- The .drv closure registers as store objects: a row for every - -- recipe plus edges to its input sources and input .drvs, so an - -- output reference scan that names an input .drv resolves instead - -- of failing the registration batch. - runTestM "writeDrvClosure registers recipes with their references" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-drv-closure" - sd = StoreDir tmpStore - removeIfExists tmpStore - store <- openStore sd - let srcSp = StorePath "gggggggggggggggggggggggggggggggg" "source.tar.gz" - drvASp = StorePath "cccccccccccccccccccccccccccccccc" "dep1.drv" - drvBSp = StorePath "dddddddddddddddddddddddddddddddd" "top.drv" - drvB = - simpleTestDrv - { drvInputDrvs = Map.fromList [(drvASp, ["out"])], - drvInputSrcs = [srcSp] - } - -- The source row registers first, as in the build driver, where - -- materializeEvalSources precedes the closure write. - registerPath (stDB store) (PathRegistration srcSp "sha256:0" 0 Nothing []) - writeDrvClosure - store - ( Map.fromList - [ (storePathToText defaultStoreDir drvASp, toATerm simpleTestDrv), - (storePathToText defaultStoreDir drvBSp, toATerm drvB) - ] - ) - validA <- isValid store drvASp - validB <- isValid store drvBSp - refsB <- queryReferences (stDB store) drvBSp - closeStore store - removeIfExists tmpStore - let expectedRefs = - sort - [ T.pack (storePathToFilePath sd drvASp), - T.pack (storePathToFilePath sd srcSp) - ] - pure $ - if not validA - then Fail "input .drv not registered" - else - if not validB - then Fail "root .drv not registered" - else assertEqual "drv references" expectedRefs (sort refsB), - -- The recorded derivation populates drvOutputs. These three read the - -- Derivation the session records, which only the IO evaluator keeps. - runTestM "derivationStrict populates drvOutputs" $ do - tmpBase <- getTemporaryDirectory - result <- evalDerivationIO tmpBase "derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }" - pure $ assertRight "drvOutputs" result $ \drv -> - case drvOutputs drv of - [] -> Fail "drvOutputs is empty" - (firstOut : _) -> - if doName firstOut == "out" - then Pass - else Fail ("first output name: " <> doName firstOut), - -- The .drv lists outputs sorted by name, as upstream writes them; the - -- declared order lives in the value's outputs and all. - runTestM "derivationStrict multi-output" $ do - tmpBase <- getTemporaryDirectory - result <- evalDerivationIO tmpBase "derivation { name = \"multi\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [\"out\" \"dev\"]; }" - pure $ assertRight "multi-output" result $ \drv -> - let names = map doName (drvOutputs drv) - in if names == ["dev", "out"] - then Pass - else Fail ("output names: " <> T.pack (show names)), - -- The .drv env carries the output paths ($out, ...) and the build - -- attributes, and no "drvPath" key - matching C++ Nix, which never - -- writes one. - runTestM "derivationStrict populates drvEnv" $ do - tmpBase <- getTemporaryDirectory - result <- evalDerivationIO tmpBase "derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }" - pure $ assertRight "drvEnv" result $ \drv -> - case (Map.lookup "out" (drvEnv drv), Map.lookup "name" (drvEnv drv)) of - (Just op, Just "test") - | "/nix/store/" `BS.isPrefixOf` op -> Pass - _ -> Fail ("drvEnv keys: " <> T.pack (show (Map.toList (drvEnv drv)))) - ] - --- --------------------------------------------------------------------------- --- Tests: Builder (Phase 2, Batch 4) --- --------------------------------------------------------------------------- - --- | Create a minimal Derivation for builder tests. --- The shell path is discovered once via 'findTestShell' and threaded through. --- All scripts are POSIX shell - bash is used on every platform. -mkTestBuildDrv :: Text -> StorePath -> Text -> Derivation -mkTestBuildDrv shell outSP script = - Derivation - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = outSP, - doHashAlgo = "", - doHash = "" - } - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = TE.encodeUtf8 shell, - drvArgs = ["-c", TE.encodeUtf8 script], - drvEnv = Map.fromList [("name", "test-build"), ("system", TE.encodeUtf8 (platformToText currentPlatform))] - } - --- | 'mkTestBuildDrv' with a fixed-output spec: registration must --- re-verify the placed bytes against the declared digest. -mkFixedOutputDrv :: Text -> StorePath -> Text -> Text -> Text -> Derivation -mkFixedOutputDrv shell outSP script algoField hexDigest = - (mkTestBuildDrv shell outSP script) - { drvOutputs = - [ DerivationOutput - { doName = "out", - doPath = outSP, - doHashAlgo = algoField, - doHash = hexDigest - } - ] - } - -testBuilder :: IO [Bool] -testBuilder = do - putStrLn "builder" - shell <- findTestShell - sequence - [ -- Build simple script that writes to $out - runTestM "build simple script" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder1" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa1" "simple-test" - drv = mkTestBuildDrv shell outSP "mkdir -p $out && echo hello > $out/result.txt" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder1-tmp"} - result <- buildDerivation config store drv - closeStore store - let ret = case result of - BuildSuccess sp -> assertEqual "success path" outSP sp - BuildFailure msg code -> Fail ("build failed (" <> T.pack (show code) <> "): " <> msg) - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure ret, - -- Build with specific file content - runTestM "build writes file content" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder2" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "content-test" - drv = mkTestBuildDrv shell outSP "mkdir -p $out && echo 'test content 42' > $out/data.txt" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder2-tmp"} - result <- buildDerivation config store drv - ret <- case result of - BuildSuccess _ -> do - let dataFile = storePathToFilePath (stDir store) outSP "data.txt" - content <- TIO.readFile dataFile - pure $ - if T.strip content == "test content 42" - then Pass - else Fail ("unexpected content: " <> content) - BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure ret, - -- Missing builder fails - runTestM "missing builder fails" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder3" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "cccccccccccccccccccccccccccccccc" "fail-test" - drv = - Derivation - { drvOutputs = [DerivationOutput "out" outSP "" ""], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = "/nonexistent/builder", - drvArgs = [], - drvEnv = Map.empty - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder3-tmp"} - result <- buildDerivation config store drv - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure _ _ -> Pass - BuildSuccess _ -> Fail "expected failure for missing builder", - -- Exit failure returns error code - runTestM "exit failure returns error code" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder4" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "dddddddddddddddddddddddddddddddd" "exitfail" - drv = mkTestBuildDrv shell outSP "exit 42" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder4-tmp"} - result <- buildDerivation config store drv - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure _ code -> if code == 42 then Pass else Fail ("expected code 42, got " <> T.pack (show code)) - BuildSuccess _ -> Fail "expected failure", - -- A builder that THROWS (nonexistent executable) must not leak the - -- deterministic build dir: stale contents would fake an archive - -- collision on the next builtin:unpack run of the same drv. - runTestM "crashed build removes its build dir" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-leak" - tmpBuild = tmpBase "nova-nix-test-builder-leak-tmp" - forceRemoveIfExists tmpStore - forceRemoveIfExists tmpBuild - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "pppppppppppppppppppppppppppppppp" "leaktest" - drv = mkTestBuildDrv (T.pack (tmpBase "no-such-builder.exe")) outSP "unused" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBuild} - result <- buildDerivation config store drv - leftovers <- do - exists <- doesDirectoryExist tmpBuild - if exists then Dir.listDirectory tmpBuild else pure [] - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists tmpBuild - pure $ case result of - BuildFailure _ _ - | null leftovers -> Pass - | otherwise -> Fail ("build dir leaked: " <> T.pack (show leftovers)) - BuildSuccess _ -> Fail "expected failure for a nonexistent builder", - -- A derivation carrying __json is built as upstream builds one: its - -- attributes, outputs included, arrive as .attrs.json and .attrs.sh - -- and none of them as a variable. The builder copies both files - -- out, finding $out where a structured builder must, in the files. - runTestM "structured attributes reach the builder as .attrs.json and .attrs.sh" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-structured" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "ssssssssssssssssssssssssssssssss" "structured" - outText = T.pack (storePathToFilePath (stDir store) outSP) - attrs = - "{\"greeting\":\"it's\",\"list\":[\"a\",1,true,null],\"nested\":{\"k\":\"v\"},\"outputs\":[\"out\"],\"self\":\"" - <> hashPlaceholder "out" - <> "/bin\"}" - script = - T.unlines - [ "probe=\"${out-unset}|${__json-unset}|${greeting-unset}\"", - "out=$(sed -n \"/^declare -A outputs=/s/.*\\['out'\\]='\\([^']*\\)'.*/\\1/p\" \"$NIX_ATTRS_SH_FILE\")", - "mkdir \"$out\" && cp \"$NIX_ATTRS_JSON_FILE\" \"$out/attrs.json\" && cp \"$NIX_ATTRS_SH_FILE\" \"$out/attrs.sh\" && printf '%s' \"$probe\" > \"$out/env\"" - ] - drv = - (mkTestBuildDrv shell outSP script) - { drvEnv = Map.fromList [("__json", TE.encodeUtf8 attrs), ("out", "/nix/store/ssssssssssssssssssssssssssssssss-structured")] - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-structured-tmp"} - jsonPath = "\"" <> T.replace "\\" "\\\\" outText <> "\"" - expectedJson = - "{\"greeting\":\"it's\",\"list\":[\"a\",1,true,null],\"nested\":{\"k\":\"v\"},\"outputs\":{\"out\":" - <> jsonPath - <> "},\"self\":" - <> T.dropEnd 1 jsonPath - <> "/bin\"}" - expectedShell = - T.concat - [ "declare greeting='it'\\''s'\n", - "declare -a list=('a' 1 1 '' )\n", - "declare -A nested=(['k']='v' )\n", - "declare -A outputs=(['out']='" <> outText <> "' )\n", - "declare self='" <> outText <> "/bin'\n" - ] - result <- buildDerivation config store drv - ret <- case result of - BuildSuccess _ -> do - let outDir = storePathToFilePath (stDir store) outSP - json <- BS.readFile (outDir "attrs.json") - shellText <- BS.readFile (outDir "attrs.sh") - probe <- BS.readFile (outDir "env") - pure $ - assertEqual "attrs.json" (TE.encodeUtf8 expectedJson) json - `andThen` assertEqual "attrs.sh" (TE.encodeUtf8 expectedShell) shellText - `andThen` assertEqual "no attribute is a variable" "unset|unset|unset" probe - BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure ret, - -- Output at expected path - runTestM "output at expected store path" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder5" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "cccccccccccccccccccccccccccccccc" "pathtest" - drv = mkTestBuildDrv shell outSP "mkdir -p $out && touch $out/marker" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder5-tmp"} - result <- buildDerivation config store drv - ret <- case result of - BuildSuccess _ -> do - let expectedDir = storePathToFilePath (stDir store) outSP - exists <- doesDirectoryExist expectedDir - pure $ if exists then Pass else Fail "output dir doesn't exist at expected path" - BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure ret, - -- A leftover tree at the output path that is NOT valid in the DB has - -- unknowable integrity (interrupted earlier run); the build replaces - -- it with the fresh output - upstream's delete-then-move - clearing - -- read-only marks rather than adopting stale bytes. - runTestM "stale leftover output is replaced by the fresh build" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-stale" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq" "staletest" - drv = mkTestBuildDrv shell outSP "mkdir -p $out && echo fresh > $out/data.txt" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-stale-tmp"} - targetPath = storePathToFilePath (stDir store) outSP - -- Fake the interrupted run: stale read-only content at the output's - -- store location, never registered. - createDirectoryIfMissing True targetPath - TIO.writeFile (targetPath "data.txt") "stale" - setReadOnly targetPath - result <- buildDerivation config store drv - content <- TIO.readFile (targetPath "data.txt") - registered <- isValid store outSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildSuccess _ - | T.strip content == "fresh" && registered -> Pass - | otherwise -> Fail ("expected fresh registered content, got: " <> content) - BuildFailure msg code -> Fail ("build failed (" <> T.pack (show code) <> "): " <> msg), - -- Path registered in DB after build - runTestM "path registered in DB" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder6" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "ffffffffffffffffffffffffffffffff" "dbtest" - drv = mkTestBuildDrv shell outSP "mkdir -p $out && touch $out/file" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder6-tmp"} - result <- buildDerivation config store drv - ret <- case result of - BuildSuccess _ -> do - valid <- isValid store outSP - pure $ if valid then Pass else Fail "path not valid in DB after build" - BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure ret, - -- Multiple outputs - runTestM "multiple outputs" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder7" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "ggggggggggggggggggggggggggggggg1" "multi" - devSP = StorePath "ggggggggggggggggggggggggggggggg2" "multi-dev" - drv = - Derivation - { drvOutputs = - [ DerivationOutput "out" outSP "" "", - DerivationOutput "dev" devSP "" "" - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = TE.encodeUtf8 shell, - drvArgs = ["-c", "mkdir -p $out && echo lib > $out/lib.txt && mkdir -p $dev && echo headers > $dev/include.h"], - drvEnv = Map.fromList [("name", "multi")] - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder7-tmp"} - result <- buildDerivation config store drv - ret <- case result of - BuildSuccess _ -> do - outExists <- doesDirectoryExist (storePathToFilePath (stDir store) outSP) - devExists <- doesDirectoryExist (storePathToFilePath (stDir store) devSP) - pure $ - if outExists && devExists - then Pass - else Fail ("out exists=" <> T.pack (show outExists) <> " dev exists=" <> T.pack (show devExists)) - BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure ret, - runTestM "partial rebuild failure preserves a valid sibling output" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-partial-valid" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "ggggggggggggggggggggggggggggggg3" "partial-main" - devSP = StorePath "ggggggggggggggggggggggggggggggg4" "partial-dev" - mkDrv script = - Derivation - { drvOutputs = - [ DerivationOutput "out" outSP "" "", - DerivationOutput "dev" devSP "" "" - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = TE.encodeUtf8 shell, - drvArgs = ["-c", script], - drvEnv = Map.fromList [("name", "partial-valid")] - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-partial-valid-tmp"} - devPath = storePathToFilePath (stDir store) devSP - initial <- buildDerivation config store (mkDrv "mkdir -p $out $dev && echo main > $out/value && echo keep > $dev/value") - deleted <- deleteStorePathRaw store (spHash outSP <> "-" <> spName outSP) - rebuilt <- buildDerivation config store (mkDrv "mkdir -p $out && echo partial > $out/value && exit 1") - devOnDisk <- Dir.doesPathExist devPath - devValid <- isValid store devSP - devContents <- if devOnDisk then T.strip <$> TIO.readFile (devPath "value") else pure "" - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - let deletedFirst = either (const False) (\outcome -> doRowRemoved outcome && doTreeRemoved outcome) deleted - pure $ case (initial, rebuilt) of - (BuildSuccess _, BuildFailure _ _) - | deletedFirst && devOnDisk && devValid && devContents == "keep" -> Pass - | otherwise -> Fail "failed partial rebuild removed or changed its valid sibling output" - _ -> Fail "partial rebuild test setup did not reach the expected states", - -- The shape the reviewer's blocker had: a package with a dev output - -- has ONE builder writing both, so a partial rebuild hands that - -- builder a $dev that is valid, registered and sealed read-only. - -- Writing there has to work and must not disturb what is registered. - runTestM "partial rebuild writes both outputs and leaves the valid one alone" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-partial-both" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "ggggggggggggggggggggggggggggggg5" "both-main" - devSP = StorePath "ggggggggggggggggggggggggggggggg6" "both-dev" - mkDrv script = - Derivation - { drvOutputs = - [ DerivationOutput "out" outSP "" "", - DerivationOutput "dev" devSP "" "" - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = TE.encodeUtf8 shell, - drvArgs = ["-c", script], - drvEnv = Map.fromList [("name", "partial-both")] - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-partial-both-tmp"} - devPath = storePathToFilePath (stDir store) devSP - outPath = storePathToFilePath (stDir store) outSP - -- Both outputs, every time, as a real multi-output builder does. - writeBoth v = "mkdir -p $out $dev && echo " <> v <> " > $out/value && echo " <> v <> " > $dev/value" - initial <- buildDerivation config store (mkDrv (writeBoth "first")) - deleted <- deleteStorePathRaw store (spHash outSP <> "-" <> spName outSP) - rebuilt <- buildDerivation config store (mkDrv (writeBoth "second")) - outContents <- T.strip <$> TIO.readFile (outPath "value") - devContents <- T.strip <$> TIO.readFile (devPath "value") - devValid <- isValid store devSP - outValid <- isValid store outSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - let deletedFirst = either (const False) (\outcome -> doRowRemoved outcome && doTreeRemoved outcome) deleted - pure $ case (initial, rebuilt) of - (BuildSuccess _, BuildSuccess _) - | not deletedFirst -> Fail "partial rebuild setup did not delete the first output" - -- The valid sibling keeps the bytes its NarHash describes: the - -- builder wrote to a scratch path, not to it. - | devContents /= "first" -> Fail ("valid sibling was overwritten: " <> devContents) - | outContents /= "second" -> Fail ("rebuilt output has the wrong contents: " <> outContents) - | not (outValid && devValid) -> Fail "both outputs should be valid after the rebuild" - | otherwise -> Pass - (_, BuildFailure msg _) -> Fail ("a builder writing both outputs failed the rebuild: " <> msg) - _ -> Fail "partial rebuild test setup did not reach the expected states", - -- The scratch path is discarded after the build, so an output that - -- records it would be registered with a reference to nothing. We do - -- not rewrite the contents the way upstream does; we refuse. - runTestM "an output recording a valid sibling's scratch path fails the build" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-scratch-leak" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "ggggggggggggggggggggggggggggggg7" "leak-main" - devSP = StorePath "ggggggggggggggggggggggggggggggg8" "leak-dev" - mkDrv script = - Derivation - { drvOutputs = - [ DerivationOutput "out" outSP "" "", - DerivationOutput "dev" devSP "" "" - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = TE.encodeUtf8 shell, - drvArgs = ["-c", script], - drvEnv = Map.fromList [("name", "scratch-leak")] - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-scratch-leak-tmp"} - devPath = storePathToFilePath (stDir store) devSP - initial <- buildDerivation config store (mkDrv "mkdir -p $out $dev && echo first > $out/value && echo first > $dev/value") - deleted <- deleteStorePathRaw store (spHash outSP <> "-" <> spName outSP) - -- \$dev now names a scratch path, and the builder bakes it into $out - -- the way a compiler driver or a libtool archive would. - rebuilt <- buildDerivation config store (mkDrv "mkdir -p $out $dev && echo $dev > $out/recorded && echo first > $dev/value") - devContents <- T.strip <$> TIO.readFile (devPath "value") - devValid <- isValid store devSP - outValid <- isValid store outSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - let deletedFirst = either (const False) (\outcome -> doRowRemoved outcome && doTreeRemoved outcome) deleted - pure $ case (initial, rebuilt) of - (BuildSuccess _, BuildFailure msg _) - | not deletedFirst -> Fail "scratch-leak setup did not delete the first output" - | not ("scratch path" `T.isInfixOf` msg) -> Fail ("expected a scratch-path refusal, got: " <> msg) - -- The refusal must not cost the sibling that was already valid. - | not devValid || devContents /= "first" -> Fail "the refusal disturbed the valid sibling" - | outValid -> Fail "the refused output registered anyway" - | otherwise -> Pass - (_, BuildSuccess _) -> Fail "an output naming a discarded scratch path was accepted" - _ -> Fail "scratch-leak test setup did not reach the expected states", - -- Builder succeeds but doesn't create $out, so the build fails - runTestM "missing output fails build" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-noout" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" "nooutput" - drv = mkTestBuildDrv shell outSP "echo 'forgot to create output'" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-noout-tmp"} - result <- buildDerivation config store drv - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure msg _ -> - if T.isInfixOf "outputs missing" msg - then Pass - else Fail ("expected 'outputs missing' error, got: " <> msg) - BuildSuccess _ -> Fail "expected failure when builder doesn't create $out", - runTestM "missing sibling output cleans produced orphan" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-partial-missing" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiii1" "partial-output" - devSP = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiii2" "missing-output" - drv = - Derivation - { drvOutputs = - [ DerivationOutput "out" outSP "" "", - DerivationOutput "dev" devSP "" "" - ], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = TE.encodeUtf8 shell, - drvArgs = ["-c", "mkdir -p $out && echo orphan > $out/value"], - drvEnv = Map.fromList [("name", "partial-missing")] - } - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-partial-missing-tmp"} - outPath = storePathToFilePath (stDir store) outSP - devPath = storePathToFilePath (stDir store) devSP - result <- buildDerivation config store drv - outOnDisk <- Dir.doesPathExist outPath - devOnDisk <- Dir.doesPathExist devPath - outValid <- isValid store outSP - devValid <- isValid store devSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure msg _ - | "outputs missing" `T.isInfixOf` msg && not outOnDisk && not devOnDisk && not outValid && not devValid -> Pass - | otherwise -> Fail ("missing-output failure left store state behind: " <> msg) - BuildSuccess _ -> Fail "partial-output builder unexpectedly succeeded", - -- File output (not directory) should succeed - runTestM "file output succeeds" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder-fileout" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjj" "fileout" - drv = mkTestBuildDrv shell outSP "echo 'I am a file output' > $out" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-fileout-tmp"} - result <- buildDerivation config store drv - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildSuccess sp -> assertEqual "file output path" outSP sp - BuildFailure msg code -> Fail ("file output build failed (" <> T.pack (show code) <> "): " <> msg), - -- Cleanup after failure - runTestM "cleanup after failure" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-builder8" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let outSP = StorePath "hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh" "cleantest" - drv = mkTestBuildDrv shell outSP "exit 1" - tmpDir = tmpBase "nova-nix-test-builder8-tmp" - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpDir} - _ <- buildDerivation config store drv - -- Build dir should be cleaned up - let buildDir = tmpDir T.unpack (spHash outSP) - buildDirExists <- doesDirectoryExist buildDir - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists tmpDir - pure $ if not buildDirExists then Pass else Fail "build dir not cleaned up after failure", - -- Fixed-output: registration re-checks the placed bytes - runTestM "fixed-output flat output verifies and registers" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-fo1" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let payload = "fixed output payload\n" - digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" payload) - outSP = StorePath "ffffffffffffffffffffffffffffff01" "fo-flat-good" - drv = mkFixedOutputDrv shell outSP "printf 'fixed output payload\\n' > $out" "sha256" digest - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo1-tmp"} - result <- buildDerivation config store drv - registered <- isValid store outSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildSuccess _ - | registered -> Pass - | otherwise -> Fail "built but not registered valid" - BuildFailure msg code -> Fail ("expected success (" <> T.pack (show code) <> "): " <> msg), - -- The impureEnvVars carve-out (#185): a fixed-output derivation's - -- listed ambient variables reach the scrubbed build, an absent - -- listed name arrives as the EMPTY STRING (present, not omitted, - -- upstream's value_or("")), and everything else stays scrubbed. - runTestM "impureEnvVars reach a fixed-output build, absent names as empty" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-impure1" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - setEnv "NOVA_TEST_IMPURE" "proxy-ok" - unsetEnv "NOVA_TEST_ABSENT" - let payload = "fixed output payload\n" - digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" payload) - outSP = StorePath "ffffffffffffffffffffffffffffff03" "fo-impure-env" - script = "[ \"$NOVA_TEST_IMPURE\" = \"proxy-ok\" ] && [ \"${NOVA_TEST_ABSENT+set}\" = \"set\" ] && [ -z \"$NOVA_TEST_ABSENT\" ] && printf 'fixed output payload\\n' > $out" - baseDrv = mkFixedOutputDrv shell outSP script "sha256" digest - drv = baseDrv {drvEnv = Map.insert "impureEnvVars" "NOVA_TEST_IMPURE NOVA_TEST_ABSENT" (drvEnv baseDrv)} - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-impure1-tmp"} - result <- buildDerivation config store drv - unsetEnv "NOVA_TEST_IMPURE" - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildSuccess _ -> Pass - BuildFailure msg code -> Fail ("carve-out did not reach the build (" <> T.pack (show code) <> "): " <> msg), - runTestM "impureEnvVars are ignored for a non-fixed-output build" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-impure2" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - setEnv "NOVA_TEST_IMPURE" "must-not-leak" - let outSP = StorePath "ffffffffffffffffffffffffffffff04" "impure-scrubbed" - script = "[ -z \"${NOVA_TEST_IMPURE-}\" ] && echo ok > $out" - baseDrv = mkTestBuildDrv shell outSP script - drv = baseDrv {drvEnv = Map.insert "impureEnvVars" "NOVA_TEST_IMPURE" (drvEnv baseDrv)} - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-impure2-tmp"} - result <- buildDerivation config store drv - unsetEnv "NOVA_TEST_IMPURE" - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildSuccess _ -> Pass - BuildFailure msg code -> Fail ("ambient leaked into a non-fixed-output build (" <> T.pack (show code) <> "): " <> msg), - runTestM "fixed-output flat mismatch fails and removes the output" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-fo2" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" "expected content\n") - outSP = StorePath "ffffffffffffffffffffffffffffff02" "fo-flat-bad" - drv = mkFixedOutputDrv shell outSP "printf 'tampered content\\n' > $out" "sha256" digest - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo2-tmp"} - result <- buildDerivation config store drv - registered <- isValid store outSP - onDisk <- Dir.doesPathExist (storePathToFilePath (stDir store) outSP) - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure msg _ - | "hash mismatch" `T.isInfixOf` msg && not registered && not onDisk -> Pass - | otherwise -> - Fail - ( "wrong failure shape (valid=" - <> T.pack (show registered) - <> ", onDisk=" - <> T.pack (show onDisk) - <> "): " - <> msg - ) - BuildSuccess _ -> Fail "mismatched fixed output registered", - runTestM "fixed-output recursive tree verifies against its NAR hash" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-fo3" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let tree = NAR.NarDirectory [("data.txt", NAR.NarRegular False "inner bytes\n")] - digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" (NAR.serialise tree)) - outSP = StorePath "ffffffffffffffffffffffffffffff03" "fo-rec-good" - drv = mkFixedOutputDrv shell outSP "mkdir -p $out && printf 'inner bytes\\n' > $out/data.txt" "r:sha256" digest - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo3-tmp"} - result <- buildDerivation config store drv - registered <- isValid store outSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildSuccess _ - | registered -> Pass - | otherwise -> Fail "built but not registered valid" - BuildFailure msg code -> Fail ("expected success (" <> T.pack (show code) <> "): " <> msg), - runTestM "fixed-output recursive mismatch fails the build" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-fo4" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let tree = NAR.NarDirectory [("data.txt", NAR.NarRegular False "declared bytes\n")] - digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" (NAR.serialise tree)) - outSP = StorePath "ffffffffffffffffffffffffffffff04" "fo-rec-bad" - drv = mkFixedOutputDrv shell outSP "mkdir -p $out && printf 'other bytes\\n' > $out/data.txt" "r:sha256" digest - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo4-tmp"} - result <- buildDerivation config store drv - registered <- isValid store outSP - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure msg _ - | "hash mismatch" `T.isInfixOf` msg && not registered -> Pass - | otherwise -> Fail ("wrong failure shape: " <> msg) - BuildSuccess _ -> Fail "mismatched fixed output registered", - runTestM "fixed-output flat mode rejects a directory output" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-fo5" - forceRemoveIfExists tmpStore - store <- openStore (StoreDir tmpStore) - let digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" "whatever\n") - outSP = StorePath "ffffffffffffffffffffffffffffff05" "fo-flat-dir" - drv = mkFixedOutputDrv shell outSP "mkdir -p $out && printf 'x' > $out/f" "sha256" digest - config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo5-tmp"} - result <- buildDerivation config store drv - closeStore store - forceRemoveIfExists tmpStore - forceRemoveIfExists (bcTmpDir config) - pure $ case result of - BuildFailure msg _ - | "directory" `T.isInfixOf` msg -> Pass - | otherwise -> Fail ("wrong failure: " <> msg) - BuildSuccess _ -> Fail "directory output passed a flat fixed-output check" - ] - --- --------------------------------------------------------------------------- --- Tests: CLI Integration (Phase 2, Batch 5) --- --------------------------------------------------------------------------- - --- | A tree holding a reserved device stem, a colon and a trailing dot, --- names POSIX holds and Windows does not, in the order a sorted listing --- gives them. The colon follows more than one letter: bsdtar, which --- fetchTarball's extraction runs on macOS, drops a one-letter prefix --- such as @a:@ as a drive letter once @--strip-components@ has exposed --- it. -reservedNameFiles :: [(FilePath, BS.ByteString)] -reservedNameFiles = [("aux.c", "device\n"), ("dot.", "dot\n"), ("key:value", "colon\n")] - --- | Where upstream stores 'reservedNameFiles' as a coerced source --- directory named @src@ (nix-instantiate 2.33.2, @"${./src}"@) and as --- the tree of a fetchTarball (with @--store 'local?root=...'@, which --- holds it under exactly these names). -reservedNameSourcePath, reservedNameTarballPath :: StorePath -reservedNameSourcePath = StorePath "42hs0hrpla9b23iz9p3nj0px0np0jv6f" "src" -reservedNameTarballPath = StorePath "rlwykawmqrmdiq4xmcr4rf2zxf6y9k09" "source" - --- | End-to-end: eval .nix source, extract derivation, build, verify output. -evalAndBuild :: StoreDir -> Text -> IO (Either Text (BuildResult, Store)) -evalAndBuild storeDir source = do - case parseNix testBaseDir "" source of - Left err -> pure (Left ("parse error: " <> T.pack (show err))) - Right expr -> do - -- The SAME store the build below is given. Evaluating against the - -- platform default while building elsewhere is what let a store dir - -- honored on writes but not on reads pass the whole suite. - st <- newEvalState storeDir "." - evalResult <- runEvalIO st $ do - val <- eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr - -- What the CLI driver does: force drvPath, which runs - -- derivationStrict (so a missing required attr surfaces as an eval - -- error) and records the .drv the build reads back by that path. - case val of - VAttrs attrs | Just thunk <- attrSetLookup "drvPath" attrs -> do - pathVal <- force thunk - case pathVal of - VStr pathBytes _ -> lookupSessionDrv (bytesText pathBytes) - _ -> pure Nothing - _ -> pure Nothing - case evalResult of - Left err -> pure (Left ("eval error: " <> err)) - Right Nothing -> pure (Left "result is not a derivation") - Right (Just drv) -> do - store <- openStore storeDir - tmpBase <- getTemporaryDirectory - let config = (defaultBuildConfig storeDir) {bcTmpDir = tmpBase "nova-nix-e2e-tmp"} - -- What the CLI driver does before building, in the same - -- order: eval has no store DB handle, so anything it wrote - -- is registered here or not at all. Skipping it made this - -- harness unable to see a whole class of driver bug. - sourceCache <- readIORef (esSourcePathCache st) - storeWrites <- readIORef (esStoreWriteCache st) - materializeEvalSources store sourceCache - materializeEvalStoreWrites store storeWrites - result <- buildDerivation config store drv - pure (Right (result, store)) - -testE2E :: IO [Bool] -testE2E = do - putStrLn "cli/e2e" - shell <- findTestShell - sequence - [ -- End-to-end: eval -> build a simple derivation - runTestM "e2e eval -> build" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-e2e1" - forceRemoveIfExists tmpStore - -- Build the Nix source with the discovered shell path. - -- Nix strings use \\ for literal backslash, \" for literal quote. - let nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - e2eSource = - T.concat - [ "derivation { name = \"e2e-test\"; system = builtins.currentSystem; ", - "builder = \"" <> nixEscape shell <> "\"; ", - "args = [\"-c\" \"mkdir -p $out && echo e2e > $out/e2e.txt\"]; }" - ] - result <- evalAndBuild (StoreDir tmpStore) e2eSource - ret <- case result of - Left err -> pure (Fail err) - Right (BuildSuccess _, store) -> do - closeStore store - pure Pass - Right (BuildFailure msg code, store) -> do - closeStore store - pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - forceRemoveIfExists tmpStore - forceRemoveIfExists (tmpBase "nova-nix-e2e-tmp") - pure ret, - -- Every eval-time store writer must register, not only toFile: an - -- unrecorded write reaches drvInputSrcs and the build dies with - -- "references unregistered path". - runTestM "e2e eval-time store writes register as derivation inputs" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-e2e-inputs" - srcDir = tmpBase "nova-nix-test-e2e-inputs-src" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - drvWith srcExpr = - T.concat - [ "derivation { name = \"inputs-test\"; system = builtins.currentSystem; ", - "builder = \"" <> nixEscape shell <> "\"; ", - "args = [\"-c\" \"echo ok > $out\"]; ", - "src = " <> srcExpr <> "; }" - ] - forceRemoveIfExists tmpStore - forceRemoveIfExists srcDir - Dir.createDirectoryIfMissing True srcDir - writeFile (srcDir "f.txt") "content\n" - let cases = - [ ("toFile", "builtins.toFile \"note\" \"text\""), - -- A path LITERAL, not a string, so it must be spelled the - -- way the evaluator spells path values: the lexer rejects a - -- backslash, and a native Windows temp dir is full of them. - -- Through 'canonPathValue' rather than a separator replace, - -- because a backslash is an ordinary file-name character on - -- POSIX and only a separator on Windows. - ("path", "builtins.path { path = " <> canonPathValue (T.pack srcDir) <> "; name = \"sd\"; }") - ] - outcomes <- - mapM - ( \(label, expr) -> do - result <- evalAndBuild (StoreDir tmpStore) (drvWith expr) - pure (label, result) - ) - cases - let failures = - [ label <> ": " <> reason - | (label, result) <- outcomes, - Just reason <- - [ case result of - Left err -> Just err - Right (BuildFailure msg _, _) -> Just msg - Right (BuildSuccess _, _) -> Nothing - ] - ] - mapM_ - ( \(_, result) -> case result of - Right (_, store) -> closeStore store - Left _ -> pure () - ) - outcomes - forceRemoveIfExists tmpStore - forceRemoveIfExists srcDir - pure $ case failures of - [] -> Pass - errs -> Fail (T.intercalate "; " errs), - -- POSIX holds names Windows reserves, and upstream stores them as - -- their bytes there (#84). A coerced source and a fetchTarball - -- tree holding a device stem, a colon and a trailing dot restore - -- with exactly those names, under the paths upstream computes - -- for them ('reservedNameSourcePath'), as the raw copy they - -- replace stored them (#235). - runTestM "e2e sources holding names Windows reserves restore with their names" $ - if SI.os == "mingw32" - then Pass <$ putStrLn " SKIP a Windows volume cannot hold these names" - else do - tmpBase <- getTemporaryDirectory - environment <- getEnvironment - let root = tmpBase "nova-nix-test-e2e-names" - srcDir = root "src" - stage = root "stage" - tarball = root "names.tar.gz" - tmpStore = tmpBase "nova-nix-test-e2e-names-store" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - source = - T.concat - [ "derivation { name = \"names\"; system = builtins.currentSystem; ", - "builder = \"" <> nixEscape shell <> "\"; ", - "args = [\"-c\" \"echo ok > $out\"]; ", - "srcs = [ " <> canonPathValue (T.pack srcDir) <> " ", - "(builtins.fetchTarball \"file://" <> nixEscape (T.pack tarball) <> "\") ]; }" - ] - -- bsdtar would otherwise add AppleDouble entries for - -- any extended attributes the files carry. - tarProcess = - (Proc.proc "tar" ["-czf", tarball, "-C", stage, "top"]) - { Proc.env = Just (("COPYFILE_DISABLE", "1") : environment) - } - writeTree dir = do - createDirectoryIfMissing True dir - mapM_ (\(name, bytes) -> BS.writeFile (dir name) bytes) reservedNameFiles - storedAs store sp = do - let dest = storePathToFilePath (stDir store) sp - present <- doesDirectoryExist dest - if not present - then pure (Just (spName sp <> ": no tree at " <> T.pack dest)) - else do - names <- sort <$> Dir.listDirectory dest - contents <- traverse (BS.readFile . (dest )) names - valid <- isValid store sp - pure $ - if valid && zip names contents == reservedNameFiles - then Nothing - else Just (spName sp <> " valid " <> T.pack (show valid) <> ", stored as " <> T.pack (show (zip names contents))) - forceRemoveIfExists root - forceRemoveIfExists tmpStore - writeTree srcDir - writeTree (stage "top") - (tarCode, _, tarErr) <- Proc.readCreateProcessWithExitCode tarProcess "" - verdict <- case tarCode of - ExitFailure n -> pure (Fail ("tar exited " <> T.pack (show n) <> ": " <> T.pack tarErr)) - ExitSuccess -> do - built <- evalAndBuild (StoreDir tmpStore) source - case built of - Left err -> pure (Fail err) - Right (BuildFailure msg _, store) -> Fail msg <$ closeStore store - Right (BuildSuccess _, store) -> do - problems <- catMaybes <$> traverse (storedAs store) [reservedNameSourcePath, reservedNameTarballPath] - closeStore store - pure (if null problems then Pass else Fail (T.intercalate "; " problems)) - forceRemoveIfExists root - forceRemoveIfExists tmpStore - pure verdict, - -- The writer half of the eval-write pair: an interrupted earlier - -- run's truncated file at a toFile path must be rewritten, not - -- adopted on bare existence (adopting it used to register such a file - -- valid under the full content's hash, seal it read-only, and let a - -- build consume it). - runTestM "a truncated pre-existing toFile write is rewritten, not adopted" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-tofile-verify" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - goodText = "the full intended content" :: Text - goodBytes = TE.encodeUtf8 goodText - forceRemoveIfExists tmpStore - case makeTextPath "note" (sha256Digest goodBytes) [] of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let dest = storePathToFilePath (StoreDir tmpStore) sp - Dir.createDirectoryIfMissing True (takeDirectory dest) - BS.writeFile dest (TE.encodeUtf8 "the full") - let expr = - "derivation { name = \"tofile-verify\"; system = builtins.currentSystem; " - <> "builder = \"" - <> nixEscape shell - <> "\"; " - <> "args = [\"-c\" \"echo ok > $out\"]; " - <> "src = builtins.toFile \"note\" \"" - <> goodText - <> "\"; }" - result <- evalAndBuild (StoreDir tmpStore) expr - rewritten <- BS.readFile dest - outcome <- case result of - Left err -> pure (Fail err) - Right (BuildFailure msg _, store) -> closeStore store >> pure (Fail msg) - Right (BuildSuccess _, store) -> do - registered <- isValid store sp - closeStore store - pure $ - if rewritten == goodBytes && registered - then Pass - else Fail "adopted the truncated file instead of rewriting it" - forceRemoveIfExists tmpStore - pure outcome, - -- Same guarantee for the tree writer behind builtins.path: a - -- corrupted partial tree at the computed path is cleared and - -- re-unpacked, never adopted. - runTestM "a corrupted pre-existing builtins.path tree is re-copied, not adopted" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-path-verify" - srcDir = tmpBase "nova-nix-test-path-verify-src" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - forceRemoveIfExists tmpStore - forceRemoveIfExists srcDir - Dir.createDirectoryIfMissing True srcDir - BS.writeFile (srcDir "f.txt") (TE.encodeUtf8 "real content\n") - entry <- NAR.serialiseFromPath srcDir - case makeFixedOutputPath "sd" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of - Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) - Right sp -> do - let dest = storePathToFilePath (StoreDir tmpStore) sp - Dir.createDirectoryIfMissing True dest - BS.writeFile (dest "f.txt") (TE.encodeUtf8 "partial garbage") - let expr = - "derivation { name = \"path-verify\"; system = builtins.currentSystem; " - <> "builder = \"" - <> nixEscape shell - <> "\"; " - <> "args = [\"-c\" \"echo ok > $out\"]; " - <> "src = builtins.path { path = " - <> canonPathValue (T.pack srcDir) - <> "; name = \"sd\"; }; }" - result <- evalAndBuild (StoreDir tmpStore) expr - outcome <- case result of - Left err -> pure (Fail err) - Right (BuildFailure msg _, store) -> closeStore store >> pure (Fail msg) - Right (BuildSuccess _, store) -> do - -- Strict bytes: a lazy read here holds the file open past - -- the cleanup below, and Windows refuses to delete it. - adopted <- BS.readFile (dest "f.txt") - registered <- isValid store sp - closeStore store - pure $ - if adopted == TE.encodeUtf8 "real content\n" && registered - then Pass - else Fail ("adopted the corrupted tree: " <> T.pack (show adopted)) - forceRemoveIfExists tmpStore - forceRemoveIfExists srcDir - pure outcome, - -- The build path joins the per-path lock protocol (#119, #121) that - -- delete, materialize and register already used. Lock files persist - -- by design, so the one guarding the output is the observable - -- evidence the build took it; without it two concurrent builds share - -- a build directory and interleave into one tree. - runTestM "e2e a build takes its output's path lock" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-e2e-lock" - nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) - lockSource = - T.concat - [ "derivation { name = \"lock-test\"; system = builtins.currentSystem; ", - "builder = \"" <> nixEscape shell <> "\"; ", - "args = [\"-c\" \"echo locked > $out\"]; }" - ] - forceRemoveIfExists tmpStore - result <- evalAndBuild (StoreDir tmpStore) lockSource - ret <- case result of - Left err -> pure (Fail err) - Right (BuildFailure msg code, store) -> do - closeStore store - pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) - Right (BuildSuccess sp, store) -> do - closeStore store - let outPath = storePathToFilePath (StoreDir tmpStore) sp - locked <- Dir.doesFileExist (outPath <> ".lock") - pure $ - if locked - then Pass - else Fail "no lock file beside the built output" - forceRemoveIfExists tmpStore - forceRemoveIfExists (tmpBase "nova-nix-e2e-tmp") - pure ret, - -- Parse error produces Left - runTestM "e2e parse error" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-e2e2" - forceRemoveIfExists tmpStore - result <- evalAndBuild (StoreDir tmpStore) "{{ invalid nix" - forceRemoveIfExists tmpStore - pure $ case result of - Left msg -> - if "parse error" `T.isInfixOf` msg - then Pass - else Fail ("expected parse error, got: " <> msg) - Right _ -> Fail "expected error but got success", - -- Eval error produces Left - runTestM "e2e eval error" $ do - tmpBase <- getTemporaryDirectory - let tmpStore = tmpBase "nova-nix-test-e2e3" - forceRemoveIfExists tmpStore - result <- evalAndBuild (StoreDir tmpStore) "derivation { }" - forceRemoveIfExists tmpStore - pure $ case result of - Left msg -> - if "error" `T.isInfixOf` T.toLower msg - then Pass - else Fail ("expected eval error, got: " <> msg) - Right _ -> Fail "expected error but got success", - -- E2E with subprocess: nova-nix eval on a .nix file - runTestM "e2e nova-nix eval subprocess" $ do - tmpBase <- getTemporaryDirectory - let tmpDir = tmpBase "nova-nix-test-e2e-sub" - nixFile = tmpDir "test.nix" - forceRemoveIfExists tmpDir - createDirectoryIfMissing True tmpDir - writeFile nixFile "1 + 2" - -- Run nova-nix eval via Process - (exitCode, stdoutStr, stderrStr) <- - Proc.readCreateProcessWithExitCode - (Proc.proc "cabal" ["run", "nova-nix", "--", "eval", nixFile]) - "" - forceRemoveIfExists tmpDir - pure $ case exitCode of - ExitSuccess -> - let nonEmpty = filter (not . T.null) (T.lines (T.pack stdoutStr)) - lastLine = case reverse nonEmpty of - (l : _) -> Just l - [] -> Nothing - in if lastLine == Just "3" - then Pass - else Fail ("expected 3 as last line, got: " <> T.pack stdoutStr) - ExitFailure code -> - Fail ("nova-nix eval failed (" <> T.pack (show code) <> "): stderr=" <> T.pack stderrStr) - ] - --- | Exercise the real CLI: testing 'execWrapperConfig' alone cannot catch --- a sub-parser that never passes the option to it. The foreign builder is --- deliberately "-c", so only launching it through the shell can succeed. -testExecWrapperCLI :: IO [Bool] -testExecWrapperCLI = do - putStrLn "cli/exec-wrapper" - shell <- findTestShell - tmpBase <- getTemporaryDirectory - ambient <- getEnvironment - let root = tmpBase "nova-nix-test-cli-wrapper" - system = platformToText (if currentPlatform == X86_64_Windows then X86_64_Linux else X86_64_Windows) - wrapper = ["--exec-wrapper", T.unpack (system <> "=" <> shell)] - otherWrapper = ["--exec-wrapper", T.unpack (platformToText currentPlatform <> "=" <> shell)] - source = - "derivation { name = \"cli-wrapper\"; system = \"" - <> T.unpack system - <> "\"; builder = \"-c\"; args = [\"printf wrapped > \\\"$out\\\"\"]; }" - target = ["--expr", source] - isolatedEnv = - ("NIX_CONFIG", "substituters =\ntrusted-public-keys =\n") - : ("XDG_CONFIG_HOME", root "config") - : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME"]) ambient - runCLI args = - Proc.readCreateProcessWithExitCode - ((Proc.proc "cabal" (["run", "-v0", "nova-nix", "--"] ++ args)) {Proc.env = Just isolatedEnv}) - "" - buildCases = - [ ("before build", wrapper ++ ["build"] ++ target), - ("before target", ["build"] ++ wrapper ++ target), - ("after target", ["build"] ++ target ++ wrapper), - ("repeated across build", otherWrapper ++ ["build"] ++ target ++ wrapper) - ] - errorCases = - [ ("missing value", ["build"] ++ target ++ ["--exec-wrapper"], "--exec-wrapper requires a value"), - ("malformed spec", ["build"] ++ target ++ ["--exec-wrapper", "invalid"], "--exec-wrapper expects SYSTEM=PATH, got: invalid"), - ("duplicate system", wrapper ++ ["build"] ++ target ++ wrapper, "--exec-wrapper names " <> system <> " twice"), - ("missing launcher", ["build"] ++ target ++ ["--exec-wrapper", T.unpack system ++ "=" ++ (root "missing-launcher")], "does not exist") - ] - bracket_ - (forceRemoveIfExists root >> createDirectoryIfMissing True root) - (forceRemoveIfExists root) - ( do - builds <- - mapM - ( \(label, args) -> runTestM ("CLI wrapper " <> label) $ do - (code, out, err) <- runCLI (args ++ ["--store", root T.unpack label]) - case (code, reverse (filter (not . null) (lines out))) of - (ExitSuccess, path : _) -> assertEqual "wrapped output" "wrapped" <$> BS.readFile path - _ -> pure (Fail ("CLI failed: " <> T.pack (show code) <> "; stdout=" <> T.pack out <> "; stderr=" <> T.pack err)) - ) - buildCases - errors <- - mapM - ( \(label, args, expected) -> runTestM ("CLI wrapper " <> label) $ do - (code, _, err) <- runCLI args - pure $ - if code /= ExitSuccess && expected `T.isInfixOf` T.pack err - then Pass - else Fail ("expected failure containing " <> expected <> ", got " <> T.pack (show (code, err))) - ) - errorCases - pure (builds ++ errors) - ) - --- --------------------------------------------------------------------------- --- Tests: Phase 4 - search paths, dynamic keys, directory import --- --------------------------------------------------------------------------- - -testPhase4 :: IO [Bool] -testPhase4 = do - putStrLn "phase4/search-paths" - sequence - [ -- parseNixPath tests - runTest "parseNixPath empty" $ - assertEqual "empty" [] (parseNixPath ""), - runTest "parseNixPath single" $ - let result = parseNixPath "nixpkgs=/home/user/nixpkgs" - in case result of - [thunk] | Just (VAttrs m) <- readThunkValue thunk -> - case (attrSetLookup "prefix" m >>= readThunkValue, attrSetLookup "path" m >>= readThunkValue) of - (Just (VStr "nixpkgs" _), Just (VStr "/home/user/nixpkgs" _)) -> Pass - _ -> Fail "wrong prefix/path" - _ -> Fail ("expected one entry, got " <> T.pack (show (length result))), - runTest "parseNixPath multiple" $ - assertEqual "count" 2 (length (parseNixPath "nixpkgs=/nix:custom=/opt")), - runTest "parseNixPath channel entry" $ - let result = parseNixPath "nixpkgs=channel:nixos-24.11" - in case result of - [thunk] | Just (VAttrs m) <- readThunkValue thunk -> - case (attrSetLookup "prefix" m >>= readThunkValue, attrSetLookup "path" m >>= readThunkValue) of - (Just (VStr "nixpkgs" _), Just (VStr "channel:nixos-24.11" _)) -> Pass - _ -> Fail "wrong prefix/path for channel" - _ -> Fail ("expected one entry, got " <> T.pack (show (length result))), - runTest "splitNixPath drive letters and separators" $ - assertEqual - "split" - ["nixpkgs=C:\\nixpkgs", "custom=/opt/custom", "C:/x"] - (splitNixPath "nixpkgs=C:\\nixpkgs:custom=/opt/custom:C:/x"), - runTest "splitNixPath splits a Unix-style absolute path list" $ - assertEqual "split-unix" ["/foo", "/bar"] (splitNixPath "/foo:/bar"), - runTest "splitNixPath splits a Unix entry after a drive entry" $ - assertEqual "split-mixed" ["C:\\a", "/foo"] (splitNixPath "C:\\a:/foo"), - runTest "splitNixPath keeps a URL entry whole" $ - assertEqual - "split-url" - ["nixpkgs=https://example.com/nixpkgs.tar.gz", "custom=/opt"] - (splitNixPath "nixpkgs=https://example.com/nixpkgs.tar.gz:custom=/opt"), - runTest "splitNixPath keeps a channel entry whole" $ - assertEqual - "split-channel" - ["channel:nixos-24.11", "/foo"] - (splitNixPath "channel:nixos-24.11:/foo"), - runTest "splitNixPath keeps a prefixed channel entry whole" $ - assertEqual - "split-channel-prefixed" - ["nixpkgs=channel:nixos-24.11", "/foo"] - (splitNixPath "nixpkgs=channel:nixos-24.11:/foo"), - runTest "splitNixPath keeps a flake entry whole" $ - assertEqual "split-flake" ["flake:nixpkgs", "/foo"] (splitNixPath "flake:nixpkgs:/foo"), - runTest "splitNixPath keeps every listed scheme whole" $ - assertEqual - "split-schemes" - ["http://h/a", "https://h/b", "file:///c", "channel://d", "git://h/e", "s3://b/f", "ssh://h/g"] - (splitNixPath "http://h/a:https://h/b:file:///c:channel://d:git://h/e:s3://b/f:ssh://h/g"), - runTest "splitNixPath splits an unlisted scheme at its colon" $ - assertEqual "split-unlisted" ["foo", "//x", "/bar"] (splitNixPath "foo://x:/bar"), - runTest "splitNixPath drops empty entries" $ - assertEqual "split-empties" ["a", "b"] (splitNixPath "a::b:"), - runTest "splitNixPath drops leading empty entries" $ - assertEqual "split-leading-empties" ["x"] (splitNixPath "::x"), - runTest "splitNixPath matches a scheme case-sensitively" $ - assertEqual "split-scheme-case" ["HTTP", "//x", "/y"] (splitNixPath "HTTP://x:/y"), - runTest "splitNixPath judges the scheme after the last = of the entry" $ - assertEqual "split-last-equals" ["a=b=https://x", "/y"] (splitNixPath "a=b=https://x:/y"), - runTest "splitNixPath splits a URL port after the host" $ - assertEqual "split-port" ["https://example.com", "8080/x"] (splitNixPath "https://example.com:8080/x"), - runTest "splitNixPath absorbs one run after a channel entry" $ - assertEqual "split-one-run" ["channel:channel", "x"] (splitNixPath "channel:channel:x"), - runTest "splitNixPath keeps a bare channel colon" $ - assertEqual "split-channel-bare" ["channel:", "foo"] (splitNixPath "channel::foo"), - runTest "isNixPathPseudoUrl: channel, flake and the listed schemes are fetched" $ - assertEqual - "pseudo" - [True, True, True, True, True] - (map isNixPathPseudoUrl ["channel:nixos-24.11", "channel:", "flake:nixpkgs", "https://example.com/x.tar.gz", "file:///c"]), - runTest "isNixPathPseudoUrl: a path, an unlisted scheme, a drive and a bare word are not" $ - assertEqual "not-pseudo" [False, False, False, False] (map isNixPathPseudoUrl ["/foo", "foo://x", "C:/x", "channel"]), - runTest "splitNixPath drops a trailing empty entry" $ - assertEqual "split-trail" ["a"] (splitNixPath "a:"), - runTestM "splitNixPath long entry splits in linear time" $ do - let entry = TE.encodeUtf8 (T.replicate 2000000 "p") - split = splitNixPath ("first:" <> entry) == ["first", entry] - outcome <- timeout walkWatchdogMicros (evaluate split) - pure $ case outcome of - Just True -> Pass - Just False -> Fail "wrong split for a long entry" - Nothing -> Fail "split did not return promptly", - runTest "parseNixPath plain path" $ - let result = parseNixPath "/some/path" - in case result of - [thunk] | Just (VAttrs m) <- readThunkValue thunk -> - case (attrSetLookup "prefix" m >>= readThunkValue, attrSetLookup "path" m >>= readThunkValue) of - (Just (VStr "" _), Just (VStr "/some/path" _)) -> Pass - _ -> Fail "wrong prefix/path for plain" - _ -> Fail "expected one entry", - -- ESearchPath desugars to __findFile __nixPath "name" during resolution - runTest "parse " $ - assertParse "search path" "" (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "nixpkgs"])), - runTest "parse " $ - assertParse "search path with subpath" "" (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "nixpkgs/lib"])), - -- ESearchPath eval (should fail in pure mode since no search paths) - runTest "eval fails without path" $ - assertEvalFail "search path not found" "", - -- Dynamic attribute keys - runTest "dynamic key basic" $ - assertEval "dynamic key" "{ ${\"hello\"} = 42; }.hello" (VInt 42), - runTest "dynamic key from let" $ - assertEval "dynamic key let" "let name = \"x\"; in { ${name} = 1; }.x" (VInt 1), - runTest "dynamic key in select" $ - assertEval "dynamic key select" "let s = { x = 10; }; in s.${\"x\"}" (VInt 10), - runTest "dynamic key in hasAttr" $ - assertEval "dynamic key hasAttr" "let s = { x = 10; }; in s ? ${\"x\"}" (VBool True), - runTest "dynamic key hasAttr missing" $ - assertEval "dynamic key hasAttr missing" "let s = { x = 10; }; in s ? ${\"y\"}" (VBool False), - -- has-attr checks presence of the terminal attribute without - -- forcing its value, matching upstream laziness. - runTest "hasAttr does not force the final attribute" $ - assertEval "hasattr-lazy" "{ a = builtins.throw \"boom\"; } ? a" (VBool True), - runTest "hasAttr path does not force the terminal attribute" $ - assertEval "hasattr-path-lazy" "{ a = { b = builtins.throw \"boom\"; }; } ? a.b" (VBool True), - -- A null dynamic key in select or has-attr is a type error, as - -- upstream; it is not treated as an absent attribute. - runTest "null dynamic select key is a type error" $ - assertEvalFail "sel-null-key" "({ x = 1; }).${null}", - runTest "null dynamic hasAttr key is a type error" $ - assertEvalFail "has-null-key" "{ x = 1; } ? ${null}", - -- inherit inside a rec set with a dynamic key resolves against the - -- enclosing scope, never the rec set's own binding. - runTest "inherit in a dynamic-keyed rec set resolves outward" $ - assertEval "dyn-rec-inherit" "let v = 42; in (rec { ${\"d\"} = 1; inherit v; }).v" (VInt 42), - -- Dynamic attr inside string interpolation (the ${name} must not - -- prematurely close the outer interpolation) - runTest "dynamic key in string interp" $ - assertEval "dynamic key interp" "let s = { x = 10; }; in \"${toString s.${\"x\"}}\"" (VStr "10" mempty) - ] - -testPhase4IO :: IO [Bool] -testPhase4IO = do - putStrLn "phase4/directory-import" - tmpDir <- getTemporaryDirectory - let testDir = tmpDir "nova-nix-phase4-test" - subDir = testDir "mypkg" - defaultNix = subDir "default.nix" - -- Create temp directory structure - createDirectoryIfMissing True subDir - TIO.writeFile defaultNix "42" - results <- - sequence - [ -- Directory import: import ./dir resolves to ./dir/default.nix - runTestM "import directory" $ do - result <- evalNixIO testDir ("import " <> T.pack "./mypkg") - pure $ case result of - Right (VInt 42) -> Pass - Right other -> Fail ("expected VInt 42, got " <> T.pack (show other)) - Left err -> Fail ("eval error: " <> err), - -- Search path with --nix-path equivalent (populated nixPath) - runTestM "search path with populated nixPath" $ do - st <- newEvalState platformStoreDir testDir - let nixPaths = parseNixPath (TE.encodeUtf8 ("mypkg=" <> T.pack subDir)) - env = builtinEnv unrestrictedPolicy (esTimestamp st) nixPaths - result <- runEvalIO st (eval env (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "mypkg"]))) - pure $ case result of - Right (VPath _) -> Pass - Right other -> Fail ("expected VPath, got " <> T.pack (show other)) - Left err -> Fail ("eval error: " <> err) - ] - -- Cleanup - removeDirectoryRecursive testDir - pure results - --- | @builtins.toJSON@ of a path uses copy-to-store coercion (upstream --- value-to-json.cc serializes paths with @copyToStore = true@): the JSON --- text is the quoted source store path and the result carries its --- context. EvalIO-only: PureEval has no store-path computation. -testToJSONPathIO :: IO [Bool] -testToJSONPathIO = do - putStrLn "eval/tojson-path-io" - tmpDir <- getTemporaryDirectory - let testDir = tmpDir "nova-nix-tojson-path-test" - createDirectoryIfMissing True testDir - TIO.writeFile (testDir "data.txt") "payload\n" - results <- - sequence - [ runTestM "toJSON of a path is its quoted store path with context" $ do - result <- evalNixIO testDir "builtins.toJSON ./data.txt" - pure $ case result of - Right (VStr json ctx) -> - if "\"/nix/store/" `BS.isPrefixOf` json - && "-data.txt\"" `BS.isSuffixOf` json - && ctx /= emptyContext - then Pass - else Fail ("expected a quoted store path with context, got " <> bytesText json) - Right other -> Fail ("expected VStr, got " <> T.pack (show other)) - Left err -> Fail ("eval error: " <> err) - ] - removeDirectoryRecursive testDir - pure results - --- --------------------------------------------------------------------------- --- Arena lifecycle guard (C FFI) --- --------------------------------------------------------------------------- - --- | The argument that turns this executable into the child of --- 'testArenaGuard'. The child reaches the C layer with no 'arenaInit', --- which the suite cannot do in its own process: 'main' brackets every --- group, and a destroy-then-reinit cycle would invalidate the arena --- pointers that process-lifetime CAFs already hold (#19). -arenaGuardChildFlag :: String -arenaGuardChildFlag = "--arena-guard-child" - --- | One way a library user reaches the C layer, with what the child must --- report for it. -data ArenaGuardPath = ArenaGuardPath - { -- | The child's argument. - guardName :: !String, - -- | The suite's name for the case. - guardClaim :: !Text, - -- | What the child must report. - guardOutcome :: !GuardOutcome, - -- | The child's body, run with no 'arenaInit' of its own. - guardAction :: !(IO ()) - } - --- | What a guard child must report for its path. -data GuardOutcome - = -- | 'ArenaNotInitialized', naming this C entry point. - RefusedAt !Text - | -- | No exception: the path needs no arena. - Served - --- | The line a guard child prints when its path raised nothing. -servedLine :: String -servedLine = "served without an exception" - --- | The paths a library user reaches the C layer by. The first C call --- of each of the first four lands in a different sub-arena, and the --- fifth runs a full init .. destroy cycle first, so both ends of the --- window are covered. The last two read the shared @null@, @true@ and --- @false@ thunks, which must be valid in every window: were they arena --- cells behind a process-lifetime CAF, forcing one outside the window --- would poison it with 'ArenaNotInitialized' for every later arena, and --- forcing one inside an arena would leave it pointing into memory the --- next 'arenaDestroy' frees, a use-after-free the ASan job reports. -arenaGuardPaths :: [ArenaGuardPath] -arenaGuardPaths = - [ noArena "compile" "nn_bc_emit" evalIssueProgram, - noArena "thunk" "nn_thunk_new_computed_int" (void (evaluate (unThunk (evaluated (VInt 1))))), - noArena "symbol" "nn_symbol_intern" (void (evaluate (unThunk (evaluated (mkStr "a"))))), - noArena "env" "nn_env_alloc_slots" (void (evaluate (fst (buildCSlots [evaluated (VInt 1)])))), - noArena "after-destroy" "nn_bc_emit" (bracket_ arenaInit arenaDestroy (pure ()) >> evalIssueProgram), - ArenaGuardPath - { guardName = "constants-outside-window", - guardClaim = "the null, true and false thunks read correctly before arenaInit and in a later arena", - guardOutcome = Served, - guardAction = readConstants >> bracket_ arenaInit arenaDestroy readConstants - }, - ArenaGuardPath - { guardName = "constants-across-cycles", - guardClaim = "the null, true and false thunks read correctly across two init .. destroy cycles", - guardOutcome = Served, - guardAction = bracket_ arenaInit arenaDestroy readConstants >> bracket_ arenaInit arenaDestroy readConstants - } - ] - where - noArena name site = ArenaGuardPath name ("no arena: " <> T.pack name <> " raises ArenaNotInitialized at " <> site) (RefusedAt site) - -- The program from #206, forced to its result. - evalIssueProgram = case parseNix "/tmp" "" "let x = 5; in x * 2 + 1" of - Left err -> throwIO (ErrorCall (show err)) - Right expr -> void (evaluate (runPureEval (eval (builtinEnv unrestrictedPolicy 0 []) expr))) - -- Read through the IO accessors: a pure read of a constant is itself - -- a constant GHC may share between the cycles, and the second would - -- then read nothing. A wrong cell is a broken outcome rather than the - -- guard under test, so it leaves the child by another exception. - readConstants = do - found <- mapM (readCell . unThunk . evaluated) [VNull, VBool True, VBool False] - unless (found == [(ThunkComputed, ValueNull, 0), (ThunkComputed, ValueBool, 1), (ThunkComputed, ValueBool, 0)]) $ - throwIO (ErrorCall ("the constants read back as " ++ show found)) - readCell ptr = (,,) <$> cthunkState ptr <*> cthunkValueTag ptr <*> cthunkGetBool ptr - --- | Child body: run one path with no arena and print what it raised, or --- 'servedLine'. Exit 0 either way; a segfault, a sanitizer report or --- any other exception type surfaces as the process's own exit code. -arenaGuardChild :: String -> IO () -arenaGuardChild name = case [guardAction path | path <- arenaGuardPaths, guardName path == name] of - [action] -> do - outcome <- try action - putStrLn $ case outcome of - Left (err :: CStatusError) -> displayException err - Right () -> servedLine - _ -> hPutStrLn stderr ("unknown arena guard path: " ++ name) >> exitWith (ExitFailure 2) - --- | @builtins.storePath@ resolves a path's symlinks unless the path is --- itself a store path (primops.cc at 2.24.9), so a link outside the store --- into it names its target. The links dangle on a runner with no store, --- which upstream resolves the same way; Windows needs symlink privilege. -testStorePathLinksIO :: IO [Bool] -testStorePathLinksIO = do - putStrLn "eval/storepath-links-io" - canLink <- symlinksAvailable - if not canLink || SI.os == "mingw32" - then [] <$ putStrLn " SKIP needs POSIX symlinks" - else do - tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory - let dir = tmpBase "nova-nix-test-storepath-links" - target = "/nix/store/00000000000000000000000000000000-x" - through name = "builtins.storePath (/. + " <> nixQuotedPath (dir name) <> ")" - Dir.removePathForcibly dir - createDirectoryIfMissing True dir - Dir.createFileLink target (dir "path") - Dir.createFileLink (target <> "/bin") (dir "sub") - results <- - sequence - [ runTestIO "a link into the store names the store path" dir (through "path") (VStr (TE.encodeUtf8 (T.pack target)) (Context.plainContext (StorePath "00000000000000000000000000000000" "x"))), - runTestIO "a link to a subpath names the subpath" dir (through "sub") (VStr (TE.encodeUtf8 (T.pack (target <> "/bin"))) (Context.plainContext (StorePath "00000000000000000000000000000000" "x"))) - ] - Dir.removePathForcibly dir - pure results - --- | A derivation attribute carrying another's drvPath brings that .drv's --- whole closure into inputSrcs and inputDrvs, as upstream's --- derivationStrict does (primops.cc at 2.24.9). Each drvPath is --- nix-instantiate 2.24.9's. -testDeepContextClosureIO :: IO [Bool] -testDeepContextClosureIO = do - putStrLn "eval/deep-context-closure-io" - tmpBase <- getTemporaryDirectory - let plain name rest = "derivation { name = \"" <> name <> "\"; system = \"x\"; builder = \"/bin/sh\"; " <> rest <> "}" - drvPathOf bindings body = "builtins.unsafeDiscardStringContext (let " <> bindings <> " in " <> body <> ").drvPath" - a = "a = " <> plain "a" "" <> ";" - m = "m = " <> plain "m" "dep = a; " <> ";" - t = "t = " <> plain "t" "dep = m; " <> ";" - sequence - [ runTestIO "a drvPath brings its own .drv into inputSrcs" tmpBase (drvPathOf a (plain "b" "x = \"${a.drvPath}\"; ")) (mkStr "/nix/store/r3pz4ykyxg5s9f08fafcksw6bxfds40r-b.drv"), - runTestIO "a drvPath brings the .drv files it depends on" tmpBase (drvPathOf (a <> " " <> m) (plain "b" "x = \"${m.drvPath}\"; ")) (mkStr "/nix/store/00pfjcd57v5dd5j4w4zmsp3s8lcpv6wg-b.drv"), - runTestIO "the closure is followed to its end" tmpBase (drvPathOf (a <> " " <> m <> " " <> t) (plain "b" "x = \"${t.drvPath}\"; ")) (mkStr "/nix/store/f480ldqci72g5miaywmhljjlw1fg1y4i-b.drv") - ] - --- | Run as a child, evaluate one expression under the IO evaluator, which --- writes traces and warnings to stderr as it goes, then write its failure --- to the same stream, so the parent reads them in the order they came. -evalChildFlag :: String -evalChildFlag = "--eval-child" - -evalChild :: String -> IO () -evalChild source = do - result <- evalNixIO "." (T.pack source) - either (\err -> hPutStrLn stderr ("error: " <> T.unpack err)) (const (pure ())) result - --- | @deepSeq@, @trace@ and @warn@ finish with their first argument before --- they force their second (primops.cc at 2.24.9), however the second --- arrives. Each expected stream is nix-instantiate 2.24.9's: its trace --- and warning lines, then the final error line. -testFirstArgumentOrderIO :: IO [Bool] -testFirstArgumentOrderIO = do - putStrLn "eval/first-argument-order-io" - self <- getExecutablePath - let emits label source expected = runTestM label $ do - (_, _, err) <- Proc.readCreateProcessWithExitCode (Proc.proc self [evalChildFlag, T.unpack source]) "" - pure (assertEqual label expected (T.lines (T.pack err))) - sequence - [ emits "trace prints before its second argument fails" "builtins.trace \"hi\" (throw \"b\")" ["trace: hi", "error: b"], - emits "warn warns before its second argument fails" "builtins.warn \"w\" (throw \"b\")" ["evaluation warning: w", "error: b"], - emits "deepSeq forces its first argument deeply before its second" "builtins.deepSeq { a = throw \"a\"; } (throw \"b\")" ["error: a"], - emits "deepSeq applied to one argument first forces it on the second" "let f = builtins.deepSeq { a = throw \"a\"; }; in f (throw \"b\")" ["error: a"], - emits "deepSeq mapped over a list forces its first argument first" "builtins.elemAt (map (builtins.deepSeq { a = throw \"a\"; }) [ (throw \"b\") ]) 0" ["error: a"], - emits "trace inside deepSeq sees the forced value" "let x = { a = 1 + 1; }; in builtins.deepSeq x (builtins.trace x 1)" ["trace: { a = 2; }"] - ] - --- | The smallest slot count whose byte size exceeds @UINT32_MAX@. --- @nn_env_alloc_slots@ refuses it before touching a page, so inside a --- live arena it fails without exhausting anything. -slotCountPastUInt32 :: Int -slotCountPastUInt32 = fromIntegral (maxBound :: Word32) `div` sizeOf (nullPtr :: Ptr ()) + 1 - --- | One byte past the longest string the symbol table can hold. -symbolLengthPastUInt32 :: Int -symbolLengthPastUInt32 = fromIntegral (maxBound :: Word32) + 1 - --- | Intern a ByteString whose length claims 'symbolLengthPastUInt32' --- bytes over one real byte, so no 4 GiB buffer is needed. Sound only --- because the interner refuses on the length before reading: an --- interner that read would run out of bounds here. -internOversizedSymbol :: IO Symbol -internOversizedSymbol = - alloca $ \byte -> do - poke byte (0 :: CChar) - oversized <- BSU.unsafePackCStringLen (byte, symbolLengthPastUInt32) - symbolInternBytes oversized - --- | Reaching the C layer outside the 'arenaInit' .. 'arenaDestroy' --- window raises 'ArenaNotInitialized' naming the entry point, where --- #206 reported a SIGSEGV. Each such path runs in a child process. --- The live side of the same check runs in this process, under the --- suite's bracket: a refusal with the arena up is 'CAllocationFailed'. -testArenaGuard :: IO [Bool] -testArenaGuard = do - putStrLn "arena/guard" - self <- getExecutablePath - children <- - mapM - ( \path -> runTestM (guardClaim path) $ do - (code, out, err) <- Proc.readCreateProcessWithExitCode (Proc.proc self [arenaGuardChildFlag, guardName path]) "" - let message = T.pack out - pure $ case (code, guardOutcome path) of - (ExitSuccess, RefusedAt site) - | "arenaInit" `T.isInfixOf` message && site `T.isInfixOf` message -> Pass - | otherwise -> Fail ("message does not name arenaInit and " <> site <> ": " <> message) - (ExitSuccess, Served) - | T.strip message == T.pack servedLine -> Pass - | otherwise -> Fail ("expected no exception, got: " <> message) - (ExitFailure n, _) -> Fail ("child exited " <> T.pack (show n) <> " (negative is a signal): " <> T.pack err) - ) - arenaGuardPaths - live <- - sequence - [ liveRefusal "a slot array past UINT32_MAX bytes" "nn_env_alloc_slots" (void (evaluate (allocCSlots slotCountPastUInt32))), - -- The list's items come from the same slot allocator, so the same - -- count is refused there and must surface as a list failure, where - -- the NULL it used to return read as the empty list. - liveRefusal "a list past UINT32_MAX slot bytes" "nn_list_new" (void (clistNew (fromIntegral slotCountPastUInt32))), - -- A length the entry's uint32_t cannot hold, refused rather than - -- truncated to alias a shorter string. - liveRefusal "a symbol longer than UINT32_MAX bytes" "nn_symbol_intern" (void internOversizedSymbol) - ] - tableIntact <- - runTestM "a refused symbol leaves the table unchanged" $ do - before <- symbolCount - _ <- try internOversizedSymbol :: IO (Either CStatusError Symbol) - after <- symbolCount - sym <- symbolIntern "after-a-refusal" - pure $ - if before == after && symbolText sym == "after-a-refusal" - then Pass - else Fail ("count " <> T.pack (show before) <> " -> " <> T.pack (show after) <> ", text " <> symbolText sym) - pure (children ++ live ++ [tableIntact]) - where - liveRefusal what site action = - runTestM ("live arena: " <> what <> " raises CAllocationFailed at " <> site) $ do - alive <- arenaLive - outcome <- try action - pure $ case (alive, outcome) of - (True, Left (CAllocationFailed refused _)) | refused == T.unpack site -> Pass - (True, Left err) -> Fail ("expected CAllocationFailed at " <> site <> ", got " <> T.pack (show err)) - (True, Right ()) -> Fail "no exception raised" - (False, _) -> Fail "arenaLive is False inside the suite's bracket" - --- --------------------------------------------------------------------------- --- Symbol interning (C FFI) --- --------------------------------------------------------------------------- - -testSymbol :: IO [Bool] -testSymbol = do - putStrLn "symbol" - -- Symbol table is initialized by arenaInit in main bracket. - sequence - [ runTestM "intern returns non-zero" $ do - sym <- symbolIntern "hello" - pure (if unSymbol sym /= 0 then Pass else Fail "got symbol 0"), - runTestM "intern same string returns same symbol" $ do - sym1 <- symbolIntern "name" - sym2 <- symbolIntern "name" - pure (assertEqual "same symbol" sym1 sym2), - runTestM "intern different strings returns different symbols" $ do - sym1 <- symbolIntern "foo" - sym2 <- symbolIntern "bar" - pure (if sym1 /= sym2 then Pass else Fail "symbols should differ"), - runTestM "symbolText round-trips" $ do - sym <- symbolIntern "version" - let txt = symbolText sym - pure (assertEqual "text" "version" txt), - runTestM "symbolLen correct" $ do - sym <- symbolIntern "outputs" - pure (assertEqual "len" 7 (symbolLen sym)), - runTestM "empty string interns" $ do - sym <- symbolIntern "" - let txt = symbolText sym - pure (assertEqual "empty" "" txt), - runTestM "symbolCount tracks unique entries" $ do - _ <- symbolIntern "alpha" - _ <- symbolIntern "beta" - _ <- symbolIntern "alpha" - count <- symbolCount - -- count includes all symbols interned in this bracket, - -- so at least the ones from prior tests plus alpha + beta - pure (if count >= 2 then Pass else Fail ("count too low: " <> T.pack (show count))), - runTestM "many symbols (stress)" $ do - let names = map (\i -> "pkg_" <> T.pack (show (i :: Int))) [1 .. 1000] - syms <- mapM symbolIntern names - -- All unique - let unique = length (Set.fromList (map unSymbol syms)) - pure (assertEqual "1000 unique" 1000 unique) - ] - --- --------------------------------------------------------------------------- --- C attribute set (FFI) --- --------------------------------------------------------------------------- - --- | Cast a StablePtr to CThunkPtr for CAttrSet tests. --- CAttrSet stores void* - we use StablePtrs as opaque values in tests. -spToCPtr :: StablePtr a -> CThunkPtr -spToCPtr = castPtr . castStablePtrToPtr - --- | Cast a CThunkPtr back to StablePtr for CAttrSet test verification. -cptrToSp :: CThunkPtr -> StablePtr a -cptrToSp = castPtrToStablePtr . castPtr - -testCAttrSet :: IO [Bool] -testCAttrSet = do - putStrLn "cattrset" - -- Symbol table is initialized by arenaInit in main bracket. - sequence - [ runTestM "new/free" $ do - _set <- cattrsetNew 16 - -- set freed by arenaDestroy via nn_attrset_free_all - pure Pass, - runTestM "insert + freeze + lookup" $ do - set <- cattrsetNew 4 - kName <- symbolIntern "name" - kVer <- symbolIntern "version" - valName <- newStablePtr ("hello" :: Text) - valVer <- newStablePtr ("1.0" :: Text) - cattrsetInsert set kName (spToCPtr valName) - cattrsetInsert set kVer (spToCPtr valVer) - cattrsetFreeze set - result <- cattrsetLookup set kName - case result of - Nothing -> do - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr valName - freeStablePtr valVer - pure (Fail "lookup returned Nothing") - Just cptr -> do - val <- deRefStablePtr (cptrToSp cptr) :: IO Text - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr valName - freeStablePtr valVer - pure (assertEqual "lookup name" "hello" val), - runTestM "lookup missing key returns Nothing" $ do - set <- cattrsetNew 4 - kFoo <- symbolIntern "foo" - kBar <- symbolIntern "bar" - sp <- newStablePtr ("x" :: Text) - cattrsetInsert set kFoo (spToCPtr sp) - cattrsetFreeze set - result <- cattrsetLookup set kBar - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr sp - pure (case result of Nothing -> Pass; Just _ -> Fail "expected Nothing"), - runTestM "size after freeze" $ do - set <- cattrsetNew 4 - k1 <- symbolIntern "a" - k2 <- symbolIntern "b" - k3 <- symbolIntern "c" - sp <- newStablePtr (42 :: Int) - cattrsetInsert set k1 (spToCPtr sp) - cattrsetInsert set k2 (spToCPtr sp) - cattrsetInsert set k3 (spToCPtr sp) - cattrsetFreeze set - n <- cattrsetSize set - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr sp - pure (assertEqual "size" 3 n), - runTestM "duplicate keys: last writer wins" $ do - set <- cattrsetNew 4 - kName <- symbolIntern "name" - sp1 <- newStablePtr ("first" :: Text) - sp2 <- newStablePtr ("second" :: Text) - cattrsetInsert set kName (spToCPtr sp1) - cattrsetInsert set kName (spToCPtr sp2) - cattrsetFreeze set - n <- cattrsetSize set - result <- cattrsetLookup set kName - val <- case result of - Nothing -> pure "MISSING" - Just cptr -> deRefStablePtr (cptrToSp cptr) - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr sp1 - freeStablePtr sp2 - pure - ( if n == 1 && val == ("second" :: Text) - then Pass - else Fail ("size=" <> T.pack (show n) <> " val=" <> val) - ), - runTestM "keys returned sorted" $ do - set <- cattrsetNew 8 - -- Insert in reverse order; after freeze keys should be sorted by symbol ID - k1 <- symbolIntern "zzz" - k2 <- symbolIntern "aaa" - k3 <- symbolIntern "mmm" - sp <- newStablePtr (0 :: Int) - cattrsetInsert set k1 (spToCPtr sp) - cattrsetInsert set k2 (spToCPtr sp) - cattrsetInsert set k3 (spToCPtr sp) - cattrsetFreeze set - keys <- cattrsetKeys set - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr sp - -- Keys should be sorted by symbol ID (ascending) - let ids = map unSymbol keys - sorted = ids == foldl (\acc x -> acc ++ [x]) [] (Set.toAscList (Set.fromList ids)) - pure (if sorted then Pass else Fail ("unsorted: " <> T.pack (show ids))), - runTestM "union right-biased" $ do - setA <- cattrsetNew 4 - setB <- cattrsetNew 4 - kX <- symbolIntern "x" - kY <- symbolIntern "y" - kZ <- symbolIntern "z" - spA <- newStablePtr ("fromA" :: Text) - spB <- newStablePtr ("fromB" :: Text) - spZ <- newStablePtr ("onlyA" :: Text) - cattrsetInsert setA kX (spToCPtr spA) - cattrsetInsert setA kZ (spToCPtr spZ) - cattrsetInsert setB kX (spToCPtr spB) - cattrsetInsert setB kY (spToCPtr spB) - cattrsetFreeze setA - cattrsetFreeze setB - merged <- cattrsetUnion setA setB - n <- cattrsetSize merged - resultX <- cattrsetLookup merged kX - valX <- case resultX of - Nothing -> pure "MISSING" - Just cptr -> deRefStablePtr (cptrToSp cptr) - -- sets freed by arenaDestroy via nn_attrset_free_all - freeStablePtr spA - freeStablePtr spB - freeStablePtr spZ - pure - ( if n == 3 && valX == ("fromB" :: Text) - then Pass - else Fail ("size=" <> T.pack (show n) <> " x=" <> valX) - ), - runTestM "stress: 10k entries" $ do - set <- cattrsetNew 1024 - sp <- newStablePtr (0 :: Int) - syms <- mapM (\i -> symbolIntern ("key_" <> T.pack (show (i :: Int)))) [1 .. 10000] - mapM_ (\sym -> cattrsetInsert set sym (spToCPtr sp)) syms - cattrsetFreeze set - n <- cattrsetSize set - -- Spot-check a lookup from the middle of the key range - hit <- case drop 5000 syms of - middleSym : _ -> cattrsetLookup set middleSym - [] -> pure Nothing - -- set freed by arenaDestroy via nn_attrset_free_all - freeStablePtr sp - pure - ( if n == 10000 && isJust hit - then Pass - else Fail ("size=" <> T.pack (show n)) - ), - -- Grown from the default capacity, so every doubling runs; the - -- index of an absent key is the C side's NN_ATTRSET_NOT_FOUND. - runTestM "index finds each key at its sorted position and none for an absent key" $ do - set <- cattrsetNew 0 - sp <- newStablePtr (0 :: Int) - syms <- mapM (\i -> symbolIntern ("index_" <> T.pack (show (i :: Int)))) [1 .. 100] - mapM_ (\sym -> cattrsetInsert set sym (spToCPtr sp)) syms - cattrsetFreeze set - absent <- symbolIntern "index_absent" - found <- mapM (cattrsetIndex set) (sort syms) - missing <- cattrsetIndex set absent - freeStablePtr sp - pure - ( if found == map Just [0 .. 99] && isNothing missing - then Pass - else Fail ("found=" <> T.pack (show found) <> " missing=" <> T.pack (show missing)) - ) - ] - --- --------------------------------------------------------------------------- --- C thunk arena (FFI) --- --------------------------------------------------------------------------- - -testCThunk :: IO [Bool] -testCThunk = do - putStrLn "cthunk" - -- Arena is already initialized by main's bracket. - -- Each test uses the shared arena (thunks accumulate - that's fine). - sequence - [ runTestM "new pending + state" $ do - sp <- newStablePtr ("pending" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) - state <- cthunkState ptr - pure (assertEqual "state" 0 state), - runTestM "new computed + state" $ do - sp <- newStablePtr ("computed" :: Text) - ptr <- cthunkNewComputed (castStablePtrToPtr sp) - state <- cthunkState ptr - pure (assertEqual "state" 1 state), - runTestM "payload round-trips (pending)" $ do - sp <- newStablePtr ("hello" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) - payload <- cthunkPayload ptr - val <- deRefStablePtr (castPtrToStablePtr payload) :: IO Text - pure (assertEqual "payload" "hello" val), - runTestM "payload round-trips (computed)" $ do - sp <- newStablePtr (42 :: Int) - ptr <- cthunkNewComputed (castStablePtrToPtr sp) - payload <- cthunkPayload ptr - val <- deRefStablePtr (castPtrToStablePtr payload) :: IO Int - pure (assertEqual "payload" 42 val), - runTestM "mark_blackhole succeeds on pending" $ do - sp <- newStablePtr ("x" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) - ok <- cthunkMarkBlackhole ptr - state <- cthunkState ptr - pure - ( if ok && state == 2 - then Pass - else Fail ("ok=" <> T.pack (show ok) <> " state=" <> T.pack (show state)) - ), - runTestM "mark_blackhole fails on computed" $ do - sp <- newStablePtr ("x" :: Text) - ptr <- cthunkNewComputed (castStablePtrToPtr sp) - ok <- cthunkMarkBlackhole ptr - pure (if not ok then Pass else Fail "should have failed"), - runTestM "mark_blackhole fails on blackhole" $ do - sp <- newStablePtr ("x" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) - _ <- cthunkMarkBlackhole ptr - ok <- cthunkMarkBlackhole ptr - pure (if not ok then Pass else Fail "should have failed"), - runTestM "set_computed stores into a blackhole" $ do - pendingSp <- newStablePtr ("old" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr pendingSp) - _ <- cthunkMarkBlackhole ptr - computedSp <- newStablePtr ("new" :: Text) - stored <- cthunkSetComputed ptr (castStablePtrToPtr computedSp) - state <- cthunkState ptr - newPayload <- cthunkPayload ptr - newVal <- deRefStablePtr (castPtrToStablePtr newPayload) :: IO Text - freeStablePtr pendingSp - pure - ( if stored && newVal == "new" && state == 1 - then Pass - else Fail ("stored=" <> T.pack (show stored) <> " new=" <> newVal <> " state=" <> T.pack (show state)) - ), - -- set_computed accepts PENDING (direct memoization, no blackhole step) - runTestM "set_computed stores into a pending thunk" $ do - sp <- newStablePtr ("x" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) - valSp <- newStablePtr ("v" :: Text) - stored <- cthunkSetComputed ptr (castStablePtrToPtr valSp) - freeStablePtr sp - pure (if stored then Pass else Fail "refused a PENDING thunk"), - runTestM "set_computed refuses a computed thunk and keeps its value" $ do - firstSp <- newStablePtr ("first" :: Text) - ptr <- cthunkNewComputed (castStablePtrToPtr firstSp) - secondSp <- newStablePtr ("second" :: Text) - stored <- cthunkSetComputed ptr (castStablePtrToPtr secondSp) - payload <- cthunkPayload ptr - kept <- deRefStablePtr (castPtrToStablePtr payload) :: IO Text - freeStablePtr secondSp - pure - ( if not stored && kept == "first" - then Pass - else Fail ("stored=" <> T.pack (show stored) <> " kept=" <> kept) - ), - -- The shared cells are one static each for the whole process, so a - -- transition that ran on one would change every null or boolean. - runTestM "the shared null and boolean cells refuse every transition" $ do - let cells = [cthunkNull, cthunkBool True, cthunkBool False] - marked <- mapM cthunkMarkBlackhole cells - stored <- mapM (`cthunkSetComputed` nullPtr) cells - repointed <- mapM (`cthunkSetPayload` nullPtr) cells - let values = map (readThunkValue . Thunk) cells - expected = map Just [VNull, VBool True, VBool False] - pure - ( if not (or (marked ++ stored ++ repointed)) && values == expected - then Pass - else Fail ("accepted=" <> T.pack (show (marked, stored, repointed)) <> " values=" <> T.pack (show values)) - ), - runTestM "count tracks allocations" $ do - countBefore <- cthunkCount - sp <- newStablePtr (0 :: Int) - _ <- cthunkNewBc 0 (castStablePtrToPtr sp) - _ <- cthunkNewBc 0 (castStablePtrToPtr sp) - _ <- cthunkNewComputed (castStablePtrToPtr sp) - countAfter <- cthunkCount - let delta = countAfter - countBefore - pure (assertEqual "delta" 3 delta), - runTestM "get retrieves by index" $ do - countBefore <- cthunkCount - sp <- newStablePtr ("indexed" :: Text) - ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) - retrieved <- cthunkGet countBefore - stateOrig <- cthunkState ptr - stateRetrieved <- cthunkState retrieved - pure - ( if ptr == retrieved && stateOrig == stateRetrieved - then Pass - else Fail "get returned wrong pointer" - ), - runTestM "stress: 100k thunks" $ do - countBefore <- cthunkCount - sp <- newStablePtr (0 :: Int) - mapM_ (\_ -> cthunkNewBc 0 (castStablePtrToPtr sp)) [(1 :: Int) .. 100000] - countAfter <- cthunkCount - let delta = countAfter - countBefore - -- Spot-check: retrieve one from the middle - midPtr <- cthunkGet (countBefore + 50000) - midState <- cthunkState midPtr - pure - ( if delta == 100000 && midState == 0 - then Pass - else - Fail - ( "delta=" - <> T.pack (show delta) - <> " midState=" - <> T.pack (show midState) - ) - ) - ] - --- --------------------------------------------------------------------------- --- Bytecode compilation tests --- --------------------------------------------------------------------------- - --- --------------------------------------------------------------------------- --- Tests: upstream conformance follow-ups (#50) --- --------------------------------------------------------------------------- - --- | Error kind for 'StubStoreEval', mirroring PureEval's split: only a --- throw/assert is tryEval-catchable. -data StubErr = StubThrow !Text | StubOther !Text - --- | Pure evaluator over a stubbed store: 'readStoreDerivation' serves --- derivations from a fixed map (keyed by canonical @.drv@ path text); --- everything else behaves like 'PureEval'. Exercises the --- input-derivation-modulo STORE-READ arm hermetically - the real arm --- reads the platform store, which dev machines and CI runners must not --- depend on (the build matrix has no writable @/nix/store@). -newtype StubStoreEval a = StubStoreEval (StubEnv -> Either StubErr a) - --- | What the stubbed store answers from. -data StubEnv = StubEnv - { -- | Derivations 'readStoreDerivation' serves, by canonical @.drv@ path. - seDrvs :: !(Map.Map Text Derivation), - -- | Recorded fetches 'lookupFetchCache' serves, by key. - seFetchCache :: !(Map.Map Text Text), - -- | Store paths 'adoptStorePath' accepts. Deliberately NOT the same - -- answer as 'doesPathExist', which is 'False' throughout: on disk and - -- registered are different facts, and a test where the two coincide - -- cannot tell which one the code under test asked about. - seAdoptable :: !(Set.Set Text) - } - --- | A stub store holding nothing but the given derivations. -stubEnv :: Map.Map Text Derivation -> StubEnv -stubEnv drvs = StubEnv {seDrvs = drvs, seFetchCache = Map.empty, seAdoptable = Set.empty} - -runStubStoreEvalWith :: StubEnv -> StubStoreEval a -> Either Text a -runStubStoreEvalWith env (StubStoreEval action) = case action env of - Left (StubThrow msg) -> Left msg - Left (StubOther msg) -> Left msg - Right val -> Right val - -instance Functor StubStoreEval where - fmap f (StubStoreEval g) = StubStoreEval (fmap f . g) - -instance Applicative StubStoreEval where - pure val = StubStoreEval (const (Right val)) - StubStoreEval mf <*> StubStoreEval ma = StubStoreEval $ \env -> mf env <*> ma env - -instance Monad StubStoreEval where - StubStoreEval ma >>= f = StubStoreEval $ \env -> case ma env of - Left err -> Left err - Right val -> let StubStoreEval mb = f val in mb env - -instance MonadEval StubStoreEval where - throwEvalError msg = StubStoreEval (const (Left (StubOther msg))) - throwCatchableError msg = StubStoreEval (const (Left (StubThrow msg))) - abortEvaluation msg = StubStoreEval (const (Left (StubOther ("evaluation aborted: " <> msg)))) - catchEvalError (StubStoreEval action) = StubStoreEval $ \env -> case action env of - Left (StubThrow msg) -> Right (Left msg) - Left other -> Left other - Right val -> Right (Right val) - onEvalError (StubStoreEval action) _ = StubStoreEval action - addErrorTrace _ action = action - - -- The stub keeps no call depth: it exists to answer store questions, - -- and the ceiling is tested on the evaluators that enforce it. - withCallFrame (StubStoreEval action) = StubStoreEval action - doesPathExist _ _ = pure False - listDirectory _ = throwEvalError "readDir: not available in the stub evaluator" - importFile _ = throwEvalError "import: not available in the stub evaluator" - getEnvVar _ = pure "" - getCurrentTime = pure 0 - writeToStore _ _ _ = throwEvalError "toFile: not available in the stub evaluator" - scopedImportFile _ _ = throwEvalError "scopedImport: not available in the stub evaluator" - readFileBytes _ = throwEvalError "readFile: not available in the stub evaluator" - getFileType _ = throwEvalError "readFileType: not available in the stub evaluator" - runProcess _ _ _ = throwEvalError "runProcess: not available in the stub evaluator" - createScratchDir _ = throwEvalError "createScratchDir: not available in the stub evaluator" - removeScratchDir _ = pure () - copyPathToStore _ _ _ = throwEvalError "builtins.path: not available in the stub evaluator" - narHashOfPath _ = throwEvalError "builtins.fetchGit: not available in the stub evaluator" - setExecutableFile _ = throwEvalError "builtins.fetchGit: not available in the stub evaluator" - lookupFetchCache key = StubStoreEval $ \env -> Right (Map.lookup key (seFetchCache env)) - adoptStorePath path = StubStoreEval $ \env -> Right (Set.member path (seAdoptable env)) - writeFetchCache _ _ = pure () - isExecutableFile _ = throwEvalError "builtins.path: not available in the stub evaluator" - readSymlinkTarget _ = throwEvalError "builtins.path: not available in the stub evaluator" - resolveSymlinks = pure - addSourceNar _ _ = throwEvalError "builtins.path: not available in the stub evaluator" - addFixedOutputFile _ _ = throwEvalError "builtins.fetchurl: not available in the stub evaluator" - traceMessage _ = pure () - lookupDrvHash _ = pure Nothing - cacheDrvHash _ _ = pure () - recordDrvAterm _ _ = pure () - readStoreDerivation sp = - StubStoreEval $ \env -> Right (Map.lookup (storePathToText defaultStoreDir sp) (seDrvs env)) - lookupSessionDrv _ = pure Nothing - lookupSessionReferences _ = pure Nothing - storeSourcePath = pure - evalPolicy = pure unrestrictedPolicy - checkUri _ = pure () - resolvePathLiteral = pure . canonPath - forceThunk evalFn thunk@(Thunk ptr) = case readThunkValue thunk of - Just val -> pure val - Nothing -> case unsafePerformIO (cthunkState ptr) of - 2 {- BLACKHOLE -} -> abortEvaluation "infinite recursion encountered" - _ {- PENDING -} -> - let bcIdx = unsafePerformIO (cthunkGetBcIdx ptr) - envSp = unsafePerformIO (cthunkPayload ptr) - env = unsafePerformIO (deRefStablePtr (castPtrToStablePtr envSp)) - in evalFn env bcIdx - --- | Parse and evaluate under the stubbed-store evaluator. -evalNixStub :: Map.Map Text Derivation -> Text -> Either Text NixValue -evalNixStub = evalNixStubWith . stubEnv - --- | 'evalNixStub' with the whole stub store spelled out. -evalNixStubWith :: StubEnv -> Text -> Either Text NixValue -evalNixStubWith env source = case parseNix testBaseDir "" source of - Left err -> Left (T.pack (show err)) - Right expr -> runStubStoreEvalWith env (eval (builtinEnv unrestrictedPolicy 0 []) expr) - --- | Upstream conformance follow-ups (#50): behaviors that landed --- with #37 but had no direct test. Pure cases here; filesystem-touching --- cases in 'testClassIFollowupsIO'. -testClassIFollowups :: IO [Bool] -testClassIFollowups = do - putStrLn "eval/class-i-followups" - let storeA = "/nix/store/" <> T.replicate 32 "a" - enclosingCtx = StringContext (Set.singleton (SCPlain (StorePath (T.replicate 32 "a") "x"))) - sequence - [ -- path + path concatenates the spellings and canonicalizes - runTest "path + path canonicalizes the joined spelling" $ - assertEval "pp-canon" "builtins.toString (/a/b + /c/../d)" (mkStr "/a/b/d"), - -- concatStringsSep coerces a path element; an in-store path takes - -- the short-circuit (itself + enclosing context, no store copy) - runTest "concatStringsSep coerces an in-store path element" $ - assertEval - "csep-path" - ("builtins.concatStringsSep \":\" [ " <> storeA <> "-x \"y\" ]") - (VStr (TE.encodeUtf8 (storeA <> "-x:y")) enclosingCtx), - runTest "substring and unsafeDiscardOutputDependency keep a coerced path's context" $ - assertEval "substring-store-path" ("builtins.substring 0 10 " <> storeA <> "-x") (VStr "/nix/store" enclosingCtx) - `andThen` assertEval - "discard-output-store-path" - ("builtins.unsafeDiscardOutputDependency " <> storeA <> "-x") - (VStr (TE.encodeUtf8 (storeA <> "-x")) enclosingCtx), - runTest "addDrvOutputDependencies judges a coerced path by its context" $ - assertEvalError - "add-output-store-path" - ("builtins.addDrvOutputDependencies " <> storeA <> "-x") - ("builtins.addDrvOutputDependencies: path " <> storeA <> "-x is not a derivation"), - -- the same in-store short-circuit for general interpolation, on a - -- SUBPATH: the text is the subpath, the context the enclosing path - runTest "interpolating an in-store subpath keeps text, contexts the enclosing path" $ - assertEval - "interp-substore" - ("\"${" <> storeA <> "-x/sub}\"") - (VStr (TE.encodeUtf8 (storeA <> "-x/sub")) enclosingCtx), - -- storePath on a subpath: value text is the subpath itself - runTest "storePath on a subpath keeps text, contexts the enclosing path" $ - assertEval - "storepath-sub" - ("builtins.storePath " <> storeA <> "-x/sub/file") - (VStr (TE.encodeUtf8 (storeA <> "-x/sub/file")) enclosingCtx), - runTest "fromJSON falls to float past uint64" $ - assertEval "fromjson-float" "builtins.fromJSON \"18446744073709551616\"" (VFloat 18446744073709551616.0), - -- the input-derivation-modulo STORE-READ arm: a dependent whose - -- input .drv was NOT evaluated in-session resolves by reading the - -- (stubbed) store, and lands on the same drvPath as the in-session - -- cache-hit arm computes for the identical derivation - runTestM "input modulo recurses through the store read (stub store)" $ do - let depSrc = "derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }" - tmpBase <- getTemporaryDirectory - depDrv <- evalDerivationIO tmpBase depSrc >>= either (fail . ("dep: " <>) . T.unpack) pure - depPath <- case evalNix ("(" <> depSrc <> ").drvPath") of - Right (VStr p _) -> pure (bytesText p) - other -> fail ("dep.drvPath: " <> show other) - let stubResult = - evalNixStub (Map.singleton depPath depDrv) $ - T.concat - [ "(derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ", - "input = builtins.appendContext \"x\" { \"", - depPath, - "\" = { outputs = [\"out\"]; }; }; }).drvPath" - ] - ioResult <- - evalNixIO tmpBase $ - T.concat - [ "let dep = ", - depSrc, - "; in (derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ", - "input = builtins.appendContext \"x\" { \"${dep.drvPath}\" = { outputs = [\"out\"]; }; }; }).drvPath" - ] - pure $ case (stubResult, ioResult) of - (Right (VStr a _), Right (VStr b _)) - | a == b -> Pass - | otherwise -> - Fail ("store-read and in-session arms disagree: " <> bytesText a <> " vs " <> bytesText b) - other -> Fail ("expected two drvPaths, got: " <> T.pack (show other)) - ] - --- | Filesystem-touching conformance follow-ups (#50). -testClassIFollowupsIO :: IO [Bool] -testClassIFollowupsIO = do - putStrLn "eval/class-i-followups-io" - tmpDir <- getTemporaryDirectory - let testDir = tmpDir "nova-nix-classi-test" - testDirFwd = T.replace "\\" "/" (T.pack testDir) - bracket_ - ( do - createDirectoryIfMissing True (testDir "sub") - TIO.writeFile (testDir "target.txt") "hit\n" - TIO.writeFile (testDir "thefile") "payload\n" - -- Imported files for the two path-resolution tests below. Each is - -- a directory deeper than the expression that names it, so a - -- literal resolved against the wrong one is visibly wrong. - TIO.writeFile (testDir "sub" "useq.nix") "q\n" - TIO.writeFile (testDir "sub" "tilde.nix") "~/nova-tilde-probe\n" - ) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ -- ~/ expands against the home directory at path resolution - runTestM "tilde path literal expands against the home directory" $ do - home <- Dir.getHomeDirectory - result <- evalNixIO testDir "builtins.toString ~/nova-tilde-probe" - let expected = canonPathValue (T.pack (home "nova-tilde-probe")) - pure $ assertRight "tilde" result $ \val -> - assertEqual "tilde-expanded" (mkStr expected) val, - -- The same literal inside an imported file. Path resolution runs - -- over every parsed file now, and joining ~/x to the importing - -- directory would bury the tilde where nothing expands it. - runTestM "tilde path literal expands the same inside an imported file" $ do - home <- Dir.getHomeDirectory - result <- evalNixIO testDir "builtins.toString (import ./sub/tilde.nix)" - let expected = canonPathValue (T.pack (home "nova-tilde-probe")) - pure $ assertRight "tilde-import" result $ \val -> - assertEqual "tilde-expanded-in-import" (mkStr expected) val, - -- A path literal names a location relative to the file it is - -- written in. This one is written here and forced during the - -- evaluation of sub/useq.nix, where the base directory is sub/: - -- resolving on force rather than on parse gave sub/target.txt. - runTestM "a path literal resolves where it is written, not where it is forced" $ do - let expr = "builtins.toString (builtins.scopedImport { q = ./target.txt; } ./sub/useq.nix)" - result <- evalNixIO testDir expr - let expected = canonPathValue (T.pack (testDir "target.txt")) - pure $ assertRight "scoped-import-path" result $ \val -> - assertEqual "resolved-against-writing-file" (mkStr expected) val, - -- a search-path match is returned CANONICALIZED - runTestM "findFile canonicalizes the matched candidate" $ do - result <- - evalNixIO testDir $ - T.concat - ["builtins.findFile [ { prefix = \"\"; path = \"", testDirFwd, "/sub/..\"; } ] \"target.txt\""] - pure $ assertRight "findfile-canon" result $ \val -> - assertEqual "canonical" (VPath (testDirFwd <> "/target.txt")) val, - -- the store copy is named by canonBaseName (the path's last segment) - runTestM "source copy is named by canonBaseName" $ do - result <- evalNixIO testDir "\"${./thefile}\"" - pure $ assertRight "canonbase" result $ \case - VStr s ctx -> - if "/nix/store/" `BS.isPrefixOf` s && "-thefile" `BS.isSuffixOf` s && ctx /= emptyContext - then Pass - else Fail ("expected a store path named -thefile with context, got " <> bytesText s) - other -> Fail ("expected VStr, got " <> T.pack (show other)), - -- canonBaseName's empty-name arm: the filesystem root has no - -- base name to copy under, refused before any read. POSIX only: - -- a root path literal on Windows names a drive. - if SI.os == "mingw32" - then True <$ putStrLn " SKIP coercing the filesystem root errors (no base name): the root is a drive" - else runTestM "coercing the filesystem root errors (no base name)" $ do - result <- evalNixIO testDir "\"${/.}\"" - pure $ case result of - Left err | "no base name" `T.isInfixOf` err -> Pass - Left err -> Fail ("expected a base-name error, got: " <> err) - Right val -> Fail ("expected failure, got " <> T.pack (show val)) - ] - --- | Bytecode short_arg spill: op-level payload counts at or above the --- 0xFFFF sentinel move to the first data word, so literals are no longer --- capped at 65535 elements. The two exact-boundary list cases pin the --- inline maximum (65534) and the first spilled count (65535); the rest --- drive each counted-op kind (list, attrs, let, string parts, attr path) --- well past the old ceiling. --- --------------------------------------------------------------------------- --- Bytecode shared across elements --- --------------------------------------------------------------------------- - --- | A bytecode instruction as far as the reserved instructions use them: a --- resolved variable (level, slot), a deferred application, or anything --- else (opcode, flags). -data CodeShape - = SlotRef !Word32 !Word32 - | DeferredApp !CodeShape !CodeShape - | OtherCode !Word8 !Word8 - deriving (Eq, Show) - --- | Read the code at a bytecode index back as a 'CodeShape'. -codeShape :: Word32 -> IO CodeShape -codeShape idx = do - op <- cbcOpcode idx - flags <- cbcFlags idx - arg1 <- cbcArg1 idx - arg2 <- cbcArg2 idx - case op of - OpResolvedVar -> pure (SlotRef arg1 arg2) - OpApp | flags == appDeferred -> DeferredApp <$> codeShape arg1 <*> codeShape arg2 - _ -> pure (OtherCode op flags) - --- | The instructions and data words evaluating a source adds to the --- bytecode store, which only 'arenaDestroy' frees. The source must --- evaluate to an integer computed from everything it builds, so each --- element has been forced when the counts are read. -bytecodeGrowth :: Text -> IO (Either Text (Word32, Word32)) -bytecodeGrowth source = do - opsBefore <- cbcOpCount - dataBefore <- cbcDataCount - forced <- case evalNix source of - Right (VInt n) -> Right <$> evaluate n - Right other -> pure (Left ("expected an integer, got " <> T.pack (show other))) - Left err -> pure (Left err) - opsAfter <- cbcOpCount - dataAfter <- cbcDataCount - pure ((opsAfter - opsBefore, dataAfter - dataBefore) <$ forced) - --- | A source builds one element or two hundred, and the bytecode it adds --- is the same: the code each element runs is shared, never compiled per --- element. A first run at one element is discarded, so anything compiled --- once per process is not counted against either size. -assertNoPerElementBytecode :: (Text -> Text) -> IO TestResult -assertNoPerElementBytecode sourceFor = do - _ <- bytecodeGrowth (sourceFor "1") - one <- bytecodeGrowth (sourceFor "1") - many <- bytecodeGrowth (sourceFor "200") - pure $ case (one, many) of - (Right atOne, Right atMany) -> - assertEqual "instructions and data words added at 1 element and at 200" atOne atMany - (Left err, _) -> Fail err - (_, Left err) -> Fail err - -testBytecodePerElement :: IO [Bool] -testBytecodePerElement = do - putStrLn "bytecode/per-element" - let summed body n = "builtins.foldl' (a: b: a + b) 0 (" <> body n <> ")" - indices n = "builtins.genList (i: i) " <> n - sequence - [ runTestM "reserved instructions are the deferred applications of the slots" $ do - apply1 <- codeShape reservedApply1 - apply2 <- codeShape reservedApply2 - apply2Function <- cbcArg1 reservedApply2 - pure $ - assertEqual "reservedApply1" (DeferredApp (SlotRef 0 0) (SlotRef 0 1)) apply1 - `andThen` assertEqual "reservedApply2" (DeferredApp (DeferredApp (SlotRef 0 0) (SlotRef 0 1)) (SlotRef 0 2)) apply2 - `andThen` assertEqual "reservedApply2's function" reservedApply1 apply2Function, - runTestM "map adds no bytecode per element" $ - assertNoPerElementBytecode (summed (\n -> "builtins.map (x: x + 1) (" <> indices n <> ")")), - runTestM "genList adds no bytecode per element" $ - assertNoPerElementBytecode (summed ("builtins.genList (i: i * 2) " <>)), - runTestM "concatMap adds no bytecode per element" $ - assertNoPerElementBytecode (summed (\n -> "builtins.concatMap (x: [ x x ]) (" <> indices n <> ")")), - runTestM "mapAttrs adds no bytecode per attribute" $ - assertNoPerElementBytecode - ( summed - (\n -> "builtins.attrValues (builtins.mapAttrs (name: v: v + 1) (builtins.listToAttrs (builtins.genList (i: { name = toString i; value = i; }) " <> n <> ")))") - ), - runTestM "zipAttrsWith adds no bytecode per attribute" $ - assertNoPerElementBytecode - ( summed - (\n -> "builtins.attrValues (builtins.zipAttrsWith (name: vs: builtins.length vs) (builtins.genList (i: { ${toString i} = i; }) " <> n <> "))") - ), - runTestM "inherit (from) in an attr set adds no bytecode per evaluation" $ - assertNoPerElementBytecode (summed ("builtins.genList (i: { inherit ({ v = i; }) v; }.v) " <>)), - runTestM "inherit (from) in a recursive attr set adds no bytecode per evaluation" $ - assertNoPerElementBytecode (summed ("builtins.genList (i: rec { inherit ({ v = i; }) v; }.v) " <>)), - runTestM "inherit (from) in a let adds no bytecode per evaluation" $ - assertNoPerElementBytecode (summed ("builtins.genList (i: let inherit ({ v = i; }) v; in v) " <>)) - ] - -testBytecodeCountSpill :: IO [Bool] -testBytecodeCountSpill = do - putStrLn "bytecode/count-spill" - let listOf n = "builtins.length [ " <> T.unwords (replicate n "1") <> " ]" - bigAttrsBody = T.concat [T.pack ("a" <> show i <> " = " <> show i <> "; ") | i <- [0 :: Int .. 69999]] - sequence - [ runTest "list literal at the inline count maximum (65534)" $ - assertEval "spill-list-inline-max" (listOf 65534) (VInt 65534), - runTest "list literal at the first spilled count (65535)" $ - assertEval "spill-list-first-spill" (listOf 65535) (VInt 65535), - runTest "spilled list preserves element order" $ - assertEval - "spill-list-order" - ("builtins.elemAt [ " <> T.unwords (map (T.pack . show) [0 :: Int .. 69999]) <> " ] 69999") - (VInt 69999), - runTest "spilled attrset literal binds every attribute" $ - assertEval - "spill-attrs-count" - ("builtins.length (builtins.attrNames { " <> bigAttrsBody <> "})") - (VInt 70000), - runTest "spilled attrset lookup reads the right value" $ - assertEval - "spill-attrs-lookup" - ("{ " <> bigAttrsBody <> "}.a69999") - (VInt 69999), - runTest "spilled let binds every name" $ - assertEval - "spill-let" - ("let " <> T.concat [T.pack ("v" <> show i <> " = " <> show i <> "; ") | i <- [0 :: Int .. 69999]] <> "in v69999") - (VInt 69999), - runTest "spilled interpolated string keeps every part" $ - assertEval - "spill-string-parts" - ("builtins.stringLength \"" <> T.concat (replicate 70000 "${\"x\"}") <> "\"") - (VInt 70000), - runTest "spilled attr path walks (set ? long.path)" $ - assertEval - "spill-attrpath" - ("{ } ? " <> T.intercalate "." (map (\i -> T.pack ("p" <> show i)) [0 :: Int .. 69999])) - (VBool False) - ] - --- | C value structs carry element counts as a full uint32; a narrower --- count would wrap at 65536 and size the C array smaller than the fill --- loop that follows it. Both cases marshal counts past that boundary --- and force the value twice - the first force writes the C struct (the --- marshal side), the second reads it back off the computed thunk cell --- (the unmarshal side). -testValueCountWidths :: IO [Bool] -testValueCountWidths = do - putStrLn "value/count-widths" - let formalsBody = T.intercalate ", " [T.pack ("a" <> show i) | i <- [0 :: Int .. 69999]] - sequence - [ runTest "lambda with 70000 formals round-trips through the C closure" $ - assertEval - "width-lambda-formals" - ( "let f = { " - <> formalsBody - <> " }: 1; in builtins.seq (builtins.functionArgs f) (builtins.length (builtins.attrNames (builtins.functionArgs f)))" - ) - (VInt 70000), - runTest "string context with 70000 elements round-trips through the C thunk" $ - assertEval - "width-ctxstr-elems" - ( "let s = builtins.appendContext \"x\" (builtins.listToAttrs (builtins.genList (i: { " - <> "name = \"/nix/store/00000000000000000000000000000000-p\" + builtins.toString i; " - <> "value = { path = true; }; }) 70000)); " - <> "in builtins.seq s (builtins.length (builtins.attrNames (builtins.getContext s)))" - ) - (VInt 70000) - ] - --- --------------------------------------------------------------------------- --- Tests: store-path name validation at write sinks (#39) --- --------------------------------------------------------------------------- - --- | Name validation at write sinks (#39): the store-path name rules hold --- at path CONSTRUCTION, not only at parse. Derivation names, output names, and --- fetchurl basenames reject exactly what the parse boundary rejects, --- before any write path is built from them - and names the old ad hoc --- sink checks over-rejected (an interior @..@) are valid again. -testStoreNameSinks :: IO [Bool] -testStoreNameSinks = do - putStrLn "store/name-sinks" - let drvWith nameLit = - "(derivation { name = " <> nameLit <> "; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).drvPath" - drvOutPath nameLit = - "(derivation { name = " <> nameLit <> "; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath" - drvWithOutputs outsLit = - "(derivation { name = \"p\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = " <> outsLit <> "; }).drvPath" - failsWith label source needle = case evalNix source of - Left err - | parseErrorTag `T.isPrefixOf` err -> Fail (label <> ": did not parse: " <> err) - | needle `T.isInfixOf` err -> Pass - | otherwise -> Fail (label <> ": wrong error: " <> err) - Right val -> Fail (label <> ": expected an eval error, got " <> T.pack (show val)) - succeedsWithSuffix label source suffix = case evalNix source of - Left err -> Fail (label <> ": unexpected error: " <> err) - Right (VStr s _) -> - if TE.encodeUtf8 suffix `BS.isSuffixOf` s - then Pass - else Fail (label <> ": expected suffix " <> suffix <> ", got " <> bytesText s) - Right other -> Fail (label <> ": expected VStr, got " <> T.pack (show other)) - sequence - [ runTest "derivation name with a space is rejected" $ - failsWith "name-space" (drvWith "\"a b\"") "invalid derivation name", - runTest "derivation name with a slash is rejected" $ - failsWith "name-slash" (drvWith "\"a/b\"") "invalid derivation name", - runTest "derivation name with a backslash is rejected" $ - failsWith "name-backslash" (drvWith "\"a\\\\b\"") "invalid derivation name", - runTest "derivation name with a drive colon is rejected" $ - failsWith "name-colon" (drvWith "\"C:x\"") "invalid derivation name", - runTest "empty derivation name is rejected" $ - failsWith "name-empty" (drvWith "\"\"") "name must not be empty", - runTest "212-character derivation name is rejected" $ - failsWith "name-long" (drvWith ("\"" <> T.replicate 212 "a" <> "\"")) "must be no longer than 211 characters", - runTest "derivation name '..' is rejected" $ - failsWith "name-dotdot" (drvWith "\"..\"") "name '..' is not valid", - runTest "derivation name '.-x' is rejected" $ - failsWith "name-dotdash" (drvWith "\".-x\"") "dash-separated component", - runTest "dotfile derivation name stays valid" $ - succeedsWithSuffix "name-dotfile" (drvWith "\".foo-1.0\"") "-.foo-1.0.drv", - runTest "interior '..' in a derivation name stays valid" $ - succeedsWithSuffix "name-interior-dots" (drvOutPath "\"x..y\"") "-x..y", - runTest "derivation output name with a traversal is rejected" $ - failsWith "out-traversal" (drvWithOutputs "[ \"out\" \"../x\" ]") "invalid derivation output name", - runTest "derivation output name with a colon is rejected" $ - failsWith "out-colon" (drvWithOutputs "[ \"a:b\" ]") "invalid derivation output name", - -- Upstream's derivationStrict refuses these in its outputs loop: the - -- result set already has a drvPath attribute, and a repeat would - -- collide there too. - runTest "derivation output named drvPath is rejected" $ - failsWith "out-drvpath" (drvWithOutputs "[ \"drvPath\" ]") "invalid derivation output name 'drvPath'", - runTest "repeated derivation output name is rejected" $ - failsWith "out-duplicate" (drvWithOutputs "[ \"out\" \"out\" ]") "duplicate derivation output 'out'", - -- The wrapper never calls derivationStrict with an empty list (its - -- builtins.head fails on the empty outputsList first), so the primop - -- is called directly. - runTest "empty derivation output list is rejected" $ - failsWith - "out-empty" - "derivationStrict { name = \"p\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ ]; }" - "derivation cannot have an empty set of outputs", - -- Both fields clean on their own, only the COMPOSED drvName-output - -- crosses the length cap: the construction-side check catches what - -- the field-level checks cannot. - runTest "composed name-output past the length cap is rejected" $ - failsWith - "composed-long" - ( "(derivation { name = \"" - <> T.replicate 208 "a" - <> "\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ \"dev\" ]; }).drvPath" - ) - "invalid store path name", - -- fetchurl derives the store name from the URL alone, so a bad - -- basename fails BEFORE the download: under PureEval a reachable - -- download would surface as "runProcess: not available" instead. - runTest "fetchurl rejects a backslash basename before fetching" $ - failsWith "fetchurl-backslash" "builtins.fetchurl \"http://e/a\\\\b\"" "invalid store path name", - runTest "fetchurl rejects a dot-segment basename before fetching" $ - failsWith "fetchurl-dotdot" "builtins.fetchurl \"http://e/..\"" "invalid store path name" - ] - --- | Which entry names and link targets each host's rules admit --- ("Nix.Store.EntryName"). The decision is pure, so every host's answer --- is checked on any host: the grammar's refusals hold everywhere, POSIX --- holds every other name as bytes, macOS needs UTF-8 without a --- noncharacter, and Windows refuses what Win32 reserves or rewrites. -testNarNameSafety :: IO [Bool] -testNarNameSafety = do - putStrLn "store/entry-name-rules" - let admitted rules names = [(name, admits rules name) | name <- names] - admits rules name = either (const False) (const True) (checkEntryName rules name) - allAdmit rules names = assertEqual (T.pack (show rules) <> " verdicts") [(name, True) | name <- names] (admitted rules names) - allRefuse rules names = assertEqual (T.pack (show rules) <> " verdicts") [(name, False) | name <- names] (admitted rules names) - everyHost = [PosixNames, DarwinNames, WindowsNames] - grammarRefused = ["", ".", "..", "a/b", "/", "a\NULb"] - posixOnlyNames = [name | (name, _) <- posixOnlyEntries] - notUtf8 = ["caf\xE9", "\xFF", "\xC0\xAF", "\xED\xA0\x80", "\xF4\x90\x80\x80"] - noncharacters = ["n\xEF\xB7\x90", "n\xEF\xB7\xAF", "n\xEF\xBF\xBE", "n\xEF\xBF\xBF", "n\xF0\x9F\xBF\xBE", "n\xF4\x8F\xBF\xBF"] - sequence - [ runTest "the grammar's refusals hold on every host" $ - foldr (keepFirstFail . (`allRefuse` grammarRefused)) Pass everyHost, - runTest "POSIX holds every other name as its bytes" $ - allAdmit PosixNames (posixOnlyNames <> notUtf8 <> noncharacters <> ["caf\xC3\xA9", "a\x7F"]), - runTest "macOS holds a name upstream restores there" $ - allAdmit DarwinNames (posixOnlyNames <> ["caf\xC3\xA9", "n\xEE\x80\x80", "n\xEF\xBF\xBD", "n\xEF\xBB\xBF"]), - runTest "macOS refuses a name that is not UTF-8 or holds a noncharacter" $ - allRefuse DarwinNames (notUtf8 <> noncharacters), - runTest "Windows refuses device names, trailing dots and spaces, and reserved characters" $ - allRefuse - WindowsNames - ( filter (not . BS.isPrefixOf "link-") posixOnlyNames - <> ["nul.txt", "Nul .txt", "COM0.log", "com3", "lpt9", "COM\xC2\xB2", "COM\xC2\xB3", "C:evil", "a*b", "a?b", "ab", "a|b", "ctl\x1F"] - ), - runTest "Windows refuses a name with no UTF-16 form" $ - allRefuse WindowsNames notUtf8, - runTest "Windows holds ordinary and near-miss names" $ - allAdmit - WindowsNames - ["a", ".hidden", "a.b", "a b", " a", "com10", "COM", "NULx", "xNUL.txt", "caf\xC3\xA9", "LPT\xE2\x81\xB9", "a~b", "a\x7F", "n\xEF\xBF\xBE"], - runTest "a refusal names the entry and the reason" $ - assertEqual - "refusals" - [ Left "NAR directory entry name 'aux.c' is a Windows device name", - Left "NAR directory entry name 'x.' ends in a dot or a space, which Windows strips", - Left "NAR directory entry name 'a:b' holds a character Windows does not allow in a name", - Left "NAR directory entry name \"caf\\233\" is not valid UTF-8, which a macOS filesystem cannot hold", - Left "unsafe NAR directory entry name: \"a/b\"" - ] - [ checkEntryName WindowsNames "aux.c", - checkEntryName WindowsNames "x.", - checkEntryName WindowsNames "a:b", - checkEntryName DarwinNames "caf\xE9", - checkEntryName PosixNames "a/b" - ], - runTest "a link target is bytes on POSIX and macOS and UTF-16 on Windows" $ - assertEqual - "target verdicts" - [Right (), Right (), Left "NAR symlink target \"caf\\233\" is not valid UTF-8, so it has no UTF-16 form for Windows", Right ()] - [ checkLinkTarget PosixNames "caf\xE9", - checkLinkTarget DarwinNames "caf\xE9", - checkLinkTarget WindowsNames "caf\xE9", - checkLinkTarget WindowsNames "../a b/c:d" - ], - -- The Windows rules check a name's bytes, where the check they - -- replace read it as text; on every name both could judge (UTF-8 - -- without a character the old check let through and Windows - -- refuses at the create) they must agree. - runTestM "the Windows rules refuse what the text check they replace refused" $ do - result <- - QC.quickCheckWithResult QC.stdArgs {QC.chatty = False, QC.maxSuccess = 5000} $ - QC.forAll genDeviceLikeName $ \name -> - either (const False) (const True) (checkEntryName WindowsNames (TE.encodeUtf8 name)) - QC.=== legacyTextNameSafety name - pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) - ] - where - keepFirstFail Pass acc = acc - keepFirstFail failure _ = failure - --- | The text-form name check the Windows rules replaced, kept verbatim as --- the oracle their byte-form port is tested against. -legacyTextNameSafety :: Text -> Bool -legacyTextNameSafety name = - not (T.null name) - && name /= ".." - && name /= "." - && not (T.any escapesTree name) - && not (trailingRewritten name) - && not (reservedDeviceStem name) - where - escapesTree c = c == '/' || c == '\\' || c == ':' || c == '\0' - trailingRewritten n = case T.unsnoc n of - Just (_, end) -> end == '.' || end == ' ' - Nothing -> False - reservedDeviceStem n = - let stem = T.toUpper (T.dropWhileEnd (== ' ') (T.takeWhile (/= '.') n)) - in stem == "CON" - || stem == "PRN" - || stem == "AUX" - || stem == "NUL" - || numberedDeviceStem stem - numberedDeviceStem stem = case T.unpack stem of - [a, b, c, digit] -> ([a, b, c] == "COM" || [a, b, c] == "LPT") && deviceDigit digit - _ -> False - deviceDigit c = isDigit c || c == '\185' || c == '\178' || c == '\179' - --- | Names shaped like a Windows device: a stem in mixed case or a near --- miss, then a digit (plain, superscript, or a superscript nine that is --- not a device digit), spaces, and nothing, an extension, or more --- pieces, among them separators, dots and letters whose uppercase is --- longer than themselves. About one name in twenty is refused by the --- device rule alone. -genDeviceLikeName :: QC.Gen Text -genDeviceLikeName = do - stem <- QC.elements ["con", "CON", "Prn", "aux", "AUX", "nul", "NuL", "com", "COM", "lpt", "LpT", "x", "\305", "\329"] - digit <- QC.elements ["", "0", "1", "9", "10", "\185", "\178", "\179", "\8313", "\233"] - spaces <- QC.elements ["", " ", " "] - rest <- QC.frequency [(3, pure ""), (3, ("." <>) <$> pieces), (2, pieces)] - pure (stem <> digit <> spaces <> rest) - where - pieces = - T.concat - <$> QC.resize 4 (QC.listOf (QC.elements [".", "..", " ", "x", "txt", "\233", "\223", "\64256", ":", "\\", "/", "\NUL", "con", "1"])) - --- | Entry names upstream's restore writes on POSIX as it finds them and --- Windows cannot hold, each as compared against @nix-store --restore@ --- 2.33.2: device stems (one with a superscript digit), trailing dots and --- spaces, colons (perl's man pages carry them), a backslash, the --- punctuation Win32 reserves, a control character, and links pointing --- at such names. -posixOnlyEntries :: [(BS.ByteString, NAR.NarEntry)] -posixOnlyEntries = - [ ("COM1", NAR.NarRegular False "com1"), - ("ExtUtils::MakeMaker.3", NAR.NarRegular False "man"), - ("LPT\xC2\xB9.txt", NAR.NarRegular False "lpt"), - ("NUL", NAR.NarRegular False "nul"), - ("a:b", NAR.NarRegular False "colon"), - ("a\\b", NAR.NarRegular False "backslash"), - ("aux.c", NAR.NarRegular False "aux"), - ("con.h", NAR.NarRegular False "con"), - ("ctl\x01", NAR.NarRegular False "control"), - ("dir.", NAR.NarDirectory [("prn", NAR.NarRegular True "prn")]), - ("link-aux", NAR.NarSymlink "aux.c"), - ("link-colon", NAR.NarSymlink "a:b"), - ("link-dot", NAR.NarSymlink "x."), - ("q\"*?<>|", NAR.NarRegular False "reserved"), - ("x.", NAR.NarRegular False "dot"), - ("y ", NAR.NarRegular False "space") - ] - --- | 'posixOnlyEntries' as one directory. -posixOnlyTree :: NAR.NarEntry -posixOnlyTree = NAR.NarDirectory posixOnlyEntries - --- | IO-evaluator write sinks reject an invalid name BEFORE any write: --- every case here errors out against a scratch dir with no store traffic. -testStoreNameSinksIO :: IO [Bool] -testStoreNameSinksIO = do - putStrLn "store/name-sinks-io" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-name-sinks" - needleTest label source needle = do - result <- evalNixIO testDir source - runTest label $ case result of - Left err - | needle `T.isInfixOf` err -> Pass - | otherwise -> Fail (label <> ": wrong error: " <> err) - Right val -> Fail (label <> ": expected an eval error, got " <> T.pack (show val)) - bracket_ - ( do - createDirectoryIfMissing True (testDir "tree") - TIO.writeFile (testDir "tree" "f.txt") "payload\n" - ) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ needleTest "toFile rejects a stream-colon name" "builtins.toFile \"a:b\" \"x\"" "invalid store path name", - needleTest "toFile rejects a dot-segment name" "builtins.toFile \"..\" \"x\"" "invalid store path name", - needleTest - "path rejects a traversal name override" - "builtins.path { path = ./tree; name = \"../../evil\"; }" - "invalid store path name", - needleTest - "path with a filter rejects a drive-prefixed name" - "builtins.path { path = ./tree; name = \"C:evil\"; filter = (_: _: true); }" - "invalid store path name", - needleTest - "source coercion rejects a basename outside the name rules" - "\"${./. + \"/sp ace\"}\"" - "invalid store path name" - ] - --- | An inherited name and whether its select reads that name, as the one --- path segment, from slot 0 of the env it runs in. -inheritedSelect :: BcInheritedName -> IO (Text, Bool) -inheritedSelect (BcInheritedName sym selectIdx) = do - op <- cbcOpcode selectIdx - pathLen <- cbcShortArg selectIdx - target <- cbcArg1 selectIdx - pathOff <- cbcArg2 selectIdx - targetOp <- cbcOpcode target - level <- cbcArg1 target - slot <- cbcArg2 target - keyTag <- cbcData pathOff - keySym <- cbcData (pathOff + 1) - pure - ( symbolText (Symbol sym), - op == OpSelect && pathLen == 1 && targetOp == OpResolvedVar && level == 0 && slot == 0 && keyTag == attrkeyStatic && keySym == sym - ) - -testBytecodeCompile :: IO [Bool] -testBytecodeCompile = do - putStrLn "bytecode" - -- Arena (including bytecode store) already initialized by main's bracket. - sequence - [ runTestM "compile ELit NixInt" $ do - idx <- compileExpr (ELit (NixInt 42)) - op <- cbcOpcode idx - a1 <- cbcArg1 idx - a2 <- cbcArg2 idx - pure - ( if op == OpLitInt && a1 == 42 && a2 == 0 - then Pass - else Fail ("op=" <> T.pack (show op) <> " a1=" <> T.pack (show a1)) - ), - runTestM "compile ELit NixInt negative" $ do - idx <- compileExpr (ELit (NixInt (-1))) - op <- cbcOpcode idx - a1 <- cbcArg1 idx - a2 <- cbcArg2 idx - -- -1 as uint64 = 0xFFFFFFFFFFFFFFFF, lo=0xFFFFFFFF, hi=0xFFFFFFFF - pure - ( if op == OpLitInt && a1 == 0xFFFFFFFF && a2 == 0xFFFFFFFF - then Pass - else - Fail - ( "a1=" - <> T.pack (show a1) - <> " a2=" - <> T.pack (show a2) - ) - ), - runTestM "compile ELit NixBool" $ do - idxT <- compileExpr (ELit (NixBool True)) - idxF <- compileExpr (ELit (NixBool False)) - opT <- cbcOpcode idxT - opF <- cbcOpcode idxF - saT <- cbcShortArg idxT - saF <- cbcShortArg idxF - pure - ( if opT == OpLitBool && saT == 1 && opF == OpLitBool && saF == 0 - then Pass - else Fail "bool encoding mismatch" - ), - runTestM "compile ELit NixNull" $ do - idx <- compileExpr (ELit NixNull) - op <- cbcOpcode idx - pure (assertEqual "opcode" OpLitNull op), - runTestM "compile EResolvedVar" $ do - idx <- compileExpr (EResolvedVar 3 7) - op <- cbcOpcode idx - a1 <- cbcArg1 idx - a2 <- cbcArg2 idx - pure - ( if op == OpResolvedVar && a1 == 3 && a2 == 7 - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " a1=" - <> T.pack (show a1) - <> " a2=" - <> T.pack (show a2) - ) - ), - runTestM "compile EVar" $ do - idx <- compileExpr (EVar "hello") - op <- cbcOpcode idx - sym <- cbcArg1 idx - let symText = symbolText (Symbol sym) - pure - ( if op == OpVar && symText == "hello" - then Pass - else Fail ("op=" <> T.pack (show op) <> " sym=" <> symText) - ), - runTestM "compile EApp" $ do - idx <- compileExpr (EApp (EVar "f") (ELit (NixInt 1))) - op <- cbcOpcode idx - funcIdx <- cbcArg1 idx - argIdx <- cbcArg2 idx - funcOp <- cbcOpcode funcIdx - argOp <- cbcOpcode argIdx - pure - ( if op == OpApp && funcOp == OpVar && argOp == OpLitInt - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " funcOp=" - <> T.pack (show funcOp) - <> " argOp=" - <> T.pack (show argOp) - ) - ), - runTestM "compile EIf" $ do - idx <- - compileExpr - (EIf (ELit (NixBool True)) (ELit (NixInt 1)) (ELit (NixInt 2))) - op <- cbcOpcode idx - condIdx <- cbcArg1 idx - thenIdx <- cbcArg2 idx - elseIdx <- cbcArg3 idx - condOp <- cbcOpcode condIdx - thenA1 <- cbcArg1 thenIdx - elseA1 <- cbcArg1 elseIdx - pure - ( if op == OpIf && condOp == OpLitBool && thenA1 == 1 && elseA1 == 2 - then Pass - else Fail "if structure mismatch" - ), - runTestM "compile EBinary" $ do - idx <- - compileExpr - (EBinary OpAdd (ELit (NixInt 10)) (ELit (NixInt 20))) - op <- cbcOpcode idx - fl <- cbcFlags idx - leftIdx <- cbcArg1 idx - rightIdx <- cbcArg2 idx - leftA1 <- cbcArg1 leftIdx - rightA1 <- cbcArg1 rightIdx - pure - ( if op == OpBinary && fl == binaryAdd && leftA1 == 10 && rightA1 == 20 - then Pass - else Fail "binary structure mismatch" - ), - runTestM "compile EUnary" $ do - idx <- compileExpr (EUnary OpNegate (ELit (NixInt 5))) - op <- cbcOpcode idx - fl <- cbcFlags idx - operandIdx <- cbcArg1 idx - operandA1 <- cbcArg1 operandIdx - pure - ( if op == OpUnary && fl == unaryNegate && operandA1 == 5 - then Pass - else Fail "unary structure mismatch" - ), - runTestM "compile EList" $ do - idx <- - compileExpr - (EList [ELit (NixInt 1), ELit (NixInt 2), ELit (NixInt 3)]) - op <- cbcOpcode idx - count <- cbcShortArg idx - dataOff <- cbcArg1 idx - c0 <- cbcData dataOff - c1 <- cbcData (dataOff + 1) - c2 <- cbcData (dataOff + 2) - c0a1 <- cbcArg1 c0 - c1a1 <- cbcArg1 c1 - c2a1 <- cbcArg1 c2 - pure - ( if op == OpList && count == 3 && c0a1 == 1 && c1a1 == 2 && c2a1 == 3 - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " count=" - <> T.pack (show count) - ) - ), - runTestM "compile EStr with interpolation" $ do - idx <- - compileExpr - (EStr [StrLit "hello ", StrInterp (EVar "name"), StrLit "!"]) - op <- cbcOpcode idx - count <- cbcShortArg idx - dataOff <- cbcArg1 idx - -- 3 parts x 2 words each = 6 data words - tag0 <- cbcData dataOff - _val0 <- cbcData (dataOff + 1) - tag1 <- cbcData (dataOff + 2) - val1 <- cbcData (dataOff + 3) - tag2 <- cbcData (dataOff + 4) - -- tag0=0(lit), tag1=1(interp), tag2=0(lit) - interpOp <- cbcOpcode val1 - pure - ( if op == OpStr - && count == 3 - && tag0 == strpartLit - && tag1 == strpartInterp - && tag2 == strpartLit - && interpOp == OpVar - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " count=" - <> T.pack (show count) - <> " tag0=" - <> T.pack (show tag0) - <> " tag1=" - <> T.pack (show tag1) - ) - ), - runTestM "compile EWith" $ do - idx <- compileExpr (EWith (EVar "lib") (EVar "x")) - op <- cbcOpcode idx - scopeIdx <- cbcArg1 idx - bodyIdx <- cbcArg2 idx - scopeOp <- cbcOpcode scopeIdx - bodyOp <- cbcOpcode bodyIdx - pure - ( if op == OpWith && scopeOp == OpVar && bodyOp == OpVar - then Pass - else Fail "with structure mismatch" - ), - runTestM "compile EAssert" $ do - idx <- compileExpr (EAssert (ELit (NixBool True)) (ELit (NixInt 1))) - op <- cbcOpcode idx - condIdx <- cbcArg1 idx - bodyIdx <- cbcArg2 idx - condOp <- cbcOpcode condIdx - bodyOp <- cbcOpcode bodyIdx - pure - ( if op == OpAssert && condOp == OpLitBool && bodyOp == OpLitInt - then Pass - else Fail "assert structure mismatch" - ), - runTestM "compile ELambda (FormalName)" $ do - idx <- - compileExpr - (ELambda (FormalName "x") (EResolvedVar 0 0) NoCaptureInfo) - op <- cbcOpcode idx - fl <- cbcFlags idx - bodyIdx <- cbcArg2 idx - bodyOp <- cbcOpcode bodyIdx - pure - ( if op == OpLambda && fl == formalName && bodyOp == OpResolvedVar - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " flags=" - <> T.pack (show fl) - ) - ), - runTestM "compile ELet" $ do - idx <- - compileExpr - ( ELet - [NamedBinding (StaticKey "x") (ELit (NixInt 42))] - (EResolvedVar 0 0) - NoCaptureInfo - ) - op <- cbcOpcode idx - count <- cbcShortArg idx - bodyIdx <- cbcArg2 idx - bodyOp <- cbcOpcode bodyIdx - pure - ( if op == OpLet && count == 1 && bodyOp == OpResolvedVar - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " count=" - <> T.pack (show count) - ) - ), - runTestM "compile EAttrs" $ do - idx <- - compileExpr - ( EAttrs - False - [NamedBinding (StaticKey "a") (ELit (NixInt 1))] - NoCaptureInfo - ) - op <- cbcOpcode idx - fl <- cbcFlags idx - count <- cbcShortArg idx - pure - ( if op == OpAttrs && fl == 0 && count == 1 - then Pass - else Fail "attrs structure mismatch" - ), - runTestM "compile EAttrs recursive" $ do - idx <- - compileExpr - ( EAttrs - True - [ NamedBinding (StaticKey "x") (ELit (NixInt 1)), - NamedBinding (StaticKey "y") (EResolvedVar 0 0) - ] - (Captures [(0, 0)]) - ) - op <- cbcOpcode idx - fl <- cbcFlags idx - count <- cbcShortArg idx - pure - ( if op == OpAttrs && fl == 1 && count == 2 - then Pass - else - Fail - ( "flags=" - <> T.pack (show fl) - <> " count=" - <> T.pack (show count) - ) - ), - runTestM "compile ESelect" $ do - idx <- - compileExpr - (ESelect (EVar "x") [StaticKey "a"] Nothing) - op <- cbcOpcode idx - fl <- cbcFlags idx - pure - ( if op == OpSelect && fl == 0 - then Pass - else Fail ("flags=" <> T.pack (show fl)) - ), - runTestM "compile ESelect with default" $ do - idx <- - compileExpr - (ESelect (EVar "x") [StaticKey "a"] (Just (ELit NixNull))) - op <- cbcOpcode idx - fl <- cbcFlags idx - defIdx <- cbcArg3 idx - defOp <- cbcOpcode defIdx - pure - ( if op == OpSelect && fl == 1 && defOp == OpLitNull - then Pass - else Fail ("flags=" <> T.pack (show fl)) - ), - runTestM "compile EHasAttr" $ do - idx <- - compileExpr - (EHasAttr (EVar "x") [StaticKey "a", StaticKey "b"]) - op <- cbcOpcode idx - pathLen <- cbcShortArg idx - pure - ( if op == OpHasAttr && pathLen == 2 - then Pass - else - Fail - ( "op=" - <> T.pack (show op) - <> " pathLen=" - <> T.pack (show pathLen) - ) - ), - -- ESearchPath is desugared by resolver to __findFile __nixPath "name", - -- so the compiler sees an EApp chain, not a raw ESearchPath. - runTestM "compile desugared search path" $ do - idx <- compileExpr (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "nixpkgs"])) - op <- cbcOpcode idx - pure - ( if op == OpApp - then Pass - else Fail ("expected OpApp, got op=" <> T.pack (show op)) - ), - runTestM "op_count grows after compilation" $ do - before <- cbcOpCount - _ <- compileExpr (EApp (EVar "f") (ELit (NixInt 1))) - after <- cbcOpCount - pure - ( if after > before - then Pass - else - Fail - ( "before=" - <> T.pack (show before) - <> " after=" - <> T.pack (show after) - ) - ), - runTestM "compile ELit NixFloat" $ do - idx <- compileExpr (ELit (NixFloat 3.14)) - op <- cbcOpcode idx - pure (assertEqual "opcode" OpLitFloat op), - runTestM "compile ELit NixUri" $ do - idx <- compileExpr (ELit (NixUri "https://example.com")) - op <- cbcOpcode idx - sym <- cbcArg1 idx - pure - ( if op == OpLitUri && symbolText (Symbol sym) == "https://example.com" - then Pass - else Fail "uri mismatch" - ), - runTestM "compile ELit NixPath" $ do - idx <- compileExpr (ELit (NixPath "/nix/store/foo")) - op <- cbcOpcode idx - sym <- cbcArg1 idx - pure - ( if op == OpLitPath && symbolText (Symbol sym) == "/nix/store/foo" - then Pass - else Fail "path mismatch" - ), - runTestM "compile inherit-from binding" $ do - idx <- - compileExpr - ( EAttrs - False - [InheritFrom (EVar "s") ["x", "y"]] - NoCaptureInfo - ) - op <- cbcOpcode idx - count <- cbcShortArg idx - dataOff <- cbcArg1 idx - bindings <- decodeBcBindings 1 dataOff - case bindings of - [BcInheritFrom _ names] - | op == OpAttrs && count == 1 -> do - selects <- mapM inheritedSelect names - pure (assertEqual "inherited names and their selects" [("x", True), ("y", True)] selects) - _ -> pure (Fail "inherit binding mismatch"), - -- A plain inherit has no lookup of its own: it carries the variable, - -- bound like any other, for the evaluator to read in the outer env. - runTestM "compile plain inherit with the variable it copies" $ do - idx <- compileExpr (EAttrs False [Inherit "x" (EResolvedVar 0 0)] NoCaptureInfo) - dataOff <- cbcArg1 idx - bindings <- decodeBcBindings 1 dataOff - case bindings of - [BcInherit sym valIdx] -> do - valOp <- cbcOpcode valIdx - pure $ - if symbolText (Symbol sym) == "x" && valOp == OpResolvedVar - then Pass - else Fail "expected x to carry the resolved variable" - _ -> pure (Fail "expected one inherit binding"), - runTestM "compile ELambda (FormalSet)" $ do - idx <- - compileExpr - ( ELambda - (FormalSet [Formal "a" Nothing, Formal "b" (Just (ELit (NixInt 0)))] False) - (EResolvedVar 0 0) - NoCaptureInfo - ) - op <- cbcOpcode idx - fl <- cbcFlags idx - pure - ( if op == OpLambda && fl == formalSet - then Pass - else Fail ("flags=" <> T.pack (show fl)) - ), - runTestM "compile ELambda (FormalNamedSet)" $ do - idx <- - compileExpr - ( ELambda - (FormalNamedSet "args" [Formal "x" Nothing] True) - (EResolvedVar 0 0) - NoCaptureInfo - ) - op <- cbcOpcode idx - fl <- cbcFlags idx - pure - ( if op == OpLambda && fl == formalNamedSet - then Pass - else Fail ("flags=" <> T.pack (show fl)) - ), - runTestM "compile CaptureInfo (Captures)" $ do - idx <- - compileExpr - ( ELambda - (FormalName "x") - (EResolvedVar 0 0) - (Captures [(1, 2), (3, 4)]) - ) - op <- cbcOpcode idx - capOff <- cbcArg3 idx - capTag <- cbcData capOff - capCount <- cbcData (capOff + 1) - capL0 <- cbcData (capOff + 2) - capI0 <- cbcData (capOff + 3) - capL1 <- cbcData (capOff + 4) - capI1 <- cbcData (capOff + 5) - pure - ( if op == OpLambda - && capTag == captureSlots - && capCount == 2 - && capL0 == 1 - && capI0 == 2 - && capL1 == 3 - && capI1 == 4 - then Pass - else - Fail - ( "capTag=" - <> T.pack (show capTag) - <> " capCount=" - <> T.pack (show capCount) - ) - ), - runTestM "compile CaptureInfo (CapturesWithScopes)" $ do - idx <- - compileExpr - ( ELambda - (FormalName "x") - (EResolvedVar 0 0) - (CapturesWithScopes [(0, 0)]) - ) - capOff <- cbcArg3 idx - capTag <- cbcData capOff - pure (assertEqual "captureTag" captureWithScopes capTag), - runTestM "compile EWithVar" $ do - idx <- compileExpr (EWithVar "dynamic") - op <- cbcOpcode idx - sym <- cbcArg1 idx - pure - ( if op == OpWithVar && symbolText (Symbol sym) == "dynamic" - then Pass - else Fail "withvar mismatch" - ), - runTestM "compile EIndStr" $ do - idx <- compileExpr (EIndStr [StrLit "indented"]) - op <- cbcOpcode idx - count <- cbcShortArg idx - pure - ( if op == OpIndStr && count == 1 - then Pass - else Fail "indstr mismatch" - ) - ] - --- --------------------------------------------------------------------------- --- Tests: substituter signature verification (the --trusted-key trust gate) --- --------------------------------------------------------------------------- - --- | Minimal narinfo for signing tests; the fingerprint covers StorePath, --- NarHash, NarSize, and References. -sigTestNarInfo :: NarInfo.NarInfo -sigTestNarInfo = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0", - NarInfo.niUrl = "nar/aaaa.nar", - NarInfo.niCompression = "none", - NarInfo.niFileHash = Just ("sha256:" <> T.replicate 52 "0"), - NarInfo.niFileSize = Just 1, - NarInfo.niNarHash = "sha256:" <> T.replicate 52 "0", - NarInfo.niNarSize = 1, - NarInfo.niReferences = [], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - --- | A substituter cache trusting the given public key text. -sigTestCache :: Text -> Subst.CacheConfig -sigTestCache publicKeyText = - Subst.CacheConfig - { Subst.ccUrl = "http://localhost/test-cache", - Subst.ccPublicKeys = [publicKeyText], - Subst.ccPriority = 40 - } - --- | Deterministic Ed25519 test keys: a nix secret key file is --- seed(32) + public(32), and both signing and public-key derivation use --- only the seed, so the public half can be zeros here. Both keys carry --- the SAME name so the wrong-key test exercises the cryptographic --- verification, not just the name comparison. -sigTestKeyText, sigTestWrongKeyText :: Text -sigTestKeyText = "test-key-1:" <> B64.encode (BS.pack ([1 .. 32] ++ replicate 32 0)) -sigTestWrongKeyText = "test-key-1:" <> B64.encode (BS.pack ([101 .. 132] ++ replicate 32 0)) - --- | Derive (trusted cache, signature by the trusted key, signature by an --- impostor key with the same name). Left on any setup failure. -sigTestSetup :: Either String (Subst.CacheConfig, Text, Text) -sigTestSetup = do - secretKey <- Signing.parseSecretKey sigTestKeyText - impostorKey <- Signing.parseSecretKey sigTestWrongKeyText - publicKey <- Signing.toPublicKey secretKey - let publicKeyText = Signing.renderPublicKey publicKey - validSig <- Signing.sign secretKey sigTestNarInfo - impostorSig <- Signing.sign impostorKey sigTestNarInfo - pure (sigTestCache publicKeyText, validSig, impostorSig) - --- | verifySigs is the security boundary behind @--trusted-key@: unsigned --- narinfos, wrong-key signatures, and malformed trusted keys must all be --- rejected; a valid signature must be accepted. -testVerifySigs :: IO [Bool] -testVerifySigs = do - putStrLn "substituter/verify-sigs" - case sigTestSetup of - Left err -> (: []) <$> runTest "verifySigs test setup" (Fail (T.pack err)) - Right (cache, validSig, impostorSig) -> - sequence - [ runTest "valid signature accepted" $ - assertEqual "verify ok" (Right ()) (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = [validSig]}), - runTest "unsigned narinfo rejected" $ - assertLeft "no sigs" (Subst.verifySigs cache sigTestNarInfo), - runTest "same-name signature from a different key rejected" $ - assertLeft "impostor sig" (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = [impostorSig]}), - runTest "valid signature among invalid ones accepted" $ - assertEqual "any valid" (Right ()) (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = [impostorSig, validSig]}), - runTest "signature under a different key name rejected" $ - assertLeft "name mismatch" (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = ["other-key:" <> T.drop (T.length "test-key-1:") validSig]}), - runTest "malformed trusted public key rejected" $ - assertLeft "bad pubkey" (Subst.verifySigs (sigTestCache "not-a-key") sigTestNarInfo {NarInfo.niSigs = [validSig]}), - -- The flat trusted-key set: a signature valid under ANY of - -- several trusted keys is accepted, even when the matching key - -- is not first. - runTest "a signature valid under any of several trusted keys is accepted" $ - let multiKey = cache {Subst.ccPublicKeys = Subst.ccPublicKeys Subst.defaultCacheConfig ++ Subst.ccPublicKeys cache} - in assertEqual "any-of" (Right ()) (Subst.verifySigs multiKey sigTestNarInfo {NarInfo.niSigs = [validSig]}), - runTest "a signature matching none of several trusted keys is rejected" $ - let multiKey = cache {Subst.ccPublicKeys = ["cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=", "other.cache-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY="]} - in assertLeft "none-of" (Subst.verifySigs multiKey sigTestNarInfo {NarInfo.niSigs = [validSig]}), - -- A malformed key anywhere in the set is an error, not a - -- silently skipped key: a typo must not quietly narrow the - -- trusted set to the keys that happened to parse. - runTest "a malformed key among valid ones is an error, not skipped" $ - let multiKey = cache {Subst.ccPublicKeys = "not-a-key" : Subst.ccPublicKeys cache} - in assertLeft "typo not skipped" (Subst.verifySigs multiKey sigTestNarInfo {NarInfo.niSigs = [validSig]}) - ] - --- | The nix.conf / NIX_CONFIG resolver: parsing, aliases, the extra- --- append rule, the precedence fold, include expansion over an in-memory --- file map, and the file cascade. The trusted-key cases are the --- security-relevant ones, a plain assignment in a higher source replaces --- the trusted set, an extra- widens it. -testNixConfig :: IO [Bool] -testNixConfig = do - putStrLn "config/nix-conf" - let -- A root the platform agrees is absolute: "/" is not one on - -- Windows, for System.FilePath and for upstream's canonPath alike. - root = if SI.os == "mingw32" then "C:\\" else "/" - etcNix = root "etc" "nix" - etcXdg = root "etc" "xdg" - etcXdgLocal = root "etc" "xdg-local" - configHome = root "home" "u" ".config" - systemConf = etcNix "nix.conf" - xdgConf dir = dir "nix" "nix.conf" - -- The expander's one effect, served from an in-memory map: a path - -- is in it or there is nothing there. - readFrom files path = Identity (maybe (Left Config.ConfigFileMissing) Right (Map.lookup path files)) - resolveWith files paths env = runIdentity (Config.loadConfig (readFrom files) paths env) - substitutersOf files paths env = ncSubstituters <$> resolveWith files paths env - fileMap = Map.mapKeys asciiOsPath . Map.fromList - -- The same, over the cascade a 'ConfigLocations' computes. - substitutersAt files locations env = Config.configFilePaths locations >>= \paths -> substitutersOf files paths env - firstPathOf locations = listToMaybe <$> Config.configFilePaths locations - -- Successive texts as successive files, weakest first. - resolveTexts texts = - let paths = [asciiOsPath (root "src" (show index ++ ".conf")) | index <- [1 .. length texts]] - in resolveWith (Map.fromList (zip paths texts)) paths Nothing - subs = fmap ncSubstituters . resolveTexts - keys = fmap ncTrustedPublicKeys . resolveTexts - uris = fmap ncAllowedUris . resolveTexts - cascade = - Config.ConfigLocations - { Config.clConfDir = Nothing, - Config.clSystemConfDir = Just (asciiOsPath etcNix), - Config.clUserConfFiles = Nothing, - Config.clConfigHome = asciiOsPath configHome, - Config.clConfigDirs = map asciiOsPath [etcXdg, etcXdgLocal] - } - cascadeFiles = - fileMap - [ (systemConf, "substituters = https://system"), - (xdgConf etcXdgLocal, "substituters = https://xdg-local"), - (xdgConf etcXdg, "substituters = https://xdg"), - (xdgConf configHome, "substituters = https://home") - ] - listVar = BS8.pack . intercalate [searchPathSeparator] - depth = fmap ncMaxCallDepth . resolveTexts - depthOf value = depth ["max-call-depth = " <> value] - refused = either (const True) (const False) . depthOf - -- Bytes with no UTF-8 reading (0xE9, Latin-1's e-acute). They are - -- a host path on POSIX and none on Windows, whose paths are UTF-16, - -- so the cases holding them branch on whether they spell one. - latin1 = "caf\xE9" :: BS.ByteString - -- What a lossy decode would open instead: U+FFFD's UTF-8. - replaced = "caf\xEF\xBF\xBD" - nixConfName = asciiOsPath "nix.conf" - sequence - [ runTest "parses a whitespace-split substituters list" $ - assertEqual "subs" (Right ["https://a", "https://b"]) (subs ["substituters = https://a https://b"]), - runTest "a comment truncates the line" $ - assertEqual "comment" (Right ["https://a"]) (subs ["substituters = https://a # not https://b"]), - runTest "a plain assignment replaces across sources" $ - assertEqual "replace" (Right ["https://b"]) (subs ["substituters = https://a", "substituters = https://b"]), - runTest "extra- appends within a source set" $ - assertEqual "append" (Right ["https://a", "https://b"]) (subs ["substituters = https://a", "extra-substituters = https://b"]), - runTest "binary-caches aliases substituters" $ - assertEqual "alias" (Right ["https://a"]) (subs ["binary-caches = https://a"]), - runTest "extra- composes with an alias" $ - assertEqual "extra-alias" (Right ["https://a", "https://b"]) (subs ["substituters = https://a", "extra-binary-caches = https://b"]), - runTest "binary-cache-public-keys aliases trusted-public-keys" $ - assertEqual "key-alias" (Right ["k1"]) (keys ["binary-cache-public-keys = k1"]), - runTest "a higher source plainly replaces the trusted set" $ - assertEqual "trust-replace" (Right ["k2"]) (keys ["trusted-public-keys = k1", "trusted-public-keys = k2"]), - runTest "a higher source with extra- widens the trusted set" $ - assertEqual "trust-widen" (Right ["k1", "k2"]) (keys ["trusted-public-keys = k1", "extra-trusted-public-keys = k2"]), - runTest "an unknown setting is ignored, not an error" $ - assertEqual "unknown" (Right ["https://a"]) (subs ["cores = 4\nsubstituters = https://a"]), - runTest "blank and comment-only lines are skipped" $ - assertEqual "blanks" (Right ["https://a"]) (subs ["# a comment\n\nsubstituters = https://a\n"]), - runTest "a line missing = is a syntax error quoting the line as truncated, untrimmed" $ - let expected = "nix.conf: syntax error in configuration line ' substituters https://a ' in '" <> T.pack (root "src" "1.conf") <> "'" - in assertEqual "syntax" (Left expected) (resolveTexts [" substituters https://a # comment"]), - runTest "the default config is empty" $ - assertEqual "default" (Right []) (subs []), - -- Tokens, as upstream's tokenizeString splits them: on space, tab, - -- CR and LF only, which nix config show 2.33.2 agrees with. - runTest "a value splits on space, tab and CR, and not on other spaces" $ - assertEqual - "separators" - (Right ["https://a\xA0https://b\vhttps://c\fhttps://d", "https://e", "https://f", "https://g"]) - (uris ["allowed-uris = https://a\xC2\xA0https://b\vhttps://c\fhttps://d https://e\rhttps://f\thttps://g"]), - runTest "a CRLF line ends where its LF does" $ - assertEqual "crlf" (Right ["https://a"]) (subs ["substituters = https://a\r\n"]), - runTest "a Boolean value ending in a no-break space is upstream's invalid-value error" $ - assertEqual "nbsp-bool" (Left "Boolean setting 'pure-eval' has invalid value 'true\xA0'") (ncPureEval <$> resolveTexts ["pure-eval = true\xC2\xA0"]), - -- Bytes with no UTF-8 reading in a setting. - runTest "a comment and an unknown setting holding a byte with no UTF-8 reading are never decoded" $ - assertEqual "bytes-ignored" (Right ["https://a"]) (substitutersOf Map.empty [] (Just ("trusted-users = " <> latin1 <> "\nsubstituters = https://a # " <> latin1))), - runTest "a list setting holding a byte with no UTF-8 reading is refused under its own name" $ - let expected = "setting 'substituters' has invalid value 'https://caf\xFFFD.example': not valid UTF-8" - in assertEqual "list-bytes" (Left expected) (substitutersOf Map.empty [] (Just ("extra-binary-caches = https://" <> latin1 <> ".example"))), - runTest "a Boolean or integer setting holding such a byte is upstream's invalid-value error" $ - assertEqual - "scalar-bytes" - (Left "Boolean setting 'pure-eval' has invalid value 'true\xFFFD'", Left "setting 'max-call-depth' has invalid value '5\xFFFD'") - (ncPureEval <$> resolveTexts ["pure-eval = true\xE9"], depthOf "5\xE9"), - -- max-call-depth: a scalar under upstream's unsigned-integer grammar. - runTest "max-call-depth defaults to upstream's 10000" $ - assertEqual "depth-default" (Right 10000) (depth []), - runTest "max-call-depth parses a decimal" $ - assertEqual "depth-decimal" (Right 5) (depthOf "5"), - runTest "a higher source replaces max-call-depth" $ - assertEqual "depth-replace" (Right 7) (depth ["max-call-depth = 5", "max-call-depth = 7"]), - runTest "max-call-depth takes a binary unit suffix in either case" $ - assertEqual "depth-unit" (Right [10240, 5120, 1048576]) (traverse depthOf ["10K", "5k", "1M"]), - runTest "max-call-depth takes a leading plus and leading zeros" $ - assertEqual "depth-plus" (Right [5, 7]) (traverse depthOf ["+5", "007"]), - runTest "max-call-depth accepts the top of unsigned int" $ - assertEqual "depth-top" (Right 4294967295) (depthOf "4294967295"), - runTest "an invalid max-call-depth is refused with upstream's words" $ - assertEqual "depth-invalid" (Left "setting 'max-call-depth' has invalid value 'abc'") (depthOf "abc"), - runTest "max-call-depth refuses a sign, a fraction, hex, an unknown unit, an empty value and a second token" $ - assertEqual "depth-refused" (True, 6) (all refused rejects, length rejects), - runTest "max-call-depth refuses a value past unsigned int, a unit product included" $ - assertEqual "depth-range" True (refused "4294967296" && refused "5G"), - runTest "extra-max-call-depth is an unknown name, not an append" $ - assertEqual "depth-extra" (Right 10000) (depth ["extra-max-call-depth = 5"]), - -- Includes. - runTest "an include is spliced in at its line, resolved against the including file's directory" $ - let files = - fileMap - [ (systemConf, "substituters = https://a\ninclude site.conf\nextra-substituters = https://c"), - (etcNix "site.conf", "extra-substituters = https://b") - ] - in assertEqual "inline" (Right ["https://a", "https://b", "https://c"]) (substitutersOf files [asciiOsPath systemConf] Nothing), - runTest "a nested include resolves against the nested file, with .. collapsed" $ - let files = - fileMap - [ (systemConf, "include sub/one.conf"), - (etcNix "sub" "one.conf", "include ../two.conf"), - (etcNix "two.conf", "substituters = https://two") - ] - in assertEqual "nested" (Right ["https://two"]) (substitutersOf files [asciiOsPath systemConf] Nothing), - runTest "!include of a file that cannot be read is skipped" $ - let files = fileMap [(systemConf, "substituters = https://a\n!include missing.conf\nextra-substituters = https://b")] - in assertEqual "optional" (Right ["https://a", "https://b"]) (substitutersOf files [asciiOsPath systemConf] Nothing), - runTest "include of a missing file is an error in upstream's words, naming both files" $ - let files = fileMap [(systemConf, "include missing.conf")] - expected = "nix.conf: file '" <> T.pack (etcNix "missing.conf") <> "' included from '" <> T.pack systemConf <> "' not found" - in assertEqual "required" (Left expected) (substitutersOf files [asciiOsPath systemConf] Nothing), - -- A file that exists but will not open: upstream drops it, here a - -- required include of it is an error in its own words. - runTest "include of a file that exists but cannot be read is an error, not a silent drop" $ - let locked = etcNix "locked.conf" - readLocked path = Identity (if path == asciiOsPath locked then Left Config.ConfigFileUnreadable else Right "include locked.conf") - expected = "nix.conf: file '" <> T.pack locked <> "' included from '" <> T.pack systemConf <> "' cannot be read" - in assertEqual "unreadable" (Left expected) (ncSubstituters <$> runIdentity (Config.loadConfig readLocked [asciiOsPath systemConf] Nothing)), - runTest "!include of a file that exists but cannot be read is skipped" $ - let locked = etcNix "locked.conf" - readLocked path = Identity (if path == asciiOsPath locked then Left Config.ConfigFileUnreadable else Right "!include locked.conf\nsubstituters = https://a") - in assertEqual "unreadable-optional" (Right ["https://a"]) (ncSubstituters <$> runIdentity (Config.loadConfig readLocked [asciiOsPath systemConf] Nothing)), - runTest "an include cycle is refused rather than followed" $ - let files = fileMap [(systemConf, "include site.conf"), (etcNix "site.conf", "include nix.conf")] - in assertLeft "cycle" (substitutersOf files [asciiOsPath systemConf] Nothing), - runTest "an include with no path or two paths is a syntax error" $ - assertEqual "arity" [True, True, True] (map (either (const True) (const False) . resolveTexts . pure) ["include", "include a b", "!include"]), - runTest "a relative include from NIX_CONFIG is refused as not absolute" $ - let expected = "nix.conf: not an absolute path: '" <> T.pack ("." "rel.conf") <> "'" - in assertEqual "env-relative" (Left expected) (substitutersOf Map.empty [] (Just "include rel.conf")), - runTest "an absolute include from NIX_CONFIG is expanded" $ - let files = fileMap [(etcNix "x.conf", "substituters = https://x")] - in assertEqual "env-absolute" (Right ["https://x"]) (substitutersOf files [] (Just ("include " <> BS8.pack (etcNix "x.conf")))), - -- An include target is bytes from the line to the open (#244): the - -- file its bytes name is read, never the one a lossy decode names. - runTest "an include target with no UTF-8 reading opens the file its bytes name" $ - let target = latin1 <> ".conf" - including = fileMap [(systemConf, "include " <> target)] - decoy = maybe including (\name -> Map.insert (asciiOsPath etcNix OP. name) "substituters = https://replacement" including) (hostPathFromBytes (replaced <> ".conf")) - in case hostPathFromBytes target of - Just name -> - let files = Map.insert (asciiOsPath etcNix OP. name) "substituters = https://latin1" decoy - in assertEqual "include-bytes" (Right ["https://latin1"]) (substitutersOf files [asciiOsPath systemConf] Nothing) - Nothing -> - let expected = "nix.conf: file 'caf\xFFFD.conf' included from '" <> T.pack systemConf <> "' is not valid UTF-8, so it names no Windows file" - in assertEqual "include-bytes-windows" (Left expected) (substitutersOf decoy [asciiOsPath systemConf] Nothing), - runTest "!include of a target with no UTF-8 reading that names nothing goes on without it" $ - let files = fileMap [(systemConf, "!include " <> latin1 <> ".conf\nsubstituters = https://a")] - in assertEqual "optional-bytes" (Right ["https://a"]) (substitutersOf files [asciiOsPath systemConf] Nothing), - -- The directories a cascade names keep their bytes too, so the - -- system file under such a NIX_CONF_DIR, and an include beside a - -- file under such a config home, are the files those bytes name. - runTest "NIX_CONF_DIR holding a byte with no UTF-8 reading names the system file by its bytes" $ - let confDir = BS8.pack (etcNix ++ "-") <> latin1 - located = cascade {Config.clConfDir = Just confDir, Config.clUserConfFiles = Just ""} - in case hostPathFromBytes confDir of - Just dir -> - let files = Map.fromList [(dir OP. nixConfName, "include site.conf"), (dir OP. asciiOsPath "site.conf", "substituters = https://conf-dir")] - in assertEqual "conf-dir-bytes" (Right (Just (dir OP. nixConfName)), Right ["https://conf-dir"]) (firstPathOf located, substitutersAt files located Nothing) - Nothing -> assertLeft "conf-dir-bytes-windows" (firstPathOf located), - runTest "an include beside a user file under a config home holding such a byte resolves beneath it" $ - case hostPathFromBytes (BS8.pack (configHome ++ "-") <> latin1) of - Just home -> - let located = cascade {Config.clSystemConfDir = Nothing, Config.clConfigHome = home, Config.clConfigDirs = []} - userDir = home OP. asciiOsPath "nix" - files = Map.fromList [(userDir OP. nixConfName, "include more.conf"), (userDir OP. asciiOsPath "more.conf", "substituters = https://home-bytes")] - in assertEqual "home-bytes" (Right ["https://home-bytes"]) (substitutersAt files located Nothing) - Nothing -> assertEqual "home-bytes-windows" "mingw32" SI.os, - -- The cascade: which files, in which order, and who wins. - runTest "the cascade is the system file, XDG_CONFIG_DIRS back to front, then the config home" $ - assertEqual "order" (Right (map asciiOsPath [systemConf, xdgConf etcXdgLocal, xdgConf etcXdg, xdgConf configHome])) (Config.configFilePaths cascade), - runTest "the config home beats XDG_CONFIG_DIRS beats the system file" $ - assertEqual "home-wins" (Right ["https://home"]) (substitutersAt cascadeFiles cascade Nothing), - runTest "the first XDG_CONFIG_DIRS entry beats the later ones" $ - assertEqual "xdg-first" (Right ["https://xdg"]) (substitutersAt (Map.delete (asciiOsPath (xdgConf configHome)) cascadeFiles) cascade Nothing), - runTest "a listed file that cannot be read is absent, not an error" $ - assertEqual "absent" (Right ["https://system"]) (substitutersAt (Map.filterWithKey (\path _ -> path == asciiOsPath systemConf) cascadeFiles) cascade Nothing), - runTest "extra- in a stronger file widens what a weaker file set" $ - let files = fileMap [(systemConf, "trusted-public-keys = k1"), (xdgConf configHome, "extra-trusted-public-keys = k2")] - in assertEqual "widen-across-files" (Right ["k1", "k2"]) (fmap ncTrustedPublicKeys (Config.configFilePaths cascade >>= \paths -> resolveWith files paths Nothing)), - runTest "NIX_CONFIG beats every file" $ - assertEqual "env-wins" (Right ["https://env"]) (substitutersAt cascadeFiles cascade (Just "substituters = https://env")), - runTest "NIX_USER_CONF_FILES replaces the XDG files, first listed strongest" $ - let listed = cascade {Config.clUserConfFiles = Just (listVar [etcNix "a.conf", etcNix "b.conf"])} - in assertEqual "listed" (Right (map asciiOsPath [systemConf, etcNix "b.conf", etcNix "a.conf"])) (Config.configFilePaths listed), - runTest "an empty NIX_USER_CONF_FILES names no user files" $ - assertEqual "none" (Right [asciiOsPath systemConf]) (Config.configFilePaths cascade {Config.clUserConfFiles = Just ""}), - runTest "empty NIX_USER_CONF_FILES entries are dropped" $ - assertEqual "empties" (Right (map asciiOsPath [systemConf, etcNix "a.conf"])) (Config.configFilePaths cascade {Config.clUserConfFiles = Just (listVar ["", etcNix "a.conf", ""])}), - runTest "NIX_CONF_DIR moves the system file" $ - assertEqual "conf-dir" (Right (Just (asciiOsPath (etcXdg "nix.conf")))) (firstPathOf cascade {Config.clConfDir = Just (BS8.pack etcXdg)}), - runTest "an empty NIX_CONF_DIR is unset" $ - assertEqual "conf-dir-empty" (Right (Just (asciiOsPath systemConf))) (firstPathOf cascade {Config.clConfDir = Just ""}), - runTest "a relative NIX_CONF_DIR is refused with upstream's complaint" $ - assertEqual "conf-dir-relative" (Left "nix.conf: not an absolute path: 'rel'") (firstPathOf cascade {Config.clConfDir = Just "rel"}), - runTest "dot and dot-dot in NIX_CONF_DIR collapse, so the system file is named canonically" $ - assertEqual "conf-dir-canonical" (Right (Just (asciiOsPath systemConf))) (firstPathOf cascade {Config.clConfDir = Just (BS8.pack (root "etc" "x" ".." "." "nix"))}), - -- A UNC directory keeps its server on Windows, where System.FilePath - -- and std::filesystem both read it as the drive; a doubled POSIX - -- root is one root, as upstream's canonPath folds it. - runTest "a UNC NIX_CONF_DIR keeps its root, and its include resolves beneath it" $ - let (dir, expected) = - if SI.os == "mingw32" - then ("\\\\server\\share", "\\\\server\\share\\nix.conf") - else ("//server/share", "/server/share/nix.conf") - uncConf = takeDirectory expected "site.conf" - files = fileMap [(expected, "include site.conf"), (uncConf, "substituters = https://unc")] - unc = cascade {Config.clConfDir = Just (BS8.pack dir), Config.clUserConfFiles = Just ""} - in assertEqual "unc" (Right (Just (asciiOsPath expected)), Right ["https://unc"]) (firstPathOf unc, substitutersAt files unc Nothing), - runTest "a platform with no machine-wide directory has no system file" $ - assertEqual "no-system-dir" (Right (map asciiOsPath [xdgConf etcXdgLocal, xdgConf etcXdg, xdgConf configHome])) (Config.configFilePaths cascade {Config.clSystemConfDir = Nothing}), - runTest "NIX_CONF_DIR names a system file even where the platform has no directory for one" $ - assertEqual "conf-dir-no-default" (Right (Just (asciiOsPath (etcXdg "nix.conf")))) (firstPathOf cascade {Config.clSystemConfDir = Nothing, Config.clConfDir = Just (BS8.pack etcXdg)}) - ] - where - rejects = ["-1", "1.5", "0x10", "5X", "", "5 6"] - --- | A test path as the config expander names it. Test paths spelled --- this way are ASCII, which 'OP.unsafeFromChar' narrows to one path unit --- exactly on every platform. -asciiOsPath :: FilePath -> OsPath -asciiOsPath = OP.pack . map OP.unsafeFromChar - --- | Narinfo field validation gates the pipeline ahead of the signed --- fingerprint: a malformed field must fail as a parse error before its --- text can reach the fingerprint or anything downstream. -testNarInfoValidation :: IO [Bool] -testNarInfoValidation = do - putStrLn "substituter/narinfo-field-validation" - sequence - [ runTest "well-formed narinfo passes" $ - assertEqual "valid" (Right ()) (Subst.validateNarInfoFields sigTestNarInfo), - runTest "malformed StorePath rejected" $ - assertLeft "bad store path" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niStorePath = "/nix/store/zzz"}), - runTest "derivation StorePath rejected" $ - assertLeft "drv path" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niStorePath = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0.drv"}), - runTest "malformed reference rejected" $ - assertLeft "bad reference" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niReferences = ["../escape"]}), - runTest "malformed NarHash rejected" $ - assertLeft "bad narhash" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niNarHash = "sha256:nope"}), - runTest "negative NarSize rejected" $ - assertLeft "negative narsize" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niNarSize = -1}), - runTest "field validation reports ahead of signature verification" $ - case sigTestSetup of - Left err -> Fail (T.pack err) - Right (cache, validSig, _) -> - case Subst.narInfoPreflight cache sigTestNarInfo {NarInfo.niStorePath = "/nix/store/zzz", NarInfo.niSigs = [validSig]} of - Left err - | "invalid narinfo" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected the field-validation error, got: " <> err) - Right () -> Fail "expected failure, got a clean preflight" - ] - --- --------------------------------------------------------------------------- --- Tests: resolver static globals stay in sync with the root env --- --------------------------------------------------------------------------- - --- | The names upstream 2.24.9's base environment binds with default --- settings, recorded from its source: every @addConstant@ and @addPrimOp@ --- in @createBaseEnv@ (src/libexpr/primops.cc) and every @RegisterPrimOp@ --- in libexpr and libflake not gated on an experimental feature, under the --- name it registers. @__importNative@ and @__exec@ need --- @allow-unsafe-native-code-during-evaluation@ and are not here. -upstreamBaseEnvNames :: Set.Set Text -upstreamBaseEnvNames = - Set.fromList - [ "__add", - "__addDrvOutputDependencies", - "__addErrorContext", - "__all", - "__any", - "__appendContext", - "__attrNames", - "__attrValues", - "__bitAnd", - "__bitOr", - "__bitXor", - "__catAttrs", - "__ceil", - "__compareVersions", - "__concatLists", - "__concatMap", - "__concatStringsSep", - "__convertHash", - "__currentSystem", - "__currentTime", - "__deepSeq", - "__div", - "__elem", - "__elemAt", - "__fetchurl", - "__filter", - "__filterSource", - "__findFile", - "__floor", - "__foldl'", - "__fromJSON", - "__functionArgs", - "__genList", - "__genericClosure", - "__getAttr", - "__getContext", - "__getEnv", - "__groupBy", - "__hasAttr", - "__hasContext", - "__hashFile", - "__hashString", - "__head", - "__intersectAttrs", - "__isAttrs", - "__isBool", - "__isFloat", - "__isFunction", - "__isInt", - "__isList", - "__isPath", - "__isString", - "__langVersion", - "__length", - "__lessThan", - "__listToAttrs", - "__mapAttrs", - "__match", - "__mul", - "__nixPath", - "__nixVersion", - "__parseDrvName", - "__partition", - "__path", - "__pathExists", - "__readDir", - "__readFile", - "__readFileType", - "__replaceStrings", - "__seq", - "__sort", - "__split", - "__splitVersion", - "__storeDir", - "__storePath", - "__stringLength", - "__sub", - "__substring", - "__tail", - "__toFile", - "__toJSON", - "__toPath", - "__toXML", - "__trace", - "__traceVerbose", - "__tryEval", - "__typeOf", - "__unsafeDiscardOutputDependency", - "__unsafeDiscardStringContext", - "__unsafeGetAttrPos", - "__warn", - "__zipAttrsWith", - "abort", - "baseNameOf", - "break", - "builtins", - "derivation", - "derivationStrict", - "dirOf", - "false", - "fetchGit", - "fetchMercurial", - "fetchTarball", - "fromTOML", - "import", - "isNull", - "map", - "null", - "placeholder", - "removeAttrs", - "scopedImport", - "throw", - "toString", - "true" - ] - --- | The two @addConstant@ calls marked @impureOnly@, which upstream skips --- under @pure-eval@. -upstreamImpureOnlyNames :: Set.Set Text -upstreamImpureOnlyNames = Set.fromList ["__currentSystem", "__currentTime"] - --- | Binding accepts exactly the names upstream's base environment holds, --- and the root environment binds exactly the names binding accepts, under --- each policy, every one of them to a value that forces. -testStaticGlobalsSync :: IO [Bool] -testStaticGlobalsSync = do - putStrLn "resolve/static-globals-sync" - let pureNames = Set.difference upstreamBaseEnvNames upstreamImpureOnlyNames - unrestrictedRoot <- rootEnvNames unrestrictedPolicy - pureRoot <- rootEnvNames purePolicy - sequence - [ runTest "binding accepts upstream's base environment" $ - assertSameNames "static globals" upstreamBaseEnvNames staticGlobalNames, - runTest "pure evaluation drops upstream's impure-only constants" $ - assertEqual "impure-only" upstreamImpureOnlyNames impureOnlyGlobalNames - `andThen` assertSameNames "pure scope" pureNames (rootScopeNames purePolicy), - runTest "the root env binds exactly those names" $ - assertSameNames "root env" upstreamBaseEnvNames unrestrictedRoot - `andThen` assertSameNames "pure root env" pureNames pureRoot, - runTest "every root env name forces" $ - assertEqual - "names that fail to force" - [] - [ name - | name <- Set.toList upstreamBaseEnvNames, - evalNix ("builtins.seq " <> name <> " true") /= Right (VBool True) - ] - ] - where - rootEnvNames policy = case builtinEnv policy 0 [] of - Env envPtr -> do - scopePtr <- cenvLazyScope envPtr - pure (Set.fromList (attrSetKeys (AttrSet (castPtr scopePtr)))) - assertSameNames label expected actual = - assertEqual - (label <> ": (missing, extra)") - ([], []) - (Set.toList (Set.difference expected actual), Set.toList (Set.difference actual expected)) - --- --------------------------------------------------------------------------- --- Tests: variables are bound before evaluation (upstream's bindVars) --- --------------------------------------------------------------------------- - --- | Assert that binding rejects a source for the named variable, before --- anything is evaluated. -assertUnbound :: Text -> Text -> Text -> TestResult -assertUnbound label source name = case parseNix testBaseDir "" source of - Left err -> assertEqual label (UndefinedVariable name) err - Right expr -> Fail (label <> ": bound, got " <> T.pack (show expr)) - --- | Assert that every variable in a source binds. -assertBinds :: Text -> Text -> TestResult -assertBinds label source = assertRight label (parseNix testBaseDir "" source) (const Pass) - --- | Upstream rejects a variable no scope binds and no @with@ could supply --- while binding (nixexpr.cc, ExprVar::bindVars), wherever it sits; only a --- name under a @with@ waits for evaluation. Each expectation here is --- nix-instantiate 2.33.2's. -testUndefinedVariables :: IO [Bool] -testUndefinedVariables = do - putStrLn "resolve/undefined-variables" - sequence - [ runTest "an unbound variable in an unused let binding is rejected" $ - assertUnbound "unused-let" "let x = y; in 1" "y", - runTest "an unbound variable on a branch not taken is rejected" $ - assertUnbound "untaken-branch" "if true then 1 else y" "y", - runTest "tryEval has nothing to catch: binding fails first" $ - assertUnbound "tryEval" "builtins.tryEval (let x = y; in 1)" "y", - runTest "the failure reads as upstream's" $ - assertEvalError "message" "builtins.tryEval (let x = y; in 1)" "undefined variable 'y'", - runTest "the first unbound variable in source order is reported" $ - assertUnbound "first" "let a = b; c = d; in 1" "b", - runTest "a name under a with binds" $ - assertBinds "with-binds" "with {}; y", - runTest "a name no with supplies fails when evaluated" $ - assertEvalError "with-eval" "with {}; y" "undefined variable 'y'", - runTest "an unused binding may read a name only a with could supply" $ - assertEval "with-unused" "with {}; let x = y; in 1" (VInt 1), - runTest "a with supplies a name a let binding reads" $ - assertEval "with-let" "with { y = 3; }; let x = y; in x" (VInt 3), - runTest "a nested let shadows the enclosing one" $ - assertEval "let-shadow" "let y = 1; in let y = 2; x = y; in x" (VInt 2), - runTest "a nested rec reads the enclosing rec" $ - assertEval "rec-nested" "rec { a = 1; b = rec { c = a; }.c; }.b" (VInt 1), - runTest "a rec reading a name it does not define is rejected" $ - assertUnbound "rec-missing" "rec { a = b; }" "b", - runTest "a lambda formal shadows a with" $ - assertEval "formal-over-with" "(x: with { x = 2; }; x) 1" (VInt 1), - runTest "a formal default reads a sibling formal" $ - assertEval "formal-default" "({ a, b ? a }: b) { a = 3; }" (VInt 3), - runTest "an unbound formal default is rejected" $ - assertUnbound "formal-default-unbound" "{ a ? b }: a" "b", - runTest "inherit of an unbound name in a let is rejected" $ - assertUnbound "let-inherit" "let inherit x; in 1" "x", - runTest "inherit of an unbound name in a set is rejected" $ - assertUnbound "set-inherit" "{ inherit x; }" "x", - runTest "inherit of an unbound name in a rec is rejected" $ - assertUnbound "rec-inherit" "rec { inherit x; }" "x", - runTest "inherit reads a name only a with supplies" $ - assertEval "with-inherit" "with { x = 5; }; rec { inherit x; }.x" (VInt 5), - runTest "inherit under an empty with fails only when selected" $ - assertEvalError "with-inherit-missing" "with {}; { inherit x; }.x" "undefined variable 'x'", - runTest "inherit in a rec reads the enclosing binding, not its own" $ - assertEval "rec-inherit-outer" "(x: rec { inherit x; y = x; }.y) 4" (VInt 4), - runTest "inherit from an unbound source is rejected" $ - assertUnbound "inherit-from-unbound" "{ inherit (s) x; }" "s", - runTest "inherit from selects lazily" $ - assertEval "inherit-from-lazy" "let s = {}; in builtins.attrNames { inherit (s) x; } == [ \"x\" ]" (VBool True), - runTest "inherit from fails when the attribute is selected" $ - assertEvalFail "inherit-from-missing" "let s = {}; in { inherit (s) x; }.x", - runTest "an inherit clause cannot repeat a name" $ - assertParseFail "inherit-repeat" "let x = 1; in { inherit x x; }", - runTest "an inherit-from clause cannot repeat a name" $ - assertParseFail "inherit-from-repeat" "let s = { x = 1; }; in { inherit (s) x x; }", - runTest "__curPos is upstream syntax, not a variable" $ - assertEval "curpos" "if false then __curPos else 1" (VInt 1), - runTest "inherit in a static-key rec reads the enclosing rec" $ - assertEval "rec-inherit-static" "rec { q = 0; x = 1; y = rec { a = 1; inherit x; }; }.y.x" (VInt 1), - runTest "a __-prefixed builtin on a branch not taken binds" $ - assertEval "prefixed-untaken" "if false then __typeOf 1 else 2" (VInt 2), - runTest "a __-prefixed builtin is the builtin" $ - assertEval "prefixed-value" "__typeOf 1 == \"int\"" (VBool True), - runTest "a global is not shadowed by a with" $ - assertEval "prefixed-over-with" "with { __typeOf = 1; }; __typeOf 2 == \"int\"" (VBool True), - runTest "fetchMercurial binds as a builtin" $ - assertEval "fetchMercurial-binds" "builtins.typeOf fetchMercurial == \"lambda\"" (VBool True), - runTest "calling fetchMercurial fails as a builtin nova-nix lacks" $ - assertEvalError "fetchMercurial-call" "fetchMercurial {}" "unknown builtin 'fetchMercurial'", - runTest "pure evaluation leaves upstream's impure-only constants unbound" $ - assertEqual "pure-currentTime" (Left "undefined variable '__currentTime'") (evalNixWith purePolicy "if false then __currentTime else 1"), - runTest "pure evaluation binds the other globals" $ - assertEqual "pure-typeOf" (Right (VInt 1)) (evalNixWith purePolicy "if false then __typeOf else 1") - ] - --- | The same check for files: upstream binds each file as it parses it, so --- an import fails on an unbound variable the importing code never reaches, --- and @scopedImport@ binds its scope's names around the file. The inherit --- cases whose regression is a self-reference run here too. -testUndefinedVariablesIO :: IO [Bool] -testUndefinedVariablesIO = do - putStrLn "resolve/undefined-variables-io" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-undefined-variables" - branchFile = nixQuotedPath (testDir "branch.nix") - scopedFile = nixQuotedPath (testDir "scoped.nix") - scopedWithFile = nixQuotedPath (testDir "scoped-with.nix") - expectError label source expected = do - result <- evalNixIO testDir source - runTest label $ case result of - Left err -> assertEqual label expected err - Right val -> Fail (label <> ": expected an error, got " <> T.pack (show val)) - bracket_ - ( do - createDirectoryIfMissing True testDir - TIO.writeFile (testDir "branch.nix") "{ flag }:\nif flag then 1 else unboundName\n" - TIO.writeFile (testDir "scoped.nix") "if false then notInScope else fromScope\n" - TIO.writeFile (testDir "scoped-with.nix") "with { fromScope = \"with\"; }; fromScope\n" - ) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ expectError - "an import fails on an unbound variable on a branch not taken" - ("(import " <> branchFile <> ") { flag = true; }") - "undefined variable 'unboundName'", - expectError - "tryEval cannot catch an import that fails to bind" - ("builtins.tryEval (import " <> branchFile <> ")") - "undefined variable 'unboundName'", - runTestIO - "an import that is never forced does not fail" - testDir - ("let f = import " <> branchFile <> "; in 1") - (VInt 1), - expectError - "scopedImport binds against its scope" - ("builtins.scopedImport { fromScope = 7; } " <> scopedFile) - "undefined variable 'notInScope'", - runTestIO - "scopedImport scope names bind" - testDir - ("builtins.scopedImport { fromScope = 7; notInScope = 1; } " <> scopedFile) - (VInt 7), - runTestIO - "a scopedImport scope name is not shadowed by a with" - testDir - ("builtins.scopedImport { fromScope = 7; } " <> scopedWithFile) - (VInt 7), - -- Evaluated where a self-reference is caught as infinite recursion - -- rather than looping, which is what reading the inherited name - -- from the rec's own scope used to do. - runTestIO - "inherit in a dynamic-key rec reads the enclosing rec, not its own" - testDir - "rec { ${\"q\"} = 0; x = 1; y = rec { ${\"a\"} = 1; inherit x; }; }.y.x" - (VInt 1), - expectError - "inherit of a name no with supplies is undefined, not the rec's own" - "with {}; rec { ${\"a\"} = 1; inherit x; }.x" - "undefined variable 'x'" - ] - --- --------------------------------------------------------------------------- --- Main --- --------------------------------------------------------------------------- - --- --------------------------------------------------------------------------- --- Tests: byte-indexed string semantics (issue #34) --- --------------------------------------------------------------------------- - --- | The pinned byte-semantics suite: a Nix string is a byte string, so --- lengths, slices, regexes, and replaceStrings all index BYTES, and the --- hash of a value is the hash of exactly its bytes. Multibyte content --- enters through source literals here (the parser interns their UTF-8); --- arbitrary/invalid bytes enter via readFile in the IO group below. -testByteStringSemantics :: IO [Bool] -testByteStringSemantics = do - putStrLn "eval/byte-strings" - sequence - [ -- stringLength / substring index bytes - runTest "stringLength counts bytes" $ - assertEval "len-bytes" "builtins.stringLength \"\228\"" (VInt 2), - runTest "substring slices at byte offsets" $ - assertEval "substr-bytes" "builtins.stringLength (builtins.substring 0 1 \"\228\")" (VInt 1), - runTest "mid-codepoint slices reassemble byte-exactly" $ - assertEval - "substr-reassemble" - "builtins.substring 0 1 \"\228\" + builtins.substring 1 1 \"\228\" == \"\228\"" - (VBool True), - -- the hash sees exactly the value's bytes - runTest "hashString of a mid-codepoint slice is the raw byte's sha256" $ - assertEval - "hash-midbyte" - "builtins.hashString \"sha256\" (builtins.substring 0 1 \"\228\")" - (mkStr (Hash.bytesToHexText (sha256Digest (BS.take 1 (TE.encodeUtf8 "\228"))))), - runTest "hashString of valid UTF-8 is unchanged by the byte layer" $ - assertEval - "hash-utf8-stable" - "builtins.hashString \"sha256\" \"\228\"" - (mkStr (Hash.bytesToHexText (sha256Digest (TE.encodeUtf8 "\228")))), - -- regexes run over bytes ('.' matches ONE byte) - runTest "match . does not match a 2-byte char" $ - assertEval "match-one-byte" "builtins.match \".\" \"\228\"" VNull, - runTest "match .. matches a 2-byte char" $ - assertEval "match-two-bytes" "builtins.match \"..\" \"\228\" == []" (VBool True), - runTest "a multibyte pattern matches its own bytes" $ - assertEval "match-multibyte-pattern" "builtins.match \"\228\" \"\228\" == []" (VBool True), - -- replaceStrings with an empty 'from' steps one BYTE - runTest "replaceStrings empty-from inserts between bytes" $ - assertEval - "replace-empty-from" - "builtins.stringLength (builtins.replaceStrings [\"\"] [\"-\"] \"\228\")" - (VInt 5), - runTest "replaceStrings empty-from result is byte-exact" $ - assertEval - "replace-empty-from-bytes" - "builtins.replaceStrings [\"\"] [\"-\"] \"\228\" == \"-\" + builtins.substring 0 1 \"\228\" + \"-\" + builtins.substring 1 1 \"\228\" + \"-\"" - (VBool True), - -- strict-decode boundaries reject bytes that are not UTF-8 - runTest "toJSON rejects invalid UTF-8" $ - assertEvalFail "tojson-invalid" "builtins.toJSON (builtins.substring 0 1 \"\228\")", - runTest "getAttr rejects an invalid-UTF-8 attr name" $ - assertEvalFail "getattr-invalid" "builtins.getAttr (builtins.substring 0 1 \"\228\") {}", - -- toXML passes bytes through raw (upstream's serializer never validates) - runTest "toXML passes a mid-codepoint byte through" $ - assertEval - "toxml-bytes" - "builtins.stringLength (builtins.toXML (builtins.substring 0 1 \"\228\")) == builtins.stringLength (builtins.toXML \"x\")" - (VBool True), - -- a search-path miss is a CATCHABLE error (upstream ThrownError; - -- nixpkgs' impure.nix relies on tryEval catching it) - runTest "search-path miss is tryEval-catchable" $ - assertEval - "findFile-catchable" - "(builtins.tryEval (builtins.findFile builtins.nixPath \"nope-missing\")).success" - (VBool False) - ] - --- | readFile returns the file's RAW BYTES: BOMs survive, UTF-16 is not --- transcoded, invalid UTF-8 is representable, and only NUL is rejected. --- The expected hashes are computed from the fixture bytes themselves, so --- the assertions pin "hash of the value = hash of the file's bytes". -testByteStringSemanticsIO :: IO [Bool] -testByteStringSemanticsIO = do - putStrLn "eval/readfile-bytes-io" - tmpDir <- getTemporaryDirectory - let testDir = tmpDir "nova-nix-bytefile-test" - bomBytes = BS.pack [0xEF, 0xBB, 0xBF] <> "hi" - -- UTF-16LE BOM + U+0101 (both payload bytes nonzero, so no NUL): - -- raw passthrough is observable as 4 bytes instead of a decoded char. - utf16Bytes = BS.pack [0xFF, 0xFE, 0x01, 0x01] - -- UTF-16LE ASCII interleaves NUL bytes - upstream readFile REJECTS it. - utf16AsciiBytes = BS.pack [0xFF, 0xFE, 0x68, 0x00, 0x69, 0x00] - invalidBytes = "a" <> BS.singleton 0xFF <> "b" - nulBytes = "a" <> BS.singleton 0x00 <> "b" - bracket_ - ( do - createDirectoryIfMissing True testDir - BS.writeFile (testDir "bom.bin") bomBytes - BS.writeFile (testDir "utf16.bin") utf16Bytes - BS.writeFile (testDir "utf16-ascii.bin") utf16AsciiBytes - BS.writeFile (testDir "invalid.bin") invalidBytes - BS.writeFile (testDir "nul.bin") nulBytes - BS.writeFile (testDir "umlaut.bin") (TE.encodeUtf8 "\228") - ) - ( do - exists <- doesDirectoryExist testDir - when exists (removeDirectoryRecursive testDir) - ) - $ sequence - [ runTestIO - "readFile keeps a BOM (raw bytes)" - testDir - "builtins.stringLength (builtins.readFile ./bom.bin)" - (VInt 5), - runTestIO - "readFile does not transcode UTF-16" - testDir - "builtins.stringLength (builtins.readFile ./utf16.bin)" - (VInt 4), - runTestIOFail - "readFile rejects UTF-16 ASCII (its NUL bytes)" - testDir - "builtins.readFile ./utf16-ascii.bin", - runTestIO - "readFile passes invalid UTF-8 through" - testDir - "builtins.stringLength (builtins.readFile ./invalid.bin)" - (VInt 3), - runTestIO - "readFile bytes hash as read (BOM file)" - testDir - "builtins.hashString \"sha256\" (builtins.readFile ./bom.bin)" - (mkStr (Hash.bytesToHexText (sha256Digest bomBytes))), - runTestIO - "readFile bytes hash as read (UTF-16 file)" - testDir - "builtins.hashString \"sha256\" (builtins.readFile ./utf16.bin)" - (mkStr (Hash.bytesToHexText (sha256Digest utf16Bytes))), - runTestIO - "readFile of invalid UTF-8 hashes its raw bytes" - testDir - "builtins.hashString \"sha256\" (builtins.readFile ./invalid.bin)" - (mkStr (Hash.bytesToHexText (sha256Digest invalidBytes))), - runTestIO - "readFile round-trips a multibyte literal" - testDir - "builtins.readFile ./umlaut.bin == \"\228\"" - (VBool True), - runTestIOFail - "readFile rejects an embedded NUL" - testDir - "builtins.readFile ./nul.bin" - ] - -main :: IO () -main = - getArgs >>= \case - [flag, name] | flag == arenaGuardChildFlag -> arenaGuardChild name - [flag, source] | flag == evalChildFlag -> bracket_ arenaInit arenaDestroy (evalChild source) - _ -> withRunTempRoot (bracket_ arenaInit arenaDestroy runSuite) - --- | Give the run a temporary root of its own and point the process's --- temporary directory at it, so every fixture the suite derives from --- 'getTemporaryDirectory' (each under a fixed name) is this run's alone --- and two suites running at once cannot delete each other's (#254). --- @TMPDIR@ is what POSIX reads, @TMP@ and @TEMP@ what Windows' --- @GetTempPath@ reads; a child process inherits them. The root is named --- for this process, so no live run shares it, and one a crashed run left --- under the same PID is cleared first. -withRunTempRoot :: IO a -> IO a -withRunTempRoot action = do - base <- getTemporaryDirectory - pid <- Proc.getCurrentPid - let root = base ("nova-nix-test-" <> show pid) - Dir.removePathForcibly root - Dir.createDirectory root - mapM_ (`setEnv` root) ["TMPDIR", "TMP", "TEMP"] - action `finally` Dir.removePathForcibly root - --- | Every group, under the one arena bracket. -runSuite :: IO () -runSuite = do - hSetBuffering stdout LineBuffering - putStrLn "nova-nix test suite" - putStrLn "===================" - results <- - concat - <$> sequence - [ testExprTypes, - testStorePaths, - testDerivation, - testTrivialBuildIO, - testSourceDateEpochIO, - testScrubbedBuildEnvIO, - testUnpackBuildIO, - testDependentBuildIO, - testEvalFidelity, - testUpstreamConformance, - testHashHelpers, - testFetchMirrors, - testSubstituterRetry, - testPkgsFetchurl, - testNarKnownAnswer, - testFetchGitTransport, - testFetchGitShallow, - testFetchGitPins, - testPathInterp, - testOutPathCoercion, - testFetchCache, - testExecWrapper, - testAttrPath, - testScratchDirs, - testEvalLiterals, - testEvalVariables, - testEvalArithmetic, - testEvalComparison, - testEvalLogic, - testEvalStrings, - testEvalIfAssert, - testEvalLet, - testEvalAttrs, - testValuePrinter, - testCoercionErrors, - testResultPrinter, - testEvalRecAttrs, - testEvalLists, - testEvalLambda, - testEvalWith, - testEvalBuiltins, - testFromTOML, - testEvalErrors, - testListCoercion, - testEvalHigherOrder, - testLexer, - testParserExprs, - testParserErrors, - testParserIntegration, - testStaticGlobalsSync, - testUndefinedVariables, - testUndefinedVariablesIO, - testBatch1, - testBatch2, - testBatch3, - testBatch4, - testBatch5, - testBatch6, - testBatch7, - testImportPure, - testImportIO, - testBlackholeRecoveryIO, - testDerivationTraceIO, - testFirstArgumentOrderIO, - testStorePathLinksIO, - testDeepContextClosureIO, - testDerivationFields, - testDerivationPathFieldsIO, - testPathArguments, - testPathArgumentsIO, - testPathFilterIO, - testPathSymlinkIO, - testInterpolatedSymlinkIO, - testSourceErrorMessage, - testSourceReadErrorsIO, - testBatchA, - testBatchAIO, - testEnvironmentBytes, - testBatchB, - testBatchC, - testBatchCIO, - testBlackhole, - testCallDepth, - testBatchD, - testBatchE, - testBatchEIO, - testBatchF, - testBatchG, - testBatchH, - testStringContext, - testContextHelpers, - testContextPropagation, - testDrvContext, - testStructuredAttrs, - testDepGraph, - testSubstituter, - testCaseSensitiveVolumeIO, - testFoldingVolumeIO, - testPathLocks, - testExecBit, - testVerifySigs, - testNarInfoValidation, - testNixConfig, - testPushPure, - testPushClosureIO, - testBuildOrchestrator, - testStoreDB, - testParseStorePath, - testStoreOps, - testStoreDelete, - testGcPure, - testStoreGC, - testSymlinkWalksIO, - testLinkOrdering, - testFromATerm, - testBuilder, - testE2E, - testExecWrapperCLI, - testPhase4, - testPhase4IO, - testToJSONPathIO, - testByteStringSemantics, - testByteStringSemanticsIO, - testSymbol, - testCAttrSet, - testCThunk, - testArenaGuard, - testBytecodeCompile, - testBytecodeCountSpill, - testBytecodePerElement, - testValueCountWidths, - testStoreNameSinks, - testNarNameSafety, - testStoreNameSinksIO, - testClassIFollowups, - testClassIFollowupsIO, - testAbsolutePathStrings, - testEvalPolicyRules, - testEvalPolicyIO, - testEvalPolicyCLI, - testResultPrinterCLI, - testConfigBytesCLI, - testInterruptsPropagate - ] - let total = length results - passed = length (filter id results) - failed = total - passed - putStrLn $ "\n" ++ show passed ++ "/" ++ show total ++ " passed" - if failed > 0 - then do - putStrLn $ show failed ++ " FAILED" - exitFailure - else do - putStrLn "All tests passed." - exitSuccess - --- --------------------------------------------------------------------------- --- Tests: evaluation policy - restricted and pure modes (#75) --- --------------------------------------------------------------------------- - --- | A string naming a relative path is refused wherever a path is coerced --- from a string, as upstream's coerceToPath refuses it ("string '%s' --- doesn't represent an absolute path", observed from nix-instantiate --- 2.33.2 in every mode). Load bearing for the access policy: a relative --- string would be checked against one location and opened at another. -testAbsolutePathStrings :: IO [Bool] -testAbsolutePathStrings = do - putStrLn "eval/absolute-path-strings" - tmpBase <- getTemporaryDirectory - let testDir = tmpBase "nova-nix-test-abs-strings" - relativeRefused label source = - runTestM label $ do - result <- evalNixIO testDir source - pure $ case result of - Left err - | "string 'foo' doesn't represent an absolute path" `T.isInfixOf` err -> Pass - | otherwise -> Fail ("expected the absolute-path refusal, got: " <> err) - Right val -> Fail ("expected a refusal, got: " <> T.pack (show val)) - bracket_ - (createDirectoryIfMissing True testDir >> BS.writeFile (testDir "foo") "1\n") - (forceRemoveIfExists testDir) - $ sequence - [ relativeRefused "readFile of a relative string" "builtins.readFile \"foo\"", - relativeRefused "import of a relative string" "import \"foo\"", - relativeRefused "pathExists of a relative string is an error, not false" "builtins.pathExists \"foo\"", - relativeRefused "readDir of a relative string" "builtins.readDir \"foo\"", - relativeRefused "readFileType of a relative string" "builtins.readFileType \"foo\"", - relativeRefused "hashFile of a relative string" "builtins.hashFile \"sha256\" \"foo\"", - relativeRefused "scopedImport of a relative string" "builtins.scopedImport { } \"foo\"", - -- The search-path miss carries upstream's hint, byte for byte. - runTest "a search path miss names the hint" $ - assertEqual - "miss" - (Left "file 'nope' was not found in the Nix search path (add it using $NIX_PATH or -I)") - (evalNix "") - ] - --- | The policies under test. -restrictedPolicy, purePolicy :: EvalPolicy -restrictedPolicy = unrestrictedPolicy {epRestrictEval = True} -purePolicy = unrestrictedPolicy {epPureEval = True} - --- | Parse and evaluate in 'PureEval' with the given policy's builtins --- table, for the constants the table itself decides. -evalNixWith :: EvalPolicy -> Text -> Either Text NixValue -evalNixWith policy source = case parseNixWithScope (rootScopeNames policy) testBaseDir "" source of - Left err -> Left (sourceFailure err) - Right expr -> runPureEval (eval (builtinEnv policy 0 []) expr) - --- | The pure rules behind the modes, each pinned to upstream's code at --- 2.24.9: CanonPath::isAllowed over the allow list, isAllowedURI and --- checkURI over allowed-uris, the git input's URL form, the nix.conf --- settings, and the builtins table under pure-eval. -testEvalPolicyRules :: IO [Bool] -testEvalPolicyRules = do - putStrLn "eval/policy-rules" - let oneRoot = allowPathIn "/a/b" noAllowedPaths - twoRoots = allowPathIn "/x" oneRoot - driveRoot = allowPathIn "C:/a/b" noAllowedPaths - github = ["https://github.com/NixOS"] - -- Successive nix.conf texts, weakest first, served to the expander - -- as files. - config texts = - let paths = [asciiOsPath ("/policy/" ++ show index ++ ".conf") | index <- [1 .. length texts]] - files = Map.fromList (zip paths texts) - readFrom path = Identity (maybe (Left Config.ConfigFileMissing) Right (Map.lookup path files)) - in runIdentity (Config.loadConfig readFrom paths Nothing) - cfgPure = fmap ncPureEval . config - cfgRestrict = fmap ncRestrictEval . config - cfgUris = fmap ncAllowedUris . config - sequence - [ -- CanonPath::isAllowed - runTest "an allowed prefix admits itself" $ - assertEqual "self" True (isAllowedPath oneRoot "/a/b"), - runTest "an allowed prefix admits what lies within it" $ - assertEqual "within" True (isAllowedPath oneRoot "/a/b/c/d"), - runTest "an allowed prefix admits its ancestors" $ - assertEqual "ancestor" True (isAllowedPath oneRoot "/a") `andThen` assertEqual "root" True (isAllowedPath oneRoot "/"), - runTest "a sibling sharing a text prefix is not within" $ - assertEqual "sibling" False (isAllowedPath oneRoot "/a/bc"), - runTest "a path beside the prefix is refused" $ - assertEqual "beside" False (isAllowedPath oneRoot "/a/c") `andThen` assertEqual "elsewhere" False (isAllowedPath twoRoots "/y"), - runTest "nothing allowed admits nothing, the root included" $ - assertEqual "empty" False (isAllowedPath noAllowedPaths "/") `andThen` assertEqual "empty-etc" False (isAllowedPath noAllowedPaths "/etc"), - runTest "the spelling of an allowed prefix is canonicalized" $ - assertEqual "canon" True (isAllowedPath (allowPathIn "/a//b/./" noAllowedPaths) "/a/b/c"), - -- The rules are platform-independent, so a Windows path value - -- (C:/..., the drive designator its first component) is decided - -- the same on every host. - runTest "a drive designator is the first component" $ - assertEqual "within" True (isAllowedPath driveRoot "C:/a/b/c") - `andThen` assertEqual "self" True (isAllowedPath driveRoot "C:/a/b") - `andThen` assertEqual "drive-root" True (isAllowedPath driveRoot "C:/") - `andThen` assertEqual "beside" False (isAllowedPath driveRoot "C:/a/c") - `andThen` assertEqual "sibling" False (isAllowedPath driveRoot "C:/a/bc") - `andThen` assertEqual "other-drive" False (isAllowedPath driveRoot "D:/a/b/c") - `andThen` assertEqual "rootless" False (isAllowedPath driveRoot "/a/b/c") - `andThen` assertEqual "first" "C:/" (joinComponents (take 1 (pathComponents "C:/a/b"))) - `andThen` assertEqual "first-posix" "/a" (joinComponents (take 1 (pathComponents "/a/b"))), - -- isAllowedURI - runTest "a URI equal to a prefix is allowed" $ - assertEqual "equal" True (isAllowedUri github "https://github.com/NixOS"), - runTest "a URI under a prefix at a slash boundary is allowed" $ - assertEqual "subpath" True (isAllowedUri github "https://github.com/NixOS/patchelf.git"), - runTest "a prefix does not admit a longer name" $ - assertEqual "github.co" False (isAllowedUri ["https://github.co"] "https://github.com") - `andThen` assertEqual "NixOSx" False (isAllowedUri github "https://github.com/NixOSx"), - runTest "a prefix ending in a slash admits below it but not itself" $ - assertEqual "below" True (isAllowedUri ["https://a/dir/"] "https://a/dir/x") - `andThen` assertEqual "itself" False (isAllowedUri ["https://a/dir/"] "https://a/dir"), - runTest "a bare scheme prefix admits its whole scheme" $ - assertEqual "https:" True (isAllowedUri ["https:"] "https://anything/at/all") - `andThen` assertEqual "git+file:" True (isAllowedUri ["git+file:"] "git+file:///repo?exportIgnore=1") - `andThen` assertEqual "http:" False (isAllowedUri ["https:"] "http://x"), - -- checkURI - runTest "nothing is checked unless restrict-eval is on" $ - assertEqual "off" (Right ()) (uriAccess purePolicy noAllowedPaths "https://x"), - runTest "a URI outside the list is refused with upstream's wording" $ - assertEqual "refused" (Left "access to URI 'https://x/y' is forbidden in restricted mode") (uriAccess restrictedPolicy noAllowedPaths "https://x/y"), - runTest "a path URI is checked against the allowed paths" $ - assertEqual "allowed" (Right ()) (uriAccess restrictedPolicy oneRoot "/a/b/f") - `andThen` assertEqual "refused" (Left "access to absolute path '/etc/passwd' is forbidden in restricted mode") (uriAccess restrictedPolicy oneRoot "/etc/passwd"), - runTest "a file URL is checked as its path, rooted" $ - assertEqual "allowed" (Right ()) (uriAccess restrictedPolicy oneRoot "file:///a/b/f") - `andThen` assertEqual "rooted" (Left "access to absolute path '/etc/passwd' is forbidden in restricted mode") (uriAccess restrictedPolicy oneRoot "file://etc/passwd"), - runTest "a file URL with a drive is checked as that drive's path" $ - assertEqual "allowed" (Right ()) (uriAccess restrictedPolicy driveRoot "file://C:/a/b/f") - `andThen` assertEqual "refused" (Left "access to absolute path 'C:/a/c' is forbidden in restricted mode") (uriAccess restrictedPolicy driveRoot "file://C:/a/c"), - runTest "the path refusal names pure mode when it is on" $ - assertEqual "pure" "access to absolute path '/etc' is forbidden in pure evaluation mode (use '--impure' to override)" (forbiddenPathMessage purePolicy "/etc") - `andThen` assertEqual "both" "access to absolute path '/etc' is forbidden in pure evaluation mode (use '--impure' to override)" (forbiddenPathMessage purePolicy {epRestrictEval = True} "/etc"), - -- Input::toURLString for a git input (strings observed from - -- nix-instantiate 2.33.2, whose renderer is 2.24.9's) - runTest "an https url renders with git+ and exportIgnore" $ - assertEqual "https" "git+https://github.com/NixOS/patchelf.git?exportIgnore=1" (gitInputUrl (gitInput "https://github.com/NixOS/patchelf.git")), - runTest "a ref follows exportIgnore in key order" $ - assertEqual "ref" "git+https://github.com/NixOS/patchelf.git?exportIgnore=1&ref=master" (gitInputUrl (gitInput "https://github.com/NixOS/patchelf.git") {fgaRef = Just "master"}), - runTest "a rev renders lowercase after ref" $ - assertEqual "rev" "git+https://h/r?exportIgnore=1&ref=main&rev=aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" (gitInputUrl (gitInput "https://h/r") {fgaRef = Just "main", fgaRev = Just "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"}), - runTest "shallow renders as a flag" $ - assertEqual "shallow" "git+ssh://git@github.com/NixOS/patchelf.git?exportIgnore=1&shallow=1" (gitInputUrl (gitInput "ssh://git@github.com/NixOS/patchelf.git") {fgaShallow = True}), - runTest "submodules replaces exportIgnore" $ - assertEqual "submodules" "git+https://h/r?submodules=1" (gitInputUrl (gitInput "https://h/r") {fgaSubmodules = True}), - runTest "a bare path becomes a file URL" $ - assertEqual "path" "git+file:///p/repo?exportIgnore=1" (gitInputUrl (gitInput "/p/repo")), - runTest "an scp-like remote becomes ssh" $ - assertEqual "scp" "git+ssh://git@github.com/NixOS/patchelf.git?exportIgnore=1" (gitInputUrl (gitInput "git@github.com:NixOS/patchelf.git")), - runTest "the git scheme keeps its name" $ - assertEqual "git" "git://h/r?exportIgnore=1" (gitInputUrl (gitInput "git://h/r")), - runTest "a path is percent-encoded as upstream encodes it" $ - assertEqual "space" "git+file:///p/my%20repo?exportIgnore=1" (gitInputUrl (gitInput "/p/my repo")), - -- nix.conf - runTest "pure-eval and restrict-eval parse upstream's Boolean spellings" $ - assertEqual "true" (Right True) (cfgPure ["pure-eval = true"]) - `andThen` assertEqual "yes" (Right True) (cfgPure ["pure-eval = yes"]) - `andThen` assertEqual "1" (Right True) (cfgRestrict ["restrict-eval = 1"]) - `andThen` assertEqual "false" (Right False) (cfgPure ["pure-eval = true", "pure-eval = false"]) - `andThen` assertEqual "no" (Right False) (cfgRestrict ["restrict-eval = no"]) - `andThen` assertEqual "0" (Right False) (cfgRestrict ["restrict-eval = 0"]), - runTest "a misspelled Boolean is an error with upstream's wording" $ - assertEqual "typo" (Left "Boolean setting 'pure-eval' has invalid value 'ture'") (cfgPure ["pure-eval = ture"]), - runTest "allowed-uris is a list and extra- appends to it" $ - assertEqual "uris" (Right ["https://a", "https://b", "https://c"]) (cfgUris ["allowed-uris = https://a https://b", "extra-allowed-uris = https://c"]), - runTest "extra- on a Boolean names no setting and is ignored" $ - assertEqual "extra-bool" (Right False) (cfgPure ["extra-pure-eval = true"]), - runTest "the default config has both modes off" $ - assertEqual "defaults" (Right (False, False, [])) ((\c -> (ncRestrictEval c, ncPureEval c, ncAllowedUris c)) <$> config []), - -- the builtins table - runTest "currentTime and currentSystem are absent under pure-eval" $ - assertEqual "time" (Right (VBool False)) (evalNixWith purePolicy "builtins ? currentTime") - `andThen` assertEqual "system" (Right (VBool False)) (evalNixWith purePolicy "builtins ? currentSystem") - `andThen` assertEqual "time-restricted" (Right (VBool True)) (evalNixWith restrictedPolicy "builtins ? currentTime") - `andThen` assertEqual "time-default" (Right (VBool True)) (evalNixWith unrestrictedPolicy "builtins ? currentSystem") - ] - where - gitInput url = - FetchGitArgs - { fgaUrl = url, - fgaName = "source", - fgaRef = Nothing, - fgaRev = Nothing, - fgaSubmodules = False, - fgaShallow = False, - fgaAllRefs = False, - fgaNarHash = Nothing - } - --- | 'evalNixIO' under a policy: the roots are allowed first, and the --- search path is what the caller passes, as the CLI would pass it. -evalPolicyIO :: EvalPolicy -> [Text] -> [Thunk] -> FilePath -> Text -> IO (Either Text NixValue) -evalPolicyIO policy roots searchPaths baseDir source = do - storeDir <- evalNixIOStoreDir - case parseNixWithScope (rootScopeNames policy) baseDir "" source of - Left err -> pure (Left (T.pack (show err))) - Right expr -> do - st0 <- newEvalState storeDir baseDir - let st = st0 {esPolicy = policy, esSearchPaths = searchPaths} - mapM_ (allowEvalPath st) roots - runEvalIO st (eval (builtinEnv policy (esTimestamp st) searchPaths) expr) - --- | The battery the modes were pinned against, run through EvalIO: every --- expression here was run through nix-instantiate under restrict-eval and --- pure-eval, and the expected text is what upstream printed, except where --- the oracle version (2.24.9) differs from the installed 2.33.2 and the --- oracle's source wins (which prefix a refusal names, the fetchGit --- wording). The fixture lives at a symlink-free root: a root behind a --- symlinked directory is refused by upstream too, since its allow list --- holds the spelling given and the walk resolves the link. -testEvalPolicyIO :: IO [Bool] -testEvalPolicyIO = do - putStrLn "eval/policy-io" - tmpBase <- getTemporaryDirectory >>= Dir.canonicalizePath - links <- symlinksAvailable - let root = tmpBase "nova-nix-test-policy" - allowed = root "allowed" - outside = root "outside" - repo = allowed "repo" - pathText = canonPathValue . T.pack - forbidden policy p = "access to absolute path '" <> pathText p <> "' is forbidden " <> modeText policy - modeText policy - | epPureEval policy = "in pure evaluation mode (use '--impure' to override)" - | otherwise = "in restricted mode" - -- The first prefix the walk pushes: /tmp on Linux, /private on - -- macOS, the drive root C:/ on Windows. - firstComponent = joinComponents (take 1 (pathComponents (pathText allowed))) - -- A fixture path as a path literal, relative to the base directory - -- (allowed): the one spelling that lexes as a path on every - -- platform, since a drive-letter path (C:/...) is a URI token to - -- upstream's lexer and to this one. - lit p = "../" <> pathText (makeRelative root p) - quoted p = "\"" <> pathText p <> "\"" - run policy roots = evalPolicyIO policy roots [] allowed - restricted = run restrictedPolicy [pathText allowed] - pureRun = run purePolicy [pathText allowed] - withUris uris = run restrictedPolicy {epAllowedUris = uris} [pathText allowed] - expectLeft label expected action = - runTestM label $ do - result <- action - pure $ case result of - Left err -> assertEqual label expected err - Right val -> Fail (label <> ": expected a refusal, got " <> T.pack (show val)) - expectRight label expected action = - runTestM label $ assertRight label <$> action <*> pure (assertEqual label expected) - expectRightWith label check action = - runTestM label $ (\r -> assertRight label r check) <$> action - repoUrl = "git+file://" <> pathText repo <> "?exportIgnore=1" - unrestricted = run unrestrictedPolicy [] - symlinkMessage p = "path '" <> pathText p <> "' is a symlink" - -- A case that needs a symlink on disk, or the record of why it did - -- not run. - linked label mk = if links then mk label else runTest (label <> " (skipped: no symlinks here)") Pass - bracket_ - ( do - forceRemoveIfExists root - createDirectoryIfMissing True (allowed "sub") - createDirectoryIfMissing True outside - BS.writeFile (allowed "data.txt") "hello\n" - BS.writeFile (allowed "sub" "data.txt") "inner\n" - BS.writeFile (allowed "y.nix") "7\n" - BS.writeFile (outside "x.nix") "42\n" - BS.writeFile (outside "secret.txt") "secret\n" - when links $ do - Dir.createFileLink (outside "secret.txt") (allowed "link") - Dir.createDirectoryLink outside (allowed "dirlink") - Dir.createFileLink "nowhere" (allowed "dangling") - createDirectoryIfMissing True (allowed "dir") - Dir.createFileLink (outside "x.nix") (allowed "dir" "default.nix") - createDirectoryIfMissing True repo - _ <- fixtureGit repo ["init", "--quiet"] - BS.writeFile (repo "f.txt") "in repo\n" - _ <- fixtureGit repo ["add", "-A"] - _ <- fixtureGit repo ["commit", "--quiet", "-m", "init"] - pure () - ) - (forceRemoveIfExists root) - $ do - rev <- T.strip <$> fixtureGit repo ["rev-parse", "HEAD"] - -- The fetch cache writes under XdgCache; point it at the fixture for - -- the duration so the suite never touches the developer's cache. - savedCacheHome <- lookupEnv "XDG_CACHE_HOME" - setEnv "XDG_CACHE_HOME" (root "cache") - results <- - sequence - [ -- restricted: the allow list - expectRight "a file under an allowed root reads" (mkStr "hello\n") (restricted ("builtins.readFile " <> lit (allowed "data.txt"))), - expectRight "a file deeper under an allowed root reads" (mkStr "inner\n") (restricted ("builtins.readFile " <> lit (allowed "sub" "data.txt"))), - expectLeft "a file beside the allowed root is refused, naming the first prefix outside the list" (forbidden restrictedPolicy outside) (restricted ("builtins.readFile " <> lit (outside "secret.txt"))), - expectLeft "with nothing allowed the refusal names the first component" (forbidden restrictedPolicy (T.unpack firstComponent)) (run restrictedPolicy [] ("builtins.readFile " <> lit (allowed "data.txt"))), - expectLeft "a string spelling the path is refused the same way" (forbidden restrictedPolicy outside) (restricted ("builtins.readFile " <> quoted (outside "secret.txt"))), - expectRight "import under the root works" (VInt 7) (restricted ("import " <> lit (allowed "y.nix"))), - expectLeft "import beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("import " <> lit (outside "x.nix"))), - expectRight "pathExists is true under the root" (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "data.txt"))), - expectRight "pathExists is false beside it, not an error" (VBool False) (restricted ("builtins.pathExists " <> lit (outside "secret.txt"))), - expectRightWith "readDir under the root lists" (\case VAttrs attrs -> assertEqual "entries" True (attrSetSize attrs == 1); other -> Fail (T.pack (show other))) (restricted ("builtins.readDir " <> lit (allowed "sub"))), - expectLeft "readDir beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("builtins.readDir " <> lit outside)), - expectLeft "readFileType names the path asked for, no walk" (forbidden restrictedPolicy (outside "secret.txt")) (restricted ("builtins.readFileType " <> lit (outside "secret.txt"))), - expectLeft "hashFile walks like readFile" (forbidden restrictedPolicy outside) (restricted ("builtins.hashFile \"sha256\" " <> lit (outside "secret.txt"))), - expectRight "getEnv answers empty" (mkStr "") (restricted "builtins.getEnv \"PATH\""), - expectRight "a toFile result is readable afterwards" (mkStr "y") (restricted "builtins.readFile (builtins.toFile \"x\" \"y\")"), - expectRightWith "a source copy under the root is allowed" (\case VStr s _ -> assertEqual "store" True (BS.isPrefixOf "/nix/store/" s); other -> Fail (T.pack (show other))) (restricted "\"${./data.txt}\""), - expectLeft "a source copy beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("\"${" <> lit (outside "secret.txt") <> "}\"")), - expectLeft "builtins.path beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("builtins.path { path = " <> lit (outside "secret.txt") <> "; }")), - expectLeft "filterSource beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("builtins.filterSource (p: t: true) " <> lit outside)), - expectLeft "tryEval does not catch a refusal" (forbidden restrictedPolicy outside) (restricted ("builtins.tryEval (builtins.readFile " <> lit (outside "secret.txt") <> ")")), - linked "a symlink under the root pointing outside is refused at its target" (\label -> expectLeft label (forbidden restrictedPolicy outside) (restricted ("builtins.readFile " <> lit (allowed "link")))), - linked "a directory import whose default.nix is a symlink outside the root is refused at the link's target" (\label -> expectLeft label (forbidden restrictedPolicy outside) (restricted ("import " <> lit (allowed "dir")))), - linked "scopedImport of that directory is refused the same way" (\label -> expectLeft label (forbidden restrictedPolicy outside) (restricted ("builtins.scopedImport {} " <> lit (allowed "dir")))), - linked "pathExists checks a symlink to a forbidden file in place: true" (\label -> expectRight label (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "link")))), - linked "pathExists checks a symlink to a forbidden directory in place: true" (\label -> expectRight label (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "dirlink")))), - linked "pathExists of a dangling symlink is true" (\label -> expectRight label (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "dangling")))), - linked "pathExists through a symlinked directory follows the ancestor, which is refused: false" (\label -> expectRight label (VBool False) (restricted ("builtins.pathExists " <> lit (allowed "dirlink" "secret.txt")))), - linked "pathExists with a trailing slash follows the final link, which is refused: false" (\label -> expectRight label (VBool False) (restricted ("builtins.pathExists \"" <> pathText (allowed "dirlink") <> "/\""))), - linked "readFileType through a symlinked directory is refused at the symlink" (\label -> expectLeft label (symlinkMessage (allowed "dirlink")) (restricted ("builtins.readFileType " <> lit (allowed "dirlink" "secret.txt")))), - linked "readFileType through a symlinked directory is refused in the default mode too" (\label -> expectLeft label (symlinkMessage (allowed "dirlink")) (unrestricted ("builtins.readFileType " <> lit (allowed "dirlink" "secret.txt")))), - linked "pathExists of a dangling symlink is true in the default mode too" (\label -> expectRight label (VBool True) (unrestricted ("builtins.pathExists " <> lit (allowed "dangling")))), - linked "builtins.path resolves a symlink root and stores its target" (\label -> expectRight label (mkStr "directory") (unrestricted ("builtins.readFileType (builtins.path { path = " <> lit (allowed "dirlink") <> "; })"))), - linked "filterSource resolves a symlink root and stores its target" (\label -> expectRight label (mkStr "directory") (unrestricted ("builtins.readFileType (builtins.filterSource (p: t: true) " <> lit (allowed "dirlink") <> ")"))), - expectRight "pathExists with a trailing slash on a file is false" (VBool False) (unrestricted ("builtins.pathExists \"" <> pathText (allowed "data.txt") <> "/\"")), - expectRight "pathExists with a trailing slash on a directory is true" (VBool True) (unrestricted ("builtins.pathExists \"" <> pathText (allowed "sub") <> "/\"")), - expectRight "pathExists with a trailing slash and dot on a directory is true" (VBool True) (unrestricted ("builtins.pathExists \"" <> pathText (allowed "sub") <> "/.\"")), - -- restricted: URIs - expectLeft "a fetch of an unlisted URI is refused before any download" "access to URI 'https://example.invalid/x' is forbidden in restricted mode" (restricted "builtins.fetchurl \"https://example.invalid/x\""), - expectLeft "a file URL beside the root is refused as its path" (forbidden restrictedPolicy (outside "secret.txt")) (restricted ("builtins.fetchurl \"file://" <> pathText (outside "secret.txt") <> "\"")), - expectRightWith "a file URL under the root fetches" (\case VPath p -> assertEqual "store" True (T.isPrefixOf "/nix/store/" p); other -> Fail (T.pack (show other))) (restricted ("builtins.fetchurl { url = \"file://" <> pathText (allowed "data.txt") <> "\"; sha256 = \"5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03\"; }")), - expectLeft "fetchTarball of an unlisted URI is refused" "access to URI 'https://example.invalid/x.tar.gz' is forbidden in restricted mode" (restricted "builtins.fetchTarball \"https://example.invalid/x.tar.gz\""), - expectLeft "an allowed-uris prefix admits only its subpaths" "access to URI 'https://example.invalid/dir2/x' is forbidden in restricted mode" (withUris ["https://example.invalid/dir"] "builtins.fetchurl { url = \"https://example.invalid/dir2/x\"; sha256 = \"5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03\"; }"), - runTestM "an allowed-uris prefix lets the fetch proceed to the network" $ do - result <- withUris ["https://example.invalid/dir"] "builtins.fetchurl { url = \"https://example.invalid/dir/x\"; sha256 = \"5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03\"; }" - pure $ case result of - Left err | "is forbidden" `T.isInfixOf` err -> Fail ("the gate refused an allowed URI: " <> err) - _ -> Pass, - expectLeft "fetchGit of an allowed path is still a URI, checked in its git+file form" ("access to URI '" <> repoUrl <> "' is forbidden in restricted mode") (restricted ("builtins.fetchGit " <> quoted repo)), - expectRight "an allowed git+file prefix admits the fetch and its tree is readable afterwards" (mkStr "in repo\n") (withUris ["git+file://" <> pathText allowed] ("builtins.readFile ((builtins.fetchGit " <> quoted repo <> ").outPath + \"/f.txt\")")), - -- restricted: the search path - expectRight "a search path root is where resolves and reads" (VInt 7) (evalPolicyIO restrictedPolicy [pathText allowed] (parseNixPath (TE.encodeUtf8 ("allowed=" <> pathText allowed))) allowed "import "), - expectLeft "a search path miss carries the NIX_PATH hint and is catchable" "file 'nope' was not found in the Nix search path (add it using $NIX_PATH or -I)" (restricted ""), - expectRight "tryEval catches the miss" (VBool False) (restricted "(builtins.tryEval ).success"), - -- pure - expectLeft "pure mode refuses with its own clause" (forbidden purePolicy outside) (pureRun ("builtins.readFile " <> lit (outside "secret.txt"))), - expectRight "pure mode still reads under an allowed root" (mkStr "hello\n") (pureRun ("builtins.readFile " <> lit (allowed "data.txt"))), - expectRight "pure mode has no currentTime" (VBool False) (pureRun "builtins ? currentTime"), - expectLeft "pure mode words the search path miss differently" "cannot look up '' in pure evaluation mode (use '--impure' to override)" (pureRun ""), - expectRight "the pure miss is catchable too" (VBool False) (pureRun "(builtins.tryEval ).success"), - expectLeft "storePath is refused in pure mode before its argument is read" "'builtins.storePath' is not allowed in pure evaluation mode" (pureRun "builtins.storePath 42"), - expectLeft "fetchurl needs a hash in pure mode, checked before any download" "in pure evaluation mode, 'fetchurl' requires a 'sha256' argument" (pureRun "builtins.fetchurl \"https://example.invalid/x\""), - expectLeft "fetchTarball needs a hash in pure mode" "in pure evaluation mode, 'fetchTarball' requires a 'sha256' argument" (pureRun "builtins.fetchTarball \"https://example.invalid/x.tar.gz\""), - expectLeft "fetchGit without a rev is unlocked in pure mode" ("in pure evaluation mode, 'fetchGit' will not fetch unlocked input '" <> repoUrl <> "'") (pureRun ("builtins.fetchGit " <> quoted repo)), - expectRight "fetchGit with a rev is locked and fetches in pure mode" (mkStr "in repo\n") (pureRun ("builtins.readFile ((builtins.fetchGit { url = " <> quoted repo <> "; rev = \"" <> rev <> "\"; }).outPath + \"/f.txt\")")), - expectLeft "a home-relative literal cannot resolve in pure mode" "the path '~/x' can not be resolved in pure mode" (pureRun "~/x"), - expectRight "pure mode's getEnv answers empty" (mkStr "") (pureRun "builtins.getEnv \"PATH\""), - expectRight "a path literal is a value, read or not" (mkStr (pathText (outside "secret.txt"))) (pureRun ("builtins.toString " <> lit (outside "secret.txt"))), - -- unrestricted stays unrestricted - expectRight "the default policy reads anywhere" (mkStr "secret\n") (run unrestrictedPolicy [] ("builtins.readFile " <> lit (outside "secret.txt"))) - ] - maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome - pure results - --- | The flags and settings through the binary: the modes select --- themselves from the command line and from NIX_CONFIG, and a refusal --- surfaces as the eval error it is. -testEvalPolicyCLI :: IO [Bool] -testEvalPolicyCLI = do - putStrLn "cli/eval-policy" - tmpBase <- getTemporaryDirectory >>= Dir.canonicalizePath - ambient <- getEnvironment - cwd <- Dir.getCurrentDirectory - let root = tmpBase "nova-nix-test-cli-policy" - -- Where a channel: entry would land if it were taken for a path. - cwdChannelEntry = T.unpack (canonPathValue (T.pack (cwd "channel:nova-probe"))) - allowed = root "allowed" - -- A string, since a drive-letter path (C:/...) is a URI token and - -- a native spelling (C:\...) is no token at all; an absolute - -- string is coerced to a path on every platform. - outsideFile = T.unpack (canonPathValue (T.pack (root "outside.txt"))) - isolate extraConfig = - ("NIX_CONFIG", "substituters =\ntrusted-public-keys =\n" <> extraConfig) - : ("XDG_CONFIG_HOME", root "config") - : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME", "NIX_PATH"]) ambient - runCLI extraConfig args = - Proc.readCreateProcessWithExitCode - ((Proc.proc "cabal" (["run", "-v0", "nova-nix", "--"] ++ args)) {Proc.env = Just (isolate extraConfig)}) - "" - expectOut label extraConfig args expected = - runTestM ("CLI " <> label) $ do - (code, out, err) <- runCLI extraConfig args - pure $ case (code, lines out) of - (ExitSuccess, line : _) -> assertEqual label expected line - _ -> Fail ("CLI: " <> T.pack (show code) <> "; stdout=" <> T.pack out <> "; stderr=" <> T.pack err) - expectErr label extraConfig args needle = - runTestM ("CLI " <> label) $ do - (code, _, err) <- runCLI extraConfig args - pure $ - if code /= ExitSuccess && needle `T.isInfixOf` T.pack err - then Pass - else Fail ("expected a failure mentioning " <> needle <> ", got " <> T.pack (show (code, err))) - bracket_ - ( do - forceRemoveIfExists root - createDirectoryIfMissing True allowed - BS.writeFile (allowed "data.txt") "hello\n" - BS.writeFile (root "outside.txt") "no\n" - ) - (forceRemoveIfExists root) - $ sequence - [ expectOut "--pure-eval hides currentTime" "" ["eval", "--pure-eval", "--expr", "builtins ? currentTime"] "false", - expectOut "--restrict-eval empties getEnv" "" ["eval", "--restrict-eval", "--expr", "builtins.getEnv \"HOME\""] "\"\"", - expectOut "pure-eval from NIX_CONFIG" "pure-eval = true\n" ["eval", "--expr", "builtins ? currentSystem"] "false", - expectOut "a --nix-path root is readable under --restrict-eval" "" ["eval", "--restrict-eval", "--nix-path", "allowed=" ++ allowed, "--expr", "builtins.readFile "] "\"hello\\n\"", - expectErr "a read outside the roots fails the command" "" ["eval", "--restrict-eval", "--expr", "builtins.readFile \"" ++ outsideFile ++ "\""] "is forbidden in restricted mode", - expectErr "a channel: search path entry allows nothing" "" ["eval", "--restrict-eval", "--nix-path", "nixpkgs=channel:nova-probe", "--expr", "builtins.readFile \"" ++ cwdChannelEntry ++ "\""] "is forbidden in restricted mode", - expectOut "build accepts the flag before its target" "" ["build", "--pure-eval", "--help"] "Usage: nova-nix [--nix-path NAME=PATH] " - ] - --- | The eval result through the binary: stdout carries the printer's bytes --- and a bare newline, with no text encoding or newline translation between. -testResultPrinterCLI :: IO [Bool] -testResultPrinterCLI = do - putStrLn "cli/eval-result" - tmpBase <- getTemporaryDirectory - ambient <- getEnvironment - let root = tmpBase "nova-nix-test-cli-result" - file = root "latin1" - notUtf8 = "a" <> BS.singleton 0xfc <> "b" - -- A string, as in testEvalPolicyCLI: a drive-letter path is no - -- path literal. - fileString = T.unpack (canonPathValue (T.pack file)) - isolated = - ("XDG_CONFIG_HOME", root "config") - : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME"]) ambient - evalProcess = - (Proc.proc "cabal" ["run", "-v0", "nova-nix", "--", "eval", "--expr", "builtins.readFile \"" ++ fileString ++ "\""]) - { Proc.env = Just isolated, - Proc.std_out = Proc.CreatePipe - } - bracket_ - (forceRemoveIfExists root >> createDirectoryIfMissing True root >> BS.writeFile file notUtf8) - (forceRemoveIfExists root) - $ sequence - [ runTestM "CLI eval writes a string's bytes and a bare newline" $ - Proc.withCreateProcess evalProcess $ \_ stdoutPipe _ process -> case stdoutPipe of - Nothing -> pure (Fail "no stdout pipe") - Just out -> do - printed <- BS.hGetContents out - code <- Proc.waitForProcess process - pure $ case code of - ExitSuccess -> assertEqual "cli-result" ("\"" <> notUtf8 <> "\"\n") printed - ExitFailure _ -> Fail ("CLI: " <> T.pack (show code)) - ] - --- | nix.conf bytes through the binary (#244): an include target, the --- system directory and NIX_CONFIG reach the file system and the settings --- as the bytes they hold. Each case reads whether pure-eval came on, --- which hides currentSystem. A name that is not UTF-8 exists only on a --- volume that holds one, so a case needing such a name makes it first --- and skips, with the reason, where the temp volume refuses it: APFS --- refuses the name, and HFS+ holds it but opens no path beneath a --- directory so named. A Windows name or variable is UTF-16 and holds no --- such byte at all. The decoy cases need no such name: a file named by --- U+FFFD's UTF-8, which a lossy decode of the byte would open instead, --- must stay unread, as it does under nix-instantiate 2.33.2. -testConfigBytesCLI :: IO [Bool] -testConfigBytesCLI = do - putStrLn "cli/config-bytes" - tmpBase <- getTemporaryDirectory - ambient <- getEnvironment - let root = tmpBase "nova-nix-test-cli-config-bytes" - confDir = root "etc" - noConfDir = root "none" - configVars = ["NIX_CONFIG", "NIX_CONF_DIR", "NIX_USER_CONF_FILES", "XDG_CONFIG_DIRS"] - -- An empty NIX_USER_CONF_FILES names no user files, so only the - -- system file under NIX_CONF_DIR and NIX_CONFIG are read. - runCLI dir nixConfig = - Proc.readCreateProcessWithExitCode - ( (Proc.proc "cabal" ["run", "-v0", "nova-nix", "--", "eval", "--expr", "builtins ? currentSystem"]) - { Proc.env = Just (("NIX_CONF_DIR", dir) : ("NIX_USER_CONF_FILES", "") : ("NIX_CONFIG", nixConfig) : filter ((`notElem` configVars) . fst) ambient) - } - ) - "" - expectAnswer label expected dir nixConfig = do - (code, out, err) <- runCLI dir nixConfig - pure $ case (code, lines out) of - (ExitSuccess, line : _) -> assertEqual label expected line - _ -> Fail ("CLI: " <> T.pack (show code) <> "; stdout=" <> T.pack out <> "; stderr=" <> T.pack err) - expectPure label = expectAnswer label "false" - expectImpure label = expectAnswer label "true" - expectRefusal nixConfig needle = do - (code, _, err) <- runCLI noConfDir nixConfig - pure $ - if code /= ExitSuccess && needle `T.isInfixOf` T.pack err - then Pass - else Fail ("expected a failure mentioning " <> needle <> ", got " <> T.pack (show (code, err))) - -- A case whose name or value holds bytes, spelled as the - -- platform's strings carry them. - spelledCase label bytes check = do - spelled <- envSpelling bytes - case spelled of - Nothing -> True <$ putStrLn (" SKIP " <> T.unpack label <> ": a Windows name or variable cannot hold a byte with no UTF-8 reading") - Just spelling -> check spelling - envCase label bytes check = spelledCase label bytes (runTestM label . check) - -- A case over a file whose name holds bytes, made before the case - -- runs and skipped where the temp volume refuses it. - -- A decoy's name is UTF-8, which every volume holds. - decoyCase label bytes make check = spelledCase label bytes $ \name -> make name >> runTestM label (check name) - fileCase label bytes make check = spelledCase label bytes $ \name -> do - made <- try (make name) - case made of - -- The error string alone: the path in the full message holds - -- the very byte stdout's encoding cannot write. - Left (err :: IOException) -> True <$ putStrLn (" SKIP " <> T.unpack label <> ": the temp volume cannot hold a name that is not UTF-8 (" <> ioeGetErrorString err <> ")") - Right () -> runTestM label (check name) - latin1 = "caf\xE9" :: BS.ByteString - -- The name a lossy decode of latin1 spells: U+FFFD's UTF-8. - decoy = "caf\xEF\xBF\xBD" :: BS.ByteString - decoyDir = root "decoy" - bracket_ - (forceRemoveIfExists root >> createDirectoryIfMissing True confDir >> createDirectoryIfMissing True decoyDir) - (forceRemoveIfExists root) - $ sequence - [ fileCase - "CLI an include target with no UTF-8 reading opens the file it names" - (latin1 <> ".conf") - ( \name -> do - BS.writeFile (confDir name) "pure-eval = true\n" - BS.writeFile (confDir "nix.conf") ("include " <> latin1 <> ".conf\n") - ) - (const (expectPure "include-bytes" confDir "")), - fileCase - "CLI a NIX_CONF_DIR holding a byte with no UTF-8 reading names the system file" - latin1 - ( \name -> do - createDirectoryIfMissing True (root name) - BS.writeFile (root name "nix.conf") "pure-eval = true\n" - ) - (\name -> expectPure "conf-dir-bytes" (root name) ""), - decoyCase - "CLI an !include target with no UTF-8 reading leaves the U+FFFD-named file unread" - (decoy <> ".conf") - ( \name -> do - BS.writeFile (decoyDir name) "pure-eval = true\n" - BS.writeFile (decoyDir "nix.conf") ("!include " <> latin1 <> ".conf\n") - ) - (const (expectImpure "include-decoy" decoyDir "")), - spelledCase "CLI a NIX_CONF_DIR holding such a byte leaves the U+FFFD-named directory unread" latin1 $ \confName -> - decoyCase - "CLI a NIX_CONF_DIR holding such a byte leaves the U+FFFD-named directory unread" - decoy - ( \name -> do - createDirectoryIfMissing True (decoyDir name) - BS.writeFile (decoyDir name "nix.conf") "pure-eval = true\n" - ) - (const (expectImpure "conf-dir-decoy" (decoyDir confName) "")), - envCase - "CLI NIX_CONFIG holding such a byte in a comment and an unknown setting applies the rest" - ("trusted-users = " <> latin1 <> "\npure-eval = true # " <> latin1 <> "\n") - (expectPure "env-bytes-ignored" noConfDir), - envCase - "CLI NIX_CONFIG holding such a byte in a list setting is refused" - ("pure-eval = true\nextra-substituters = https://" <> latin1 <> ".example\n") - (`expectRefusal` "setting 'substituters' has invalid value"), - envCase - "CLI a Boolean ending in a no-break space is invalid, as upstream splits the line" - "pure-eval = true\xC2\xA0\n" - (`expectRefusal` "Boolean setting 'pure-eval' has invalid value") - ] - --- --------------------------------------------------------------------------- --- Tests: an interrupt stops the operation it reaches (#251) --- --------------------------------------------------------------------------- - --- | How long 'interruptedAfterStall' lets an action run before --- interrupting it: far longer than any of these actions takes to reach --- the read it stalls in. -stallMicros :: Int -stallMicros = 200000 - --- | Run an action in a thread of its own, deliver a user interrupt to it --- once it has had time to stall, and report how it ended: @Left@ the --- exception that stopped it, or @Right@ the value it returned instead. -interruptedAfterStall :: IO a -> IO (Either SomeException a) -interruptedAfterStall action = - withAsync action $ \running -> do - threadDelay stallMicros - throwTo (asyncThreadId running) UserInterrupt - waitCatch running - --- | Pass when the interrupt is what stopped the action. -interruptPropagated :: (Show a) => Either SomeException a -> TestResult -interruptPropagated outcome = case outcome of - Left err - | fromException err == Just UserInterrupt -> Pass - | otherwise -> Fail ("stopped by another exception: " <> T.pack (show err)) - Right value -> Fail ("the interrupt became a value: " <> T.pack (show value)) - --- | Run an action while a FIFO sits at the path with a writer that never --- writes, so a read of the path blocks until something interrupts the --- reader. A FIFO with no writer at all reads as empty at once, because --- GHC opens a file non-blocking. -withStalledFifo :: FilePath -> IO a -> IO a -withStalledFifo path action = - bracket_ (Proc.callProcess "mkfifo" [path]) (Dir.removePathForcibly path) $ - withBinaryFile path ReadWriteMode (const action) - --- | Each of these operations caught every exception and turned an --- interrupt into its fallback value: an unreadable file, a cache miss, a --- failed push. An interrupt now stops it. A file read is made to stall --- on a FIFO ('withStalledFifo') and interrupted there from another --- thread, so those cases need POSIX; the request a push makes stalls on --- the loopback fixture on every platform. A fetch cache write never --- blocks, so its interrupt is raised from inside the write. The removal --- behind a build's cleanup neither blocks nor forces anything the caller --- supplies, so no case reaches it. -testInterruptsPropagate :: IO [Bool] -testInterruptsPropagate = do - putStrLn "exceptions/interrupts-propagate" - tmpBase <- getTemporaryDirectory - let root = tmpBase "nova-nix-test-interrupts" - storeDir = StoreDir (root "store") - cacheHome = root "cache" - inStore = storePathToFilePath storeDir - pushTo base = PushConfig {pcCacheUrl = base, pcApiKey = Nothing, pcCompression = PushNone} - plainDrv = - Derivation - { drvOutputs = [], - drvInputDrvs = Map.empty, - drvInputSrcs = [], - drvPlatform = currentPlatform, - drvBuilder = builtinUnpackBuilder, - drvArgs = [], - drvEnv = Map.empty - } - unpacking archive = plainDrv {drvEnv = Map.singleton envSrcs (TE.encodeUtf8 (storePathToText defaultStoreDir archive))} - withCacheHome = - bracket - (lookupEnv "XDG_CACHE_HOME" <* setEnv "XDG_CACHE_HOME" cacheHome) - (maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME")) - . const - fifoCase name test - | SI.os == "mingw32" = True <$ putStrLn (" SKIP " ++ T.unpack name ++ ": needs a FIFO") - | otherwise = runTestM name test - forceRemoveIfExists root - createDirectoryIfMissing True (unStoreDir storeDir) - results <- bracket (openStore storeDir) closeStore $ \store -> - sequence - [ runTestM "an interrupt during a push request stops the push" $ - withHttpServer (\_ _ -> Trickle) $ \base _ requested -> do - outcome <- withAsync (pushPaths (pushTo base) store [StorePath (T.replicate 32 "a") "pushed"]) $ \pushing -> do - requested - throwTo (asyncThreadId pushing) UserInterrupt - waitCatch pushing - pure (interruptPropagated outcome), - fifoCase "an interrupt serialising a path for a push stops the push" $ - withHttpServer (\_ _ -> Send (httpResponse "200 OK" "")) $ \base _ _ -> do - let sp = StorePath (T.replicate 32 "b") "stalled-output" - outcome <- withStalledFifo (inStore sp) (interruptedAfterStall (pushPaths (pushTo base) store [sp])) - pure (interruptPropagated outcome), - fifoCase "an interrupt reading the API key file is not an unreadable key" $ do - let keyFile = root "stalled-key" - outcome <- withStalledFifo keyFile (interruptedAfterStall (loadApiKeyFile keyFile)) - pure (interruptPropagated outcome), - fifoCase "an interrupt verifying a source tree on disk is not a mismatch" $ do - let sp = StorePath (T.replicate 32 "c") "stalled-source" - sources = Map.singleton (T.pack (root "absent-source")) (storePathToText defaultStoreDir sp) - outcome <- withStalledFifo (inStore sp) (interruptedAfterStall (materializeEvalSources store sources)) - pure (interruptPropagated outcome), - fifoCase "an interrupt reading a store derivation is not a missing one" $ do - st <- newEvalState storeDir root - let sp = StorePath (T.replicate 32 "d") "stalled.drv" - outcome <- withStalledFifo (inStore sp) (interruptedAfterStall (runEvalIO st (readStoreDerivation sp))) - pure (interruptPropagated outcome), - -- The entry's path is the cache's layout: one file per key, named - -- by the key's SHA-256 (fetchCacheFile). - fifoCase "an interrupt reading the fetch cache is not a cache miss" $ - withCacheHome $ do - st <- newEvalState storeDir root - let key = "stalled-entry" - entry = cacheHome "nova-nix" "fetch" T.unpack (Hash.bytesToHexText (sha256Digest (TE.encodeUtf8 key))) - createDirectoryIfMissing True (takeDirectory entry) - outcome <- withStalledFifo entry (interruptedAfterStall (runEvalIO st (lookupFetchCache key))) - pure (interruptPropagated outcome), - -- The entry's text is the interrupt, raised when the write forces it. - runTestM "an interrupt writing the fetch cache is not an unwritable cache" $ - withCacheHome $ do - st <- newEvalState storeDir root - outcome <- try (runEvalIO st (writeFetchCache "interrupted-entry" (throw UserInterrupt))) - pure (interruptPropagated outcome), - fifoCase "an interrupt unpacking an archive is not a failed unpack" $ do - let archive = StorePath (T.replicate 32 "f") "stalled.tar" - outcome <- withStalledFifo (inStore archive) (interruptedAfterStall (runBuiltinUnpack storeDir defaultUnpackLimits (unpacking archive) [("out", root "stalled-out")])) - pure (interruptPropagated outcome), - fifoCase "an interrupt reading an input derivation is not an unreadable one" $ do - let input = StorePath (T.replicate 32 "g") "stalled-input.drv" - rootDrv = plainDrv {drvInputDrvs = Map.singleton input ["out"]} - config = (defaultBuildConfig storeDir) {bcTmpDir = root "build"} - outcome <- withStalledFifo (inStore input) (interruptedAfterStall (buildWithDeps config store rootDrv (StorePath (T.replicate 32 "h") "root.drv"))) - pure (interruptPropagated outcome), - -- The failures the unpacker does catch: the zstd decoder reports a - -- corrupt frame with 'error', and a missing archive is an - -- IOException. Each is the archive's failure, not an escape. - runTestM "a corrupt zstd archive and a missing one fail the unpack" $ do - let corrupt = StorePath (T.replicate 32 "i") "corrupt.tar.zst" - missing = StorePath (T.replicate 32 "j") "missing.tar" - BS.writeFile (inStore corrupt) "not a zstd frame" - corruptOutcome <- runBuiltinUnpack storeDir defaultUnpackLimits (unpacking corrupt) [("out", root "corrupt-out")] - missingOutcome <- runBuiltinUnpack storeDir defaultUnpackLimits (unpacking missing) [("out", root "missing-out")] - pure $ case (corruptOutcome, missingOutcome) of - (Left (1, corruptMsg), Left (1, missingMsg)) - | "corrupt.tar.zst" `T.isInfixOf` corruptMsg && "missing.tar" `T.isInfixOf` missingMsg -> Pass - other -> Fail ("expected both unpacks to fail: " <> T.pack (show other)) +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.Zstd.Lazy as ZstdL +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay) +import Control.Concurrent.Async (asyncThreadId, cancel, waitCatch, withAsync) +import Control.Exception (AsyncException (..), ErrorCall (..), IOException, SomeAsyncException (..), SomeException, asyncExceptionToException, bracket, bracket_, catches, displayException, evaluate, finally, fromException, throw, throwIO, throwTo, toException, try) +import Control.Monad (filterM, unless, void, when) +import Control.Monad.State.Strict (State, gets, modify', runState) +import Data.Bits (shiftR, xor, (.&.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Unsafe as BSU +import Data.Char (isDigit) +import Data.Functor.Identity (Identity (..)) +import qualified Data.Graph as Graph +import Data.IORef (atomicModifyIORef', newIORef, readIORef) +import Data.Int (Int64) +import Data.List (inits, intercalate, isPrefixOf, mapAccumL, sort) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.IO as TIO +import Data.Tuple (swap) +import Data.Word (Word32, Word64, Word8) +import qualified Database.SQLite.Simple as SQL +import Foreign.C.Error (Errno (..), eACCES, eISDIR, eNOENT, eNOTDIR) +import Foreign.C.Types (CChar) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.StablePtr (StablePtr, castPtrToStablePtr, castStablePtrToPtr, deRefStablePtr, freeStablePtr, newStablePtr) +import Foreign.Storable (poke, sizeOf) +import qualified GHC.Foreign as GHCForeign +import GHC.IO.Encoding (getFileSystemEncoding, mkTextEncoding, setFileSystemEncoding) +import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import HttpFixture (Reply (..), httpResponse, withFetchurlServer, withHttpServer) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types.Status as HTTP +import Nix.Builder (AttrsDelivery (..), BuildConfig (..), BuildResult (..), BuilderSpawn (..), ReferenceCycle (..), attrsDelivery, buildDerivation, buildPath, buildWithDeps, closureUnder, defaultBuildConfig, execWrapperConfig, execWrapperFor, fetchUrlsFromEnv, orderByReferences, rewriteEnv, rewritePlaceholders, scrubAmbient, spawnFor, substitutePaths, tryFetchUrlsWith, unionEnvs, verifyFetchHash) +import Nix.Builder.Log (EscapeFilter (..), emptyPendingLine, endBuildLog, feedBuildLog, filterLogLine) +import Nix.Builder.Unpack (UnpackLimits (..), builtinUnpackBuilder, defaultUnpackLimits, entryComponents, envSrcs, resolveLinkTarget, runBuiltinUnpack) +import Nix.Builtins (builtinEnv, isNixPathPseudoUrl, parseNixPath, rootScopeNames, splitNixPath) +import Nix.Config (NixConfig (..)) +import qualified Nix.Config as Config +import qualified Nix.DependencyGraph as DepGraph +import Nix.Derivation (Derivation (..), DerivationOutput (..), Platform (..), currentPlatform, extraPlatforms, fromATerm, platformToText, textToPlatform, toATerm, toATermForHash) +import Nix.Derivation.StructuredAttrs (StructuredAttrs (..), decodeStructuredAttrs, encodeStructuredAttrs, renderAttrsShell, stringsAttr, withOutputPlaceholders) +import Nix.Eval (EvalPolicy (..), FetchCache (..), FetchGitArgs (..), MonadEval (..), NixValue (..), StringContext (..), StringContextElement (..), Thunk (..), attrSetFromMap, attrSetLookup, attrSetNull, attrSetSize, builtinNames, checkGitRef, checkGitRev, checkGitUrl, decodeFetchCache, emptyContext, emptyEnv, encodeFetchCache, eval, evaluated, fetchCacheKey, force, gitInputUrl, gitRemote, localFileUrl, mkStr, readThunkValue, runPureEval, typeName, unrestrictedPolicy) +import Nix.Eval.Arena (CStatusError (..), arenaDestroy, arenaInit, arenaLive) +import Nix.Eval.AttrPath (parseAttrPath, selectAttrPath) +import Nix.Eval.CAttrSet (cattrsetFreeze, cattrsetGetKey, cattrsetGetPos, cattrsetIndex, cattrsetInsert, cattrsetKeys, cattrsetLookup, cattrsetNew, cattrsetRemoveKeys, cattrsetSize, cattrsetUnion) +import Nix.Eval.CBytecode (appDeferred, attrkeyStatic, binaryAdd, captureSlots, captureWithScopes, cbcArg1, cbcArg2, cbcArg3, cbcData, cbcDataCount, cbcFlags, cbcOpCount, cbcOpcode, cbcShortArg, formalName, formalNamedSet, formalSet, reservedApply1, reservedApply2, strpartInterp, strpartLit, unaryNegate, pattern OpApp, pattern OpAssert, pattern OpAttrs, pattern OpBinary, pattern OpHasAttr, pattern OpIf, pattern OpIndStr, pattern OpLambda, pattern OpLet, pattern OpList, pattern OpLitBool, pattern OpLitFloat, pattern OpLitInt, pattern OpLitNull, pattern OpLitPath, pattern OpLitUri, pattern OpResolvedVar, pattern OpSelect, pattern OpStr, pattern OpUnary, pattern OpVar, pattern OpWith, pattern OpWithVar) +import Nix.Eval.CEnv (cenvLazyScope) +import Nix.Eval.CList (clistDrop, clistFromThunks, clistIndex, clistLen, clistNew, clistThunks) +import Nix.Eval.CThunk (CThunkPtr, cthunkBool, cthunkCount, cthunkGet, cthunkGetBcIdx, cthunkGetBool, cthunkMarkBlackhole, cthunkNewBc, cthunkNewComputed, cthunkNewComputedInt, cthunkNull, cthunkPayload, cthunkSetComputed, cthunkSetPayload, cthunkState, cthunkValueTag) +import Nix.Eval.CallDepth (topLevelCallDepth) +import Nix.Eval.CanonPath (canonPath, canonPathValue) +import Nix.Eval.Compile (BcBinding (..), BcInheritedName (..), compileExpr, decodeBcBindings) +import qualified Nix.Eval.Context as Context +import Nix.Eval.IO (EvalFailure (..), EvalState (..), allowEvalPath, newEvalState, renderEvalFailure, runEvalIO, runEvalIOTraced) +import Nix.Eval.Policy (allowPathIn, forbiddenPathMessage, isAllowedPath, isAllowedUri, joinComponents, noAllowedPaths, pathComponents, uriAccess) +import Nix.Eval.Print (PrintOptions (..), printAmbiguous, printValue) +import Nix.Eval.SourceError (SourceAccess (..), sourceErrorMessage) +import Nix.Eval.SourcePos (PosIdx (..), RecordedPos (..), lookupPos, newPosRecorder, noPos, recordPos) +import Nix.Eval.StringInterp (joinCoercedList) +import Nix.Eval.Symbol (Symbol (..), symbolCount, symbolIntern, symbolInternBytes, symbolLen, symbolText) +import Nix.Eval.Types (AttrSet (..), Env (..), allocCSlots, attrSetKeys, buildCSlots, emptyCList, pattern ThunkComputed, pattern ValueBool, pattern ValueNull) +import Nix.Expr.Resolve (impureOnlyGlobalNames, staticGlobalNames, undefinedVariableMessage) +import Nix.Expr.Types +import Nix.Hash (compressHash, hashPlaceholder, makeFixedOutputPath, makeTextPath, sha256Digest) +import qualified Nix.Hash as Hash +import Nix.HostPath (hostPathFromBytes) +import Nix.Http (FetchRetryPolicy (..), RetryEffects (..), TransferError (..), defaultFetchRetryPolicy, fetchExceptionFailure, fetchStatusFailure, retryDelayMs, retryTransient, statusError, transferBodyReader, transferFailureHandlers, userAgent, withUserAgent) +import Nix.Json (Json (..), parseJson, renderJson) +import Nix.Parser (ParseError (..), SourceError (..), parseNix, parseNixWithScope) +import Nix.Parser.Lexer (Located (..), Token (..), tokenize) +import Nix.Push (PushArtifact (..), PushCompression (..), PushConfig (..), checkRecordedNarHash, computeClosure, isDerivationPath, loadApiKeyFile, mkNarInfo, mkPushArtifact, narFileName, narHashMatches, outputPathsOnly, parsePushCompression, planMissing, pushPaths, storePathBasename, stripHashPrefix) +import qualified Nix.Realise as Realise +import Nix.Store (DeleteOutcome (..), GcResults (..), GcRoot (..), Store (..), SweepPlan (..), acquirePathLock, addOutLinkRoot, addToStore, autoRootsDir, caseHackDiskNames, closeStore, collectGarbage, copyPathInto, deleteStorePathRaw, findRoots, gcLockFilePath, gcRootsDir, gcSummaryLine, indirectRootRecordName, isValid, materializeEvalSources, materializeEvalStoreWrites, onDiskNameKey, openStore, orderLinks, pathExists, reachableFrom, referencesMap, registrationFor, releasePathLock, resolveDeleteTarget, rewriteBytes, rewriteStoreHashes, scanReferences, setReadOnly, showFreedBytes, sweepPlan, tryAcquirePathLock, unpackNarEntry, withCollectorLock, writeDrv, writeDrvClosure) +import Nix.Store.CaseSensitive (CaseSensitivity (..), probeCaseSensitivity, processCaseHack, trySetCaseSensitiveDir, volumeCaseHack) +import Nix.Store.DB (PathInfo (..), PathRegistration (..), closeStoreDB, dbFileName, isValidPath, metaDirName, openStoreDB, queryAllValidPaths, queryDeriver, queryPathInfo, queryReferences, registerPath, registerPaths) +import Nix.Store.EntryName (NameRules (..), checkEntryName, checkLinkTarget) +import qualified Nix.Store.ExecBit as ExecBit +import Nix.Store.Path (StoreDir (..), StorePath, StoreWriteMode (..), defaultStoreDir, defaultStoreDirText, isCanonicalStoreText, parseStorePath, parseStorePathBaseName, parseStorePathPrefix, platformStoreDir, qualifyPathText, storePathHashLen, storePathToFilePath, storePathToText, storeTextToFilePath, windowsStoreDir) +import Nix.Store.Path.Internal (StorePath (..)) +import qualified Nix.Substituter as Subst +import qualified NovaCache.Base64 as B64 +import qualified NovaCache.Hash as CHash +import qualified NovaCache.NAR as NAR +import qualified NovaCache.NarInfo as NarInfo +import qualified NovaCache.Signing as Signing +import qualified NovaCache.Zstd as CZstd +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getPermissions, getTemporaryDirectory, removeDirectoryRecursive, writable) +import qualified System.Directory as Dir +import System.Environment (getArgs, getEnvironment, getExecutablePath, lookupEnv, setEnv, unsetEnv) +import qualified System.Environment.Blank as Blank +import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) +import System.FilePath (dropDrive, joinPath, makeRelative, pathSeparator, searchPathSeparator, splitDirectories, takeDirectory, takeDrive, takeFileName, ()) +import System.IO (BufferMode (..), IOMode (..), hPutStrLn, hSetBuffering, stderr, stdout, withBinaryFile) +import System.IO.Error (ioeGetErrorString, mkIOError, resourceVanishedErrorType) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Info as SI +import System.OsPath (OsPath) +import qualified System.OsPath as OP +import qualified System.Process as Proc +import System.Timeout (timeout) +import qualified Test.QuickCheck as QC + +-- --------------------------------------------------------------------------- +-- Test harness +-- --------------------------------------------------------------------------- + +data TestResult = Pass | Fail !Text + +runTest :: Text -> TestResult -> IO Bool +runTest name result = case result of + Pass -> do + putStrLn $ " PASS " ++ T.unpack name + pure True + Fail msg -> do + putStrLn $ " FAIL " ++ T.unpack name ++ ": " ++ T.unpack msg + pure False + +-- | Like 'runTest' but for tests that need IO to produce their result. +-- An exception escaping the action becomes one FAIL line instead of +-- aborting the whole suite (which would skip every later group and its +-- cleanup). +runTestM :: Text -> IO TestResult -> IO Bool +runTestM name action = do + outcome <- try action + runTest name $ case outcome of + Left (e :: SomeException) -> Fail ("uncaught exception: " <> T.pack (show e)) + Right result -> result + +assertEqual :: (Eq a, Show a) => Text -> a -> a -> TestResult +assertEqual label expected actual + | expected == actual = Pass + | otherwise = + Fail $ + label + <> ": expected " + <> T.pack (show expected) + <> " but got " + <> T.pack (show actual) + +-- | The first failure of two results, or 'Pass' when both pass. +andThen :: TestResult -> TestResult -> TestResult +andThen first second = case first of + Pass -> second + failed -> failed + +-- | Render string-value bytes in a failure message (display-only decode). +bytesText :: BS.ByteString -> Text +bytesText = TE.decodeUtf8With lenientDecode + +assertRight :: (Show e) => Text -> Either e a -> (a -> TestResult) -> TestResult +assertRight label result check = case result of + Left err -> Fail (label <> ": got error: " <> T.pack (show err)) + Right val -> check val + +assertLeft :: (Show a) => Text -> Either e a -> TestResult +assertLeft _ (Left _) = Pass +assertLeft label (Right val) = Fail (label <> ": expected error but got: " <> T.pack (show val)) + +-- | What a test expression's relative path literals resolve against. +-- Absolute, because that is the invariant the parser now establishes: no +-- relative path literal survives parsing, so nothing downstream has to know +-- what one would have meant. +testBaseDir :: FilePath +testBaseDir = "/nova-nix-test" + +-- | Where a test expression's source comes from: text with no file, as an +-- @--expr@ argument is. +testOrigin :: SourceOrigin +testOrigin = SourceText "" + +-- | A position in a test expression's source. +testPos :: Int -> Int -> SrcPos +testPos = SrcPos testOrigin + +-- | Helper: parse and check result. +assertParse :: Text -> Text -> Expr -> TestResult +assertParse = assertParseIn [] + +-- | 'assertParse' for source whose free variables are bound around it, the +-- way @scopedImport@ binds its scope: each stays a name-based 'EVar'. +assertParseIn :: [Text] -> Text -> Text -> Expr -> TestResult +assertParseIn names label source expected = + assertRight label (parseNixWithScope (withGlobals names) testBaseDir testOrigin (TE.encodeUtf8 source)) $ \actual -> + assertEqual label expected actual + +-- | The root environment's names with more bound around them. +withGlobals :: [Text] -> Set.Set Text +withGlobals names = Set.union (Set.fromList names) staticGlobalNames + +-- | Helper: extract just token types from Located list (drop positions and EOF). +tokenTypes :: [Located] -> [Token] +tokenTypes = filter (/= TokEOF) . map locToken + +-- | Helper: parse Nix source and evaluate with builtinEnv. Parse errors +-- are tagged so failure assertions can tell them apart from eval errors. +evalNix :: Text -> Either Text NixValue +evalNix = evalNixBytes . TE.encodeUtf8 + +-- | 'evalNix' over source bytes, which need not be UTF-8. +evalNixBytes :: BS.ByteString -> Either Text NixValue +evalNixBytes source = case parseNix testBaseDir testOrigin source of + Left err -> Left (sourceFailure err) + Right expr -> runPureEval (eval (builtinEnv unrestrictedPolicy 0 []) expr) + +-- | Prefix marking a parse (not eval) failure in 'evalNix' results. +parseErrorTag :: Text +parseErrorTag = "parse error: " + +-- | A source failure as an 'evalNix' result: a syntax error carries +-- 'parseErrorTag'; an unbound variable reads as the evaluation error +-- upstream raises for it, before evaluating anything. +sourceFailure :: SourceError -> Text +sourceFailure (SyntaxError err) = parseErrorTag <> T.pack (show err) +sourceFailure (UndefinedVariable name) = undefinedVariableMessage name + +-- | The syntax error a source fails to parse with. +syntaxErrorOf :: Text -> Either Text ParseError +syntaxErrorOf = syntaxErrorOfBytes . TE.encodeUtf8 + +-- | 'syntaxErrorOf' over source bytes, which need not be UTF-8. +syntaxErrorOfBytes :: BS.ByteString -> Either Text ParseError +syntaxErrorOfBytes source = case parseNix testBaseDir testOrigin source of + Left (SyntaxError err) -> Right err + Left other -> Left ("expected a syntax error, got " <> T.pack (show other)) + Right _ -> Left "parsed unexpectedly" + +-- | Assert that a Nix expression evaluates to the expected value. +assertEval :: Text -> Text -> NixValue -> TestResult +assertEval label source expected = + assertRight label (evalNix source) $ \actual -> + assertEqual label expected actual + +-- | Assert that a Nix expression parses but fails to EVALUATE. A parse +-- failure fails the assertion: a test documenting a runtime error must +-- not keep passing after a regression stops the construct from parsing. +-- | The bytes of a string value, and nothing for any other value. +stringBytes :: NixValue -> BS.ByteString +stringBytes (VStr bytes _) = bytes +stringBytes _ = BS.empty + +assertEvalFail :: Text -> Text -> TestResult +assertEvalFail label source = case evalNix source of + Left err + | parseErrorTag `T.isPrefixOf` err -> + Fail (label <> ": expected an eval error but the source did not parse: " <> err) + | otherwise -> Pass + Right val -> Fail (label <> ": expected eval failure but got: " <> T.pack (show val)) + +-- | Assert that a Nix expression parses and fails to evaluate with exactly +-- the given message, for errors whose wording is upstream's. +assertEvalError :: Text -> Text -> Text -> TestResult +assertEvalError label source expected = case evalNix source of + Left err + | parseErrorTag `T.isPrefixOf` err -> + Fail (label <> ": expected an eval error but the source did not parse: " <> err) + | otherwise -> assertEqual label expected err + Right val -> Fail (label <> ": expected eval failure but got: " <> T.pack (show val)) + +-- | 'assertEvalError' under the IO evaluator, which keeps a forced +-- thunk's value and marks one while it is being forced, as upstream's +-- evaluator does; the pure one does neither. +assertEvalErrorIO :: FilePath -> Text -> Text -> Text -> IO TestResult +assertEvalErrorIO baseDir label source expected = do + result <- evalNixIO baseDir source + pure $ case result of + Left err -> assertEqual label expected err + Right val -> Fail (label <> ": expected eval failure but got: " <> T.pack (show val)) + +-- | Assert that a Nix expression fails at PARSE time. +assertParseFail :: Text -> Text -> TestResult +assertParseFail label source = case evalNix source of + Left err + | parseErrorTag `T.isPrefixOf` err -> Pass + | otherwise -> + Fail (label <> ": expected a parse error but evaluation failed instead: " <> err) + Right val -> Fail (label <> ": expected parse failure but got: " <> T.pack (show val)) + +-- --------------------------------------------------------------------------- +-- Shell discovery for builder tests +-- --------------------------------------------------------------------------- + +-- | Find a POSIX-compatible shell for builder tests. +-- On Unix, always @\/bin\/sh@. On Windows, searches for @bash.exe@ +-- at known Git for Windows locations first, then PATH. Checks known +-- paths first to avoid picking up the WSL launcher at +-- @C:\\Windows\\System32\\bash.exe@ which exits 1 when WSL is not +-- configured. Real Nix builders always use bash from the store - +-- this bridges the gap until nova-nix bootstraps its own bash +-- derivation. +findTestShell :: IO Text +findTestShell = case SI.os of + "mingw32" -> do + let known = + [ "C:\\Program Files\\Git\\bin\\bash.exe", + "C:\\Program Files (x86)\\Git\\bin\\bash.exe" + ] + found <- filterM Dir.doesFileExist known + case found of + (p : _) -> pure (T.pack p) + [] -> do + inPath <- Dir.findExecutable "bash" + case inPath of + Just p -> pure (T.pack p) + Nothing -> + error + "bash not found: install Git for Windows or add bash to PATH" + _ -> pure "/bin/sh" + +-- --------------------------------------------------------------------------- +-- Tests: Expr types (existing) +-- --------------------------------------------------------------------------- + +testExprTypes :: IO [Bool] +testExprTypes = do + putStrLn "expr/types" + sequence + [ runTest "int literal" $ + assertEqual "ELit NixInt" (ELit (NixInt 42)) (ELit (NixInt 42)), + runTest "bool literal" $ + assertEqual "ELit NixBool" (ELit (NixBool True)) (ELit (NixBool True)), + runTest "null literal" $ + assertEqual "ELit NixNull" (ELit NixNull) (ELit NixNull), + runTest "var" $ + assertEqual "EVar" (EVar "x") (EVar "x"), + runTest "string parts" $ + let parts = [StrLit "hello ", StrInterp (EVar "name")] + in assertEqual "EStr" (EStr parts) (EStr parts), + runTest "binary op" $ + let expr = EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2)) + in assertEqual "EBinary" expr expr, + runTest "lambda" $ + let expr = ELambda (FormalName "x") (EVar "x") NoCaptureInfo + in assertEqual "ELambda" expr expr, + runTest "let binding" $ + let expr = ELet [NamedBinding (testPos 1 5) (StaticKey "x") (ELit (NixInt 1))] (EVar "x") NoCaptureInfo + in assertEqual "ELet" expr expr, + runTest "attrs" $ + let expr = EAttrs False [NamedBinding (testPos 1 3) (StaticKey "a") (ELit (NixInt 1))] NoCaptureInfo + in assertEqual "EAttrs" expr expr, + runTest "if-then-else" $ + let expr = EIf (ELit (NixBool True)) (ELit (NixInt 1)) (ELit (NixInt 2)) + in assertEqual "EIf" expr expr + ] + +-- --------------------------------------------------------------------------- +-- Tests: Store paths (existing) +-- --------------------------------------------------------------------------- + +testStorePaths :: IO [Bool] +testStorePaths = do + putStrLn "store/path" + let sp = StorePath {spHash = "s66mzxpvicwk07gjbjfw9izjfa797vsw", spName = "hello-2.12.1"} + sequence + [ runTest "default store dir" $ + assertEqual "defaultStoreDir" "/nix/store" (unStoreDir defaultStoreDir), + runTest "windows store dir" $ + assertEqual "windowsStoreDir" "C:\\nix\\store" (unStoreDir windowsStoreDir), + runTest "store path to text" $ + assertEqual + "storePathToText" + "/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1" + (T.unpack (storePathToText defaultStoreDir sp)), + runTest "store path ordering" $ + let sp2 = StorePath {spHash = "zzz", spName = "later"} + in assertEqual "Ord" True (sp < sp2), + -- The reader-side mapping: canonical store text resolves into the + -- store dir it is given; everything else is the path as written. + runTest "store text maps into the platform store dir" $ + assertEqual + "mapped" + (unStoreDir platformStoreDir <> "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x/sub/f") + (storeTextToFilePath platformStoreDir "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x/sub/f"), + runTest "bare store dir text maps to the platform store root" $ + assertEqual "mapped-root" (unStoreDir platformStoreDir) (storeTextToFilePath platformStoreDir "/nix/store"), + runTest "store text with a backslash subpath maps" $ + assertEqual + "mapped-backslash" + (unStoreDir platformStoreDir <> "\\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-y") + (storeTextToFilePath platformStoreDir "/nix/store\\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-y"), + runTest "non-store text under a store with no drive is the path as written" $ + assertEqual "unmapped" "/etc/hosts" (storeTextToFilePath defaultStoreDir "/etc/hosts"), + runTest "a store-prefix-like name does not map" $ + assertEqual "unmapped-like" "/nix/storefoo" (storeTextToFilePath defaultStoreDir "/nix/storefoo") + `andThen` assertEqual "on-the-store-drive" "C:/nix/storefoo" (storeTextToFilePath windowsStoreDir "/nix/storefoo"), + -- A rooted path with no drive names the store's drive, fixed by + -- configuration rather than by the drive that is current. + runTest "a rooted path with no drive opens on the store's drive" $ + assertEqual "default" "C:/probe/f.txt" (storeTextToFilePath windowsStoreDir "/probe/f.txt") + `andThen` assertEqual "redirected" "D:/probe/f.txt" (storeTextToFilePath (StoreDir "D:\\s") "/probe/f.txt") + `andThen` assertEqual "root" "C:/" (storeTextToFilePath windowsStoreDir "/"), + -- A backslash roots a path only where it is a separator. + runTest "a backslash-rooted path gains the drive on Windows and is a name on POSIX" $ + assertEqual + "backslash" + (if SI.os == "mingw32" then "C:\\probe\\f.txt" else "\\probe\\f.txt") + (storeTextToFilePath windowsStoreDir "\\probe\\f.txt"), + runTest "a drive-qualified, relative or UNC path opens as written" $ + assertEqual "other-drive" "C:/probe/f.txt" (storeTextToFilePath (StoreDir "D:\\s") "C:/probe/f.txt") + `andThen` assertEqual "relative" "probe/f.txt" (storeTextToFilePath windowsStoreDir "probe/f.txt") + `andThen` assertEqual "unc" "//server/share/f.txt" (storeTextToFilePath windowsStoreDir "//server/share/f.txt") + `andThen` assertEqual "unc-backslash" "\\\\server\\share\\f.txt" (storeTextToFilePath windowsStoreDir "\\\\server\\share\\f.txt"), + -- Store text names the store directory, not the store drive's + -- \nix\store, and the logical store's parent is a plain path there. + runTest "store text under a redirected Windows store resolves through the store dir" $ + assertEqual "store" "D:\\s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x/f" (storeTextToFilePath (StoreDir "D:\\s") "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x/f") + `andThen` assertEqual "store-root" "D:\\s" (storeTextToFilePath (StoreDir "D:\\s") "/nix/store") + `andThen` assertEqual "parent" "D:/nix" (storeTextToFilePath (StoreDir "D:\\s") "/nix") + `andThen` assertEqual "value" "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x" (qualifyPathText (StoreDir "D:\\s") "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x"), + runTest "on this platform's store a rooted path with no drive gains C: on Windows only" $ + assertEqual + "platform" + (if SI.os == "mingw32" then "C:/probe/f.txt" else "/probe/f.txt") + (storeTextToFilePath platformStoreDir "/probe/f.txt"), + runTestM "a drive-qualified path opens as written under every store dir" $ + property $ + QC.forAll ((,) <$> genStoreDir <*> genDriveQualified) $ \(sd, path) -> + storeTextToFilePath sd path QC.=== T.unpack path, + runTestM "a rooted path outside the store gains the store's drive" $ + property $ + QC.forAll ((,,) <$> genDrive <*> genDriveDirTail <*> genOutsideStore) $ \(drive, dirTail, path) -> + storeTextToFilePath (StoreDir (T.unpack (drive <> dirTail))) path QC.=== T.unpack (drive <> path), + runTestM "under a store with no drive every path outside the store opens as written" $ + property $ + QC.forAll ((,) <$> genPosixStoreDir <*> QC.oneof [genOutsideStore, genDriveQualified]) $ \(sd, path) -> + storeTextToFilePath sd path QC.=== T.unpack path, + runTestM "store text resolves through the store dir under every store dir" $ + property $ + QC.forAll ((,) <$> genStoreDir <*> genStoreTail) $ \(sd, rest) -> + storeTextToFilePath sd (defaultStoreDirText <> rest) QC.=== (unStoreDir sd <> T.unpack rest), + runTestM "a path outside the store opens as the text the policy checks" $ + property $ + QC.forAll ((,) <$> genStoreDir <*> QC.oneof [genOutsideStore, genDriveQualified]) $ \(sd, path) -> + storeTextToFilePath sd path QC.=== T.unpack (qualifyPathText sd path), + runTestM "qualifying a path twice is qualifying it once" $ + property $ + QC.forAll ((,) <$> genStoreDir <*> QC.oneof [genOutsideStore, genDriveQualified, (defaultStoreDirText <>) <$> genStoreTail]) $ \(sd, path) -> + qualifyPathText sd (qualifyPathText sd path) QC.=== qualifyPathText sd path, + -- The reason this takes a store dir at all: a caller given one must + -- read from it, not from the platform default. + runTest "store text maps into a redirected store dir" $ + assertEqual + "redirected" + "/tmp/scratch-store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x" + (storeTextToFilePath (StoreDir "/tmp/scratch-store") "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x"), + -- Both sides must land in the SAME store dir. Not the same string: + -- storePathToFilePath joins with the native separator while + -- storeTextToFilePath passes the canonical text's tail through, so + -- the two spellings differ on Windows and open the same file. + runTest "a redirected read lands in the same store as the write" $ + let redirected = StoreDir "/tmp/scratch-store" + redirectedPath = StorePath {spHash = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa", spName = "x"} + readSide = storeTextToFilePath redirected (storePathToText defaultStoreDir redirectedPath) + writeSide = storePathToFilePath redirected redirectedPath + underRedirected p = unStoreDir redirected `isPrefixOf` p + in assertEqual + "both under the redirected store" + (True, True, False) + (underRedirected readSide, underRedirected writeSide, unStoreDir platformStoreDir `isPrefixOf` readSide), + runTest "isCanonicalStoreText accepts both separators and rejects lookalikes" $ + assertEqual + "predicate" + [True, True, True, False, False] + ( map + isCanonicalStoreText + ["/nix/store", "/nix/store/x", "/nix/store\\x", "/nix/storefoo", "C:\\nix\\store\\x"] + ), + runTestM "compressHash XORs byte i into position i mod the length" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genCompressCase $ \(len, bytes) -> + BS.unpack (compressHash len (BS.pack bytes)) QC.=== compressHashModel len bytes + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + where + -- Lengths on both sides of the input's, so the last chunk is short, + -- whole or absent, and below one, where there is nothing to fold into. + genCompressCase = (,) <$> QC.choose (-1, 40) <*> QC.resize 70 (QC.listOf QC.arbitrary) + property :: (QC.Testable prop) => prop -> IO TestResult + property prop = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} prop + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + genDrive = QC.elements ["C:", "D:", "z:"] + -- What follows the drive in a Windows store directory, either spelling. + genDriveDirTail = QC.elements ["\\nix\\store", "\\s", "/s/store"] + genPosixStoreDir = StoreDir <$> QC.elements ["/nix/store", "/tmp/scratch-store", "/s"] + genStoreDir = QC.oneof [genPosixStoreDir, (\drive dirTail -> StoreDir (T.unpack (drive <> dirTail))) <$> genDrive <*> genDriveDirTail] + -- Segments that spell the store, and its lookalikes, when they lead. + genSegments = QC.listOf (QC.elements ["a", "src", "f.txt", "nix", "store", "storefoo", "x y"]) + genDriveQualified = (\drive segments -> drive <> "/" <> T.intercalate "/" segments) <$> genDrive <*> genSegments + -- Rooted paths with no drive that are not store text, @/@ and @/nix@ + -- among them. + genOutsideStore = ((\segments -> "/" <> T.intercalate "/" segments) <$> genSegments) `QC.suchThat` (not . isCanonicalStoreText) + -- What follows @/nix/store@ in store text. + genStoreTail = QC.oneof [pure "", (\sep segments -> sep <> T.intercalate "/" segments) <$> QC.elements ["/", "\\"] <*> genSegments] + +-- | Upstream's @compressHash@ loop (hash.cc), one byte at a time. +compressHashModel :: Int -> [Word8] -> [Word8] +compressHashModel len bytes = + [foldl' xor 0 [b | (i, b) <- zip [0 :: Int ..] bytes, i `mod` len == j] | j <- [0 .. len - 1]] + +-- --------------------------------------------------------------------------- +-- Tests: Derivation (existing) +-- --------------------------------------------------------------------------- + +testDerivation :: IO [Bool] +testDerivation = do + putStrLn "derivation" + sequence + [ runTest "current platform is known" $ + case currentPlatform of + OtherPlatform _ -> Fail "currentPlatform returned OtherPlatform" + _ -> Pass + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Literals +-- --------------------------------------------------------------------------- + +testEvalLiterals :: IO [Bool] +testEvalLiterals = do + putStrLn "eval/literals" + sequence + [ runTest "empty env" $ + assertEqual "emptyEnv" emptyEnv emptyEnv, + runTest "int" $ + assertEval "int" "42" (VInt 42), + runTest "float" $ + assertEval "float" "3.14" (VFloat 3.14), + runTest "bool true" $ + assertEval "true" "true" (VBool True), + runTest "null" $ + assertEval "null" "null" VNull, + runTest "string" $ + assertEval "string" "\"hello\"" (mkStr "hello") + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Variables +-- --------------------------------------------------------------------------- + +testEvalVariables :: IO [Bool] +testEvalVariables = do + putStrLn "eval/variables" + sequence + [ runTest "let variable" $ + assertEval "let-var" "let x = 1; in x" (VInt 1), + runTest "undefined variable" $ + assertEvalFail "undef" "x", + runTest "builtin true" $ + assertEval "builtin-true" "true" (VBool True) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Arithmetic +-- --------------------------------------------------------------------------- + +testEvalArithmetic :: IO [Bool] +testEvalArithmetic = do + putStrLn "eval/arithmetic" + sequence + [ runTest "int add" $ + assertEval "add" "1 + 2" (VInt 3), + runTest "int sub" $ + assertEval "sub" "10 - 3" (VInt 7), + runTest "int mul" $ + assertEval "mul" "4 * 5" (VInt 20), + runTest "int div" $ + assertEval "div" "10 / 3" (VInt 3), + runTest "float add" $ + assertEval "float-add" "1.5 + 2.5" (VFloat 4.0), + -- Integer overflow is an eval error, never a two's-complement wrap; + -- the boundary itself still computes. The messages are upstream's + -- from 2.25 on, as nix-instantiate 2.33.2 prints them (2.24.9 leaves + -- overflow to undefined C++ signed arithmetic), except division's, + -- which 2.24.9 checks itself and 2.25 rewords. + runTest "add overflow fails" $ + assertEvalError "add-overflow" "9223372036854775807 + 1" "integer overflow in adding 9223372036854775807 + 1", + runTest "sub overflow fails" $ + assertEvalError "sub-overflow" "(-9223372036854775807) - 2" "integer overflow in subtracting -9223372036854775807 - 2", + runTest "mul overflow fails" $ + assertEvalError "mul-overflow" "builtins.mul 9223372036854775807 2" "integer overflow in multiplying 9223372036854775807 * 2", + runTest "div minBound by -1 overflows" $ + assertEvalError "div-overflow" "((-9223372036854775807) - 1) / (-1)" "overflow in integer division", + runTest "builtins.div minBound by -1 overflows" $ + assertEvalError "builtin-div-overflow" "builtins.div ((-9223372036854775807) - 1) (-1)" "overflow in integer division", + runTest "negate minBound overflows as 0 - n" $ + assertEvalError "neg-overflow" "-((-9223372036854775807) - 1)" "integer overflow in subtracting 0 - -9223372036854775808", + -- Unary minus is __sub 0 e upstream (parser.y at 2.24.9). + runTest "negating a float zero gives positive zero" $ + assertEval "neg-zero" "builtins.toJSON [ (-(0.0)) (-(-0.0)) ]" (mkStr "[0.0,0.0]"), + runTest "negating a non-number fails as builtins.sub does" $ + assertEvalError "neg-set" "-{ }" "expected an integer but found a set: { }", + -- -, *, / and the arithmetic builtins are upstream's prim_sub, + -- prim_mul, prim_div and prim_add (primops.cc at 2.24.9): forceInt + -- on both operands, or forceFloat on both once either is a float. + runTest "subtracting a set from an integer fails its forceInt" $ + assertEvalError "sub-set" "1 - {}" "expected an integer but found a set: { }", + runTest "subtracting from a set fails on the left operand" $ + assertEvalError "set-sub" "{} - 1" "expected an integer but found a set: { }", + runTest "subtracting a set from a float fails its forceFloat" $ + assertEvalError "float-sub-set" "1.0 - {}" "expected a float but found a set: { }", + runTest "two non-numbers fail on the left one" $ + assertEvalError "set-sub-str" "{} - \"a\"" "expected an integer but found a set: { }", + runTest "multiplying a float by a string fails its forceFloat" $ + assertEvalError "float-mul-str" "2.5 * \"a\"" "expected a float but found a string: \"a\"", + runTest "dividing by a set fails the divisor's forceFloat" $ + assertEvalError "div-set" "1 / {}" "expected a float but found a set: { }", + runTest "dividing a set by an integer fails its forceInt" $ + assertEvalError "set-div" "{} / 1" "expected an integer but found a set: { }", + runTest "a zero divisor is refused before the dividend is checked" $ + assertEvalError "set-div-zero" "{} / 0" "division by zero", + runTest "a non-number divisor is refused before the dividend" $ + assertEvalError "set-div-str" "{} / \"a\"" "expected a float but found a string: \"a\"", + runTest "dividing by negative zero is a division by zero" $ + assertEvalError "div-neg-zero" "1 / (-0.0)" "division by zero", + runTest "builtins.div by zero says only division by zero" $ + assertEvalError "builtin-div-zero" "builtins.div 1 0" "division by zero", + runTest "builtins.add refuses a string through forceInt" $ + assertEvalError "builtin-add-str" "builtins.add \"a\" 1" "expected an integer but found a string: \"a\"", + runTest "builtins.add with a float refuses a string through forceFloat" $ + assertEvalError "builtin-add-float-str" "builtins.add 1.5 \"a\"" "expected a float but found a string: \"a\"", + runTest "builtins.sub refuses a set" $ + assertEvalError "builtin-sub-set" "builtins.sub 1 {}" "expected an integer but found a set: { }", + runTest "builtins.bitXor refuses a float" $ + assertEvalError "bitxor-float" "builtins.bitXor 1 1.0" "expected an integer but found a float: 1", + runTest "builtins.bitAnd fails on its left operand first" $ + assertEvalError "bitand-set-str" "builtins.bitAnd {} \"a\"" "expected an integer but found a set: { }", + runTest "builtins.bitOr refuses a set" $ + assertEvalError "bitor-set" "builtins.bitOr {} 1" "expected an integer but found a set: { }", + runTest "float division still divides" $ + assertEval "float-div" "1 / 4.0" (VFloat 0.25), + runTest "add at the boundary still works" $ + assertEval "add-boundary" "9223372036854775806 + 1 == 9223372036854775807" (VBool True), + runTest "int-float promotion" $ + assertEval "promote" "1 + 2.0" (VFloat 3.0), + runTest "trailing-dot float" $ + assertEval "trailing-dot" "12. == 12.0" (VBool True), + runTest "trailing-dot float with exponent" $ + assertEval "trailing-dot-exp" "12.e2 == 1200.0" (VBool True), + runTest "trailing-dot float typeOf" $ + assertEval "trailing-dot-type" "builtins.typeOf 12." (mkStr "float"), + runTest "negate int" $ + assertEval "negate" "- 5" (VInt (-5)), + runTest "division by zero" $ + assertEvalFail "div0" "1 / 0", + runTest "absolute path lexes as path, not division" $ + assertEval "path-abs" "builtins.typeOf /abs/path" (mkStr "path"), + runTest "bareword relative path lexes as path" $ + assertEval "path-rel" "builtins.typeOf foo/bar" (mkStr "path"), + runTest "function applied to an absolute path argument" $ + assertEval "app-abs-path" "(p: builtins.typeOf p) /abs/path" (mkStr "path") + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Comparison +-- --------------------------------------------------------------------------- + +testEvalComparison :: IO [Bool] +testEvalComparison = do + putStrLn "eval/comparison" + sequence + [ runTest "int eq" $ + assertEval "eq" "1 == 1" (VBool True), + runTest "int neq" $ + assertEval "neq" "1 != 2" (VBool True), + runTest "int lt" $ + assertEval "lt" "1 < 2" (VBool True), + runTest "int gte" $ + assertEval "gte" "3 >= 3" (VBool True), + runTest "string compare" $ + assertEval "str-lt" "\"abc\" < \"def\"" (VBool True), + -- <= and >= are negated swapped <, so NaN compares as upstream: + -- nan <= x and nan >= x are true while nan < x and nan == nan are + -- false ((1.0e308 * 10) * 0.0 is inf * 0.0, i.e. nan). + runTest "nan lte is true" $ + assertEval "nan-lte" "let nan = (1.0e308 * 10) * 0.0; in nan <= 1.0" (VBool True), + runTest "nan gte is true" $ + assertEval "nan-gte" "let nan = (1.0e308 * 10) * 0.0; in nan >= 1.0" (VBool True), + runTest "nan lt is false" $ + assertEval "nan-lt" "let nan = (1.0e308 * 10) * 0.0; in nan < 1.0" (VBool False), + runTest "nan self-equality is false" $ + assertEval "nan-eq" "let nan = (1.0e308 * 10) * 0.0; in nan == nan" (VBool False), + runTest "lte on equal lists" $ + assertEval "list-lte-eq" "[ 1 2 ] <= [ 1 2 ]" (VBool True), + runTest "lte incomparable types fails" $ + assertEvalFail "lte-err" "1 <= \"a\"", + -- Upstream's CompareValues (primops.cc at 2.24.9); > and <= swap + -- the operands as the parser's desugaring to __lessThan does. + runTest "comparing different types names both" $ + assertEvalError "lt-int-set" "1 < {}" "cannot compare an integer with a set", + runTest "gt compares the swapped operands" $ + assertEvalError "gt-int-set" "1 > {}" "cannot compare a set with an integer", + runTest "lte compares the swapped operands" $ + assertEvalError "lte-int-set" "1 <= {}" "cannot compare a set with an integer", + runTest "gte compares the operands in order" $ + assertEvalError "gte-int-set" "1 >= {}" "cannot compare an integer with a set", + runTest "Booleans are incomparable" $ + assertEvalError "lt-bool" "true < false" "cannot compare a Boolean with a Boolean; values of that type are incomparable", + runTest "a lambda and a primop are both functions, so incomparable" $ + assertEvalError "lt-fn" "(x: x) < builtins.map" "cannot compare a function with the built-in function 'map'; values of that type are incomparable", + runTest "builtins.lessThan on nulls is incomparable" $ + assertEvalError "lessthan-null" "builtins.lessThan null null" "cannot compare null with null; values of that type are incomparable", + runTest "list comparison reports the first unequal pair" $ + assertEvalError "lt-list" "[ 1 ] < [ \"a\" ]" "cannot compare an integer with a string", + runTest "equal incomparable elements do not stop a list comparison" $ + assertEval "lt-list-sets" "[ {} ] < [ {} ]" (VBool False) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Logic +-- --------------------------------------------------------------------------- + +testEvalLogic :: IO [Bool] +testEvalLogic = do + putStrLn "eval/logic" + sequence + [ runTest "and true" $ + assertEval "and-true" "true && true" (VBool True), + runTest "and short-circuit" $ + assertEval "and-short" "false && true" (VBool False), + runTest "or true" $ + assertEval "or-true" "true || false" (VBool True), + runTest "or short-circuit" $ + assertEval "or-short" "false || true" (VBool True), + runTest "not" $ + assertEval "not" "!false" (VBool True), + runTest "implication false->x" $ + assertEval "impl-false" "false -> false" (VBool True), + runTest "implication true->true" $ + assertEval "impl-true" "true -> true" (VBool True) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Strings +-- --------------------------------------------------------------------------- + +testEvalStrings :: IO [Bool] +testEvalStrings = do + putStrLn "eval/strings" + sequence + [ runTest "string concat" $ + assertEval "concat" "\"hello\" + \" world\"" (mkStr "hello world"), + runTest "string interpolation" $ + assertEval "interp" "let x = \"world\"; in \"hello ${x}\"" (mkStr "hello world"), + runTest "interpolation coerce int" $ + assertEval "coerce-int" "\"val=${builtins.toString 42}\"" (mkStr "val=42"), + runTest "empty string" $ + assertEval "empty" "\"\"" (mkStr "") + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - If/Assert +-- --------------------------------------------------------------------------- + +testEvalIfAssert :: IO [Bool] +testEvalIfAssert = do + putStrLn "eval/if-assert" + sequence + [ runTest "if true" $ + assertEval "if-true" "if true then 1 else 2" (VInt 1), + runTest "if false" $ + assertEval "if-false" "if false then 1 else 2" (VInt 2), + runTest "assert pass" $ + assertEval "assert-pass" "assert true; 42" (VInt 42), + runTest "assert fail" $ + assertEvalFail "assert-fail" "assert false; 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Let +-- --------------------------------------------------------------------------- + +testEvalLet :: IO [Bool] +testEvalLet = do + putStrLn "eval/let" + sequence + [ runTest "simple let" $ + assertEval "let" "let x = 1; in x" (VInt 1), + runTest "multi let" $ + assertEval "multi" "let x = 1; y = 2; in x + y" (VInt 3), + runTest "recursive let" $ + assertEval "rec-let" "let x = 1; y = x + 1; in y" (VInt 2) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Attribute sets +-- --------------------------------------------------------------------------- + +testEvalAttrs :: IO [Bool] +testEvalAttrs = do + putStrLn "eval/attrs" + sequence + [ runTest "simple select" $ + assertEval "select" "{ a = 1; }.a" (VInt 1), + runTest "nested select" $ + assertEval "nested" "{ a = { b = 2; }; }.a.b" (VInt 2), + runTest "select or default" $ + assertEval "default" "{ a = 1; }.b or 42" (VInt 42), + runTest "has-attr true" $ + assertEval "has-true" "{ a = 1; } ? a" (VBool True), + runTest "has-attr false" $ + assertEval "has-false" "{ a = 1; } ? b" (VBool False), + runTest "nested attr path" $ + assertEval "dot-path" "{ a.b.c = 1; }.a.b.c" (VInt 1), + -- A non-set operand of // fails with upstream's evalAttrs message + -- (eval.cc at 2.24.9), checked against nix-instantiate 2.33.2's + -- final error line. tryEval does not catch it. + runTest "update with a null left operand" $ + assertEvalError "update-null-left" "null // {}" "expected a set but found null: null", + runTest "update with a null right operand" $ + assertEvalError "update-null-right" "{} // null" "expected a set but found null: null", + runTest "update with an integer left operand" $ + assertEvalError "update-int-left" "1 // {}" "expected a set but found an integer: 1", + runTest "update with a string right operand" $ + assertEvalError "update-string-right" "{} // \"x\"" "expected a set but found a string: \"x\"", + -- 2.24.9's ExprOpUpdate::eval evaluates and checks the left operand + -- before it evaluates the right; 2.33.2 does the right first. + runTest "update with two non-set operands reports the left" $ + assertEvalError "update-both" "1 // \"x\"" "expected a set but found an integer: 1", + runTest "update refuses a non-set left before evaluating the right" $ + assertEvalError "update-left-first" "builtins.tryEval (null // throw \"b\")" "expected a set but found null: null", + runTest "update with a set left evaluates a throwing right" $ + assertEval "update-right-throws" "(builtins.tryEval ({} // throw \"b\")).success" (VBool False), + runTest "update evaluates a throwing left first" $ + assertEvalError "update-left-throws" "throw \"a\" // null" "a", + -- builtins.warn forces its message with forceString (prim_warn, + -- primops.cc at 2.24.9); final lines as nix-instantiate 2.33.2 + -- prints them, and tryEval does not catch the refusal. + runTest "warn refuses an integer message" $ + assertEvalError "warn-int" "builtins.warn 1 2" "expected a string but found an integer: 1", + runTest "warn refuses a Boolean message" $ + assertEvalError "warn-bool" "builtins.warn true 2" "expected a string but found a Boolean: true", + runTest "warn refuses a null message" $ + assertEvalError "warn-null" "builtins.warn null 2" "expected a string but found null: null", + runTest "warn refuses a float message" $ + assertEvalError "warn-float" "builtins.warn 1.5 2" "expected a string but found a float: 1.5", + runTest "warn's refusal is not caught by tryEval" $ + assertEvalError "warn-tryeval" "builtins.tryEval (builtins.warn 1 2)" "expected a string but found an integer: 1", + runTest "warn with a string message returns its value" $ + assertEval "warn-string" "builtins.warn \"m\" 2" (VInt 2), + runTest "tryEval does not catch the update error" $ + assertEvalError "update-tryEval" "builtins.tryEval (null // {})" "expected a set but found null: null" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Value printer +-- --------------------------------------------------------------------------- + +testValuePrinter :: IO [Bool] +testValuePrinter = do + putStrLn "eval/print" + tmpBase <- getTemporaryDirectory + let stringFound body = "expected a set but found a string: " <> body + setFound body = "cannot coerce a set to a string: " <> body + listFound body = "cannot coerce a list to a string: " <> body + runOfA n = "builtins.concatStringsSep \"\" (builtins.genList (x: \"a\") " <> T.pack (show (n :: Int)) <> ")" + elided what = " \x00AB" <> what <> " elided\x00BB" + marker inner = "\x00AB" <> inner <> "\x00BB" + interpolated source = "\"${" <> source <> "}\"" + deeplyForced source = "let x = " <> source <> "; in builtins.seq (builtins.deepSeq x null) \"${x}\"" + ints n = map (T.pack . show) [1 .. n :: Int] + listOfInts n = "[ " <> T.concat (map (<> " ") (ints n)) <> "]" + attrsOfInts n = "{ " <> T.concat [name <> " = " <> value <> "; " | (name, value) <- zip letters (ints n)] <> "}" + letters = map T.singleton ['a' ..] + shownInts = T.unwords [name <> " = " <> value <> ";" | (name, value) <- zip letters (ints 10)] + paddedName i = T.pack ('a' : if i < 10 then '0' : show i else show i) + paddedAttrs n = "{ " <> T.concat [paddedName i <> " = " <> T.pack (show i) <> "; " | i <- [1 .. n]] <> "}" + boundedList n = bounded "[" "]" (ints (min n 10)) (n - 10) "item" "items" + boundedAttrs n = + bounded "{" "}" [paddedName i <> " = " <> T.pack (show i) <> ";" | i <- [1 .. min n 10]] (n - 10) "attribute" "attributes" + bounded open close shown left single plural = + open <> " " <> T.concat (map (<> " ") shown) <> leftOut left single plural <> close + leftOut left single plural + | left <= 0 = "" + | left == 1 = marker ("1 " <> single <> " elided") <> " " + | otherwise = marker (T.pack (show left) <> " " <> plural <> " elided") <> " " + quickCheckPasses property = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + sequence + [ -- Values print as upstream's printValue prints them under + -- errorPrintOptions (print.cc and print-options.hh at 2.24.9), each + -- checked against nix-instantiate 2.33.2's final error line. + runTest "a path prints bare" $ + assertEvalError "print-path" "{} // /foo/bar" "expected a set but found a path: /foo/bar", + runTest "a float prints with six significant digits" $ + assertEvalError "print-float" "{} // 1234567.0" "expected a set but found a float: 1.23457e+06", + runTest "a string prints quoted with the lexer's escapes" $ + assertEvalError + "print-escapes" + "{} // \"a\\nb\\\"c$d\\${e}\\t\\r\"" + (stringFound "\"a\\nb\\\"c$d\\${e}\\t\\r\""), + runTest "a string of 1024 bytes prints whole" $ + assertEvalError + "print-1024" + ("{} // " <> runOfA 1024) + (stringFound ("\"" <> T.replicate 1024 "a" <> "\"")), + runTest "a longer string is cut after 1024 bytes" $ + assertEvalError + "print-1025" + ("{} // " <> runOfA 1025) + (stringFound ("\"" <> T.replicate 1024 "a" <> "\"" <> elided "1 byte")), + runTest "the bytes cut are counted" $ + assertEvalError + "print-1100" + ("{} // " <> runOfA 1100) + (stringFound ("\"" <> T.replicate 1024 "a" <> "\"" <> elided "76 bytes")), + runTest "a dollar shown last is escaped when the brace after it was cut" $ + assertEvalError + "print-cut-dollar" + ("{} // (" <> runOfA 1023 <> " + \"\\${\")") + (stringFound ("\"" <> T.replicate 1023 "a" <> "\\$\"" <> elided "1 byte")), + -- A set or list prints its entries, nothing forced, and is cut + -- once the print has shown ten attributes or ten items in all. + runTest "a set prints its attributes by name" $ + assertEvalError "print-set" "\"${{ b = \"s\"; a = 1; }}\"" (setFound "{ a = 1; b = \"s\"; }"), + runTest "an empty set prints as a pair of braces" $ + assertEvalError "print-empty-set" "\"${{}}\"" (setFound "{ }"), + runTest "_type and type print ahead of the other attributes" $ + assertEvalError + "print-important-first" + "\"${{ z = 1; type = 2; _type = 3; a = 4; }}\"" + (setFound "{ _type = 3; type = 2; a = 4; z = 1; }"), + runTest "an attribute name the lexer cannot read bare prints quoted" $ + assertEvalError + "print-quoted-names" + "\"${{ \"a b\" = 1; \"if\" = 2; \"\" = 3; }}\"" + (setFound "{ \"\" = 3; \"a b\" = 1; \"if\" = 2; }"), + runTest "an attribute never forced prints as upstream's thunk marker" $ + assertEvalError "print-thunk" "\"${{ a = 1 + 1; }}\"" (setFound ("{ a = " <> marker "thunk" <> "; }")), + runTest "an eleventh attribute is counted, not shown" $ + assertEvalError + "print-11-attrs" + (interpolated (attrsOfInts 11)) + (setFound ("{ " <> shownInts <> " " <> marker "1 attribute elided" <> " }")), + runTest "attributes past the tenth are counted together" $ + assertEvalError + "print-12-attrs" + (interpolated (attrsOfInts 12)) + (setFound ("{ " <> shownInts <> " " <> marker "2 attributes elided" <> " }")), + runTest "an empty list prints as a pair of brackets" $ + assertEvalError "print-empty-list" "\"${[ ]}\"" (listFound "[ ]"), + runTest "an eleventh item is counted, not shown" $ + assertEvalError + "print-11-items" + (interpolated (listOfInts 11)) + (listFound ("[ 1 2 3 4 5 6 7 8 9 10 " <> marker "1 item elided" <> " ]")), + runTest "items past the tenth are counted together" $ + assertEvalError + "print-12-items" + (interpolated (listOfInts 12)) + (listFound ("[ 1 2 3 4 5 6 7 8 9 10 " <> marker "2 items elided" <> " ]")), + runTestM "a list shows ten items and counts the rest" $ + quickCheckPasses $ + QC.forAll (QC.chooseInt (0, 25)) $ \n -> + evalNix (interpolated (listOfInts n)) QC.=== Left (listFound (boundedList n)), + runTestM "a set shows ten attributes and counts the rest" $ + quickCheckPasses $ + QC.forAll (QC.chooseInt (0, 25)) $ \n -> + evalNix (interpolated (paddedAttrs n)) QC.=== Left (setFound (boundedAttrs n)), + -- Forced values need the IO evaluator, which keeps them. + runTestM "a nested set's attributes count before the attribute holding it" $ + assertEvalErrorIO + tmpBase + "print-nested-count" + (deeplyForced "{ a = { b = 1; c = 2; d = 3; e = 4; f = 5; g = 6; }; h = 7; i = 8; j = 9; k = 10; l = 11; }") + (setFound ("{ a = { b = 1; c = 2; d = 3; e = 4; f = 5; g = 6; }; h = 7; i = 8; j = 9; " <> marker "2 attributes elided" <> " }")), + runTestM "list items count over the whole print" $ + assertEvalErrorIO + tmpBase + "print-items-across-lists" + (deeplyForced "{ a = [ 1 2 3 4 5 6 7 8 9 ]; b = [ 10 11 12 ]; }") + (setFound ("{ a = [ 1 2 3 4 5 6 7 8 9 ]; b = [ 10 " <> marker "2 items elided" <> " ]; }")), + runTestM "a set nested ten deep prints as an ellipsis" $ + assertEvalErrorIO + tmpBase + "print-deep-set" + (deeplyForced (T.replicate 12 "{ a = " <> "1" <> T.replicate 12 "; }")) + (setFound (T.replicate 10 "{ a = " <> "{ ... }" <> T.replicate 10 "; }")), + runTestM "a list nested ten deep prints as an ellipsis" $ + assertEvalErrorIO + tmpBase + "print-deep-list" + (deeplyForced (T.replicate 12 "[ " <> "1" <> T.replicate 12 " ]")) + (listFound (T.replicate 10 "[ " <> "[ ... ]" <> T.replicate 10 " ]")), + runTestM "an attribute being forced prints as upstream's recursion marker" $ + assertEvalErrorIO + tmpBase + "print-blackhole" + "let x = { a = \"${x}\"; }; in x.a" + (setFound ("{ a = " <> marker "potential infinite recursion" <> "; }")), + runTest "a primop prints as upstream's primop marker" $ + assertEvalError + "print-primop" + "{} // builtins.map" + ("expected a set but found the built-in function 'map': " <> marker "primop map"), + runTest "a partially applied primop prints as upstream's marker" $ + assertEvalError + "print-primop-app" + "{} // builtins.map (x: x)" + ("expected a set but found the partially applied built-in function 'map': " <> marker "partially applied primop map"), + -- builtins.trace's defaults bound nothing and sort only by name. + runTest "a set prints in full by name as trace prints it" + $ assertRight "print-full-set" (evalNix "{ type = 1; a = 2; }") + $ assertEqual "print-full-set" "{ a = 2; type = 1; }" . printValue PrintInFull, + runTest "a long list prints in full as trace prints it" + $ assertRight "print-full-list" (evalNix (listOfInts 12)) + $ assertEqual "print-full-list" "[ 1 2 3 4 5 6 7 8 9 10 11 12 ]" . printValue PrintInFull, + -- builtins.trace prints a non-string through the same printer with + -- upstream's default options. + runTest "a float prints in full as trace prints it" $ + assertEqual "print-full-float" "1.23457e+06" (printValue PrintInFull (VFloat 1234567.0)), + runTestM "a string printed in full reads back as itself" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genEscapable $ \text -> + evalNix (printValue PrintInFull (mkStr text)) QC.=== Right (mkStr text) + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + +-- | Text built from what the string printer escapes (quotes, backslashes, +-- the escaped control characters, a dollar before a brace) among plain and +-- multi-byte characters. @${@ is a piece of its own so the escape that +-- needs lookahead comes up often. +genEscapable :: QC.Gen Text +genEscapable = + T.concat <$> QC.listOf (QC.elements ["\"", "\\", "\n", "\r", "\t", "$", "{", "}", "${", "a", " ", "\233", "\128512"]) + +-- --------------------------------------------------------------------------- +-- Tests: Eval - + and string coercion errors +-- --------------------------------------------------------------------------- + +-- | @+@ and string coercion fail with upstream's messages, those of +-- @ExprConcatStrings::eval@ and @coerceToString@ (eval.cc at 2.24.9): the +-- type as @showType@ names it, and after a failed coercion the value as +-- @errorPrintOptions@ prints it. Each expected message is nix-instantiate +-- 2.33.2's final error line for the same expression. +testCoercionErrors :: IO [Bool] +testCoercionErrors = do + putStrLn "eval/coercion" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-coercion" + setup = createDirectoryIfMissing True (testDir "d") + cleanup = do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + withContext = "\"${builtins.toFile \"a\" \"b\"}\"" + primopMarker = "\x00ABprimop map\x00BB" + failsIO label source expected = runTestM label (assertEvalErrorIO testDir label source expected) + bracket_ setup cleanup . sequence $ + [ -- An integer or float on the left makes + arithmetic, and a right + -- operand that is no number is named. + runTest "an integer plus a string cannot be added" $ + assertEvalError "add-int-string" "1 + \"a\"" "cannot add a string to an integer", + runTest "a float plus a string cannot be added" $ + assertEvalError "add-float-string" "1.0 + \"a\"" "cannot add a string to a float", + runTest "an integer plus null cannot be added" $ + assertEvalError "add-int-null" "1 + null" "cannot add null to an integer", + failsIO "an integer plus a string with context names the context" ("1 + " <> withContext) "cannot add a string with context to an integer", + runTest "an integer plus a primop names the primop" $ + assertEvalError "add-int-primop" "1 + builtins.map" "cannot add the built-in function 'map' to an integer", + runTest "an integer plus a partial application names its primop" $ + assertEvalError + "add-int-primop-app" + "1 + builtins.map (x: x)" + "cannot add the partially applied built-in function 'map' to an integer", + -- Anything else on the left makes + concatenation, each operand + -- coerced as interpolation coerces it. + runTest "a primop on the left does not coerce" $ + assertEvalError "add-primop-int" "builtins.map + 1" ("cannot coerce the built-in function 'map' to a string: " <> primopMarker), + failsIO "a string with context plus an integer refuses the integer" (withContext <> " + 1") "cannot coerce an integer to a string: 1", + runTest "a Boolean on the left fails to coerce rather than to add" $ + assertEvalError "add-bool-int" "true + 1" "cannot coerce a Boolean to a string: true", + runTest "a string plus a float refuses the float" $ + assertEvalError "add-string-float" "\"a\" + 1.5" "cannot coerce a float to a string: 1.5", + runTest "a string plus a list refuses the list" $ + assertEvalError "add-string-list" "\"a\" + [ ]" "cannot coerce a list to a string: [ ]", + runTest "a path plus an integer refuses the integer" $ + assertEvalError "add-path-int" "./d + 1" "cannot coerce an integer to a string: 1", + failsIO + "a path plus a string with context is refused" + ("./d + " <> withContext) + "a string that refers to a store path cannot be appended to a path", + -- The left operand is dealt with before the right is evaluated. + runTest "a set on the left fails before the right is evaluated" $ + assertEvalError "add-left-first" "{} + throw \"b\"" "cannot coerce a set to a string: { }", + runTest "tryEval does not catch a failed coercion" $ + assertEvalError "add-tryEval" "builtins.tryEval ({} + throw \"b\")" "cannot coerce a set to a string: { }", + -- Upstream copies a path into the store only when the left operand + -- is a string, so a set's outPath on the left is its own text. + runTestM "a set on the left contributes its path without a store copy" $ do + result <- evalNixIO testDir "let s = { outPath = ./d; } + \"x\"; in builtins.getContext s == {} && s == toString ./d + \"x\"" + pure (assertRight "add-set-path" result (assertEqual "add-set-path" (VBool True))), + -- Interpolation, toString and concatStringsSep coerce the same way. + runTest "an interpolated set without outPath prints the set" $ + assertEvalError "interp-set" "\"${{ a = 1; b = \"s\"; }}\"" "cannot coerce a set to a string: { a = 1; b = \"s\"; }", + runTest "an interpolated integer is refused" $ + assertEvalError "interp-int" "\"v${1}\"" "cannot coerce an integer to a string: 1", + runTest "toString of a primop is refused" $ + assertEvalError "tostring-primop" "builtins.toString builtins.map" ("cannot coerce the built-in function 'map' to a string: " <> primopMarker), + runTest "toString of a partial application is refused" $ + assertEvalError + "tostring-primop-app" + "builtins.toString (builtins.map (x: x))" + "cannot coerce the partially applied built-in function 'map' to a string: \x00ABpartially applied primop map\x00BB", + -- Upstream prints a lambda's source position after the word, which + -- a nova-nix function value does not carry. + runTest "toString of a lambda is refused" $ + assertEvalError "tostring-lambda" "builtins.toString (x: x)" "cannot coerce a function to a string: \x00ABlambda\x00BB", + runTest "toString of a set without outPath is refused" $ + assertEvalError "tostring-set" "builtins.toString { }" "cannot coerce a set to a string: { }", + runTest "concatStringsSep refuses an integer element" $ + assertEvalError "concatsep-int" "builtins.concatStringsSep \",\" [ 1 ]" "cannot coerce an integer to a string: 1", + -- An interpolated path literal concatenates as + does with a path + -- first, and refuses a context only after every piece coerced. + runTest "a path segment refuses a set" $ + assertEvalError "path-segment-set" "./a${{}}" "cannot coerce a set to a string: { }", + failsIO + "a later path segment that fails to coerce is reported over an earlier one's context" + ("./a${" <> withContext <> "}${1}") + "cannot coerce an integer to a string: 1", + -- A selection path names the type it cannot index as showType does + -- (attr-path.cc at 2.24.9). + runTest "a selection path through a function names it" $ + assertRight "attrpath-functions" (evalNix "{ a = builtins.map; b = builtins.map (x: x); c = x: x; }") $ \root -> + assertEqual + "attrpath-functions" + ( Right + [ Left "the expression selected by the selection path 'a.x' should be a set but is the built-in function 'map'", + Left "the expression selected by the selection path 'b.x' should be a set but is the partially applied built-in function 'map'", + Left "the expression selected by the selection path 'c.x' should be a set but is a function" + ] + ) + (runPureEval (mapM (`selectAttrPath` root) ["a.x", "b.x", "c.x"])) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Result printer +-- --------------------------------------------------------------------------- + +-- | What @nova-nix eval@ prints for a value. Each expected value is the +-- output of @nix-instantiate --eval --readonly-mode -E@ (Nix 2.33.2) for +-- the same expression, less the newline the command writes after it. +testResultPrinter :: IO [Bool] +testResultPrinter = do + putStrLn "eval/print-result" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-print-result" + notUtf8 = "a" <> BS.singleton 0xfc <> "b" + setup = do + createDirectoryIfMissing True testDir + BS.writeFile (testDir "latin1") notUtf8 + cleanup = do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + printsIO label source expected = runTestM label $ do + result <- evalNixIO testDir source + pure (assertRight label result (assertEqual label expected . renderResult)) + prints label source expected = + runTest label (assertRight label (evalNix source) (assertEqual label expected . renderResult)) + floatPrints (source, expected) = + prints ("a float prints in ostream form: " <> source) source expected + bracket_ setup cleanup . sequence $ + [ printsIO + "a string prints its bytes, not U+FFFD for one that is not UTF-8" + "builtins.readFile ./latin1" + ("\"" <> notUtf8 <> "\""), + prints + "a string escapes each of upstream's characters and a dollar before a brace" + "\"\\\" \\\\ \\n \\r \\t \\${ $\"" + "\"\\\" \\\\ \\n \\r \\t \\${ $\"", + prints "a lone dollar prints as it is" "\"$\"" "\"$\"", + prints + "an attribute name past ASCII prints quoted, as its bytes" + "{ \"\233\" = 1; }" + ("{ \"" <> BS.pack [0xc3, 0xa9] <> "\" = 1; }"), + prints + "an attribute name the lexer cannot read bare prints quoted" + "{ \"a b\" = 1; \"if\" = 2; \"\" = 3; \"1x\" = 4; or = 5; \"a-b'\" = 6; _x = 7; \"-a\" = 8; \"'a\" = 9; \"x\\\"y\" = 10; }" + "{ \"\" = 3; \"'a\" = 9; \"-a\" = 8; \"1x\" = 4; _x = 7; \"a b\" = 1; a-b' = 6; \"if\" = 2; or = 5; \"x\\\"y\" = 10; }", + printsIO + "nested lists and sets print their strings and names the same way" + "let v = [ (builtins.readFile ./latin1) { \"b c\" = [ \"$\" \"\\${\" ]; } ]; in builtins.deepSeq v v" + ("[ \"" <> notUtf8 <> "\" { \"b c\" = [ \"$\" \"\\${\" ]; } ]"), + prints "an element never forced prints as upstream's thunk marker" "[ (1 + 1) ]" "[ ]", + prints "a lambda prints as upstream's marker" "x: x" "", + prints "a primop prints as upstream's marker" "builtins.map" "", + prints "a partially applied primop prints as upstream's marker" "builtins.map (x: x)" "", + prints "a regex builtin given its pattern is a partial application" "builtins.match \"a\"" "", + runTestM "a printed string reads back as itself" $ + quickCheckPasses $ + QC.forAll genEscapable $ \text -> + readsBack (renderResult (mkStr text)) (mkStr text), + runTestM "a printed attribute name reads back as itself" $ + quickCheckPasses $ + QC.forAll genAttrName $ \name -> + let attrs = VAttrs (attrSetFromMap (Map.singleton name (evaluated (VInt 1)))) + in readsBack ("builtins.head (builtins.attrNames " <> renderResult attrs <> ")") (mkStr name) + ] + <> map floatPrints floatCases + where + renderResult = BL.toStrict . BB.toLazyByteString . printAmbiguous + readsBack printed expected = case TE.decodeUtf8' printed of + Left _ -> QC.counterexample "the printed bytes are not UTF-8" False + Right source -> evalNix source QC.=== Right expected + quickCheckPasses property = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + -- Upstream unary minus is 0 - x, so -0.0 written as a literal is + -- positive zero there; fromJSON yields a negative one. + floatCases = + [ ("1.0", "1"), + ("1.5", "1.5"), + ("0.1", "0.1"), + ("1.0e20", "1e+20"), + ("1.23456789", "1.23457"), + ("builtins.fromJSON \"-0.0\"", "-0"), + ("1234567.0", "1.23457e+06") + ] + +-- | Attribute names built from what decides whether one prints bare: the +-- identifier characters in and out of first place, the reserved keywords +-- and @or@, which is not one, and characters only a quoted name holds. +genAttrName :: QC.Gen Text +genAttrName = + T.concat <$> QC.listOf (QC.elements ["a", "Z", "_", "0", "'", "-", " ", "\"", "\\", "${", ".", "\233", "if", "in", "inherit", "rec", "or"]) + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Recursive attribute sets +-- --------------------------------------------------------------------------- + +testEvalRecAttrs :: IO [Bool] +testEvalRecAttrs = do + putStrLn "eval/rec-attrs" + sequence + [ runTest "rec self-reference" $ + assertEval "rec-self" "rec { a = 1; b = a + 1; }.b" (VInt 2), + runTest "rec mutual reference" $ + assertEval "rec-mutual" "rec { a = 1; b = a; }.b" (VInt 1), + -- A plain inherit inside a fallback (nested-path) rec/let must reference + -- the OUTER binding, not self-reference into infinite recursion. + runTest "inherit in fallback rec set references outer" $ + assertEval "inherit-fallback-rec" "let n = 7; in (rec { inherit n; a.b = 1; }).n" (VInt 7), + runTest "inherit in fallback let references outer" $ + assertEval "inherit-fallback-let" "let x = 5; in let a.b = 1; inherit x; in x" (VInt 5), + -- Guard the fix: a genuine sibling reference in a fallback rec still resolves. + runTest "sibling reference survives in fallback rec" $ + assertEval "sibling-fallback-rec" "(rec { a = 1; b = a + 10; c.d = 2; }).b" (VInt 11), + -- Dynamic rec-set keys evaluate in the rec env (C++ Nix env2): a key may + -- reference an enclosing var or a static sibling, and must not abort. + runTest "dynamic key references enclosing var" $ + assertEval "dyn-key-enclosing" "let k = \"x\"; in (rec { p.q = 1; ${k} = 2; }).x" (VInt 2), + runTest "dynamic key resolves the correct enclosing slot" $ + assertEval "dyn-key-slot" "let a = \"A\"; b = \"B\"; in let c = \"C\"; in (rec { p.q = 1; ${b} = 2; }).B" (VInt 2), + runTest "dynamic key references a static rec sibling" $ + assertEval "dyn-key-sibling" "(rec { a = \"b\"; ${a} = 1; }).b" (VInt 1) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Lists +-- --------------------------------------------------------------------------- + +testEvalLists :: IO [Bool] +testEvalLists = do + putStrLn "eval/lists" + sequence + [ runTest "list head" $ + assertEval "head" "builtins.head [ 1 2 3 ]" (VInt 1), + runTest "list length" $ + assertEval "length" "builtins.length [ 1 2 3 ]" (VInt 3), + runTest "list concat" $ + assertEval "concat" "builtins.length ([ 1 ] ++ [ 2 3 ])" (VInt 3), + runTest "head forces only the first element" $ + assertEval "head-lazy" "builtins.head [ 1 (throw \"x\") ]" (VInt 1), + runTest "tail keeps every element after the first" $ + assertEval "tail" "builtins.tail [ 1 2 3 ] == [ 2 3 ]" (VBool True), + runTest "tail of a tail" $ + assertEval "tail-tail" "builtins.tail (builtins.tail [ 1 2 3 ]) == [ 3 ]" (VBool True), + runTest "tail of a one-element list is empty" $ + assertEval "tail-one" "builtins.tail [ 1 ] == [ ]" (VBool True), + runTest "tail forces none of the elements" $ + assertEval "tail-lazy" "builtins.length (builtins.tail [ (throw \"a\") (throw \"b\") ])" (VInt 1), + runTest "head of a tail" $ + assertEval "head-tail" "builtins.head (builtins.tail [ 1 2 3 ])" (VInt 2), + -- The messages 2.24.9 raises: head is its elemAt at index 0 and + -- tail has its own (primops.cc), a non-list fails in forceList + -- (eval-inline.hh), and tryEval catches neither. 2.26.0 reworded + -- both empty-list messages, so nix-instantiate 2.33.2 prints + -- "'builtins.head' called on an empty list" and the same for tail. + runTest "head of an empty list" $ + assertEvalError "head-empty" "builtins.head [ ]" "list index 0 is out of bounds", + runTest "tail of an empty list" $ + assertEvalError "tail-empty" "builtins.tail [ ]" "'tail' called on an empty list", + runTest "head of the empty list tail returns" $ + assertEvalError "head-tail-empty" "builtins.head (builtins.tail [ 1 ])" "list index 0 is out of bounds", + runTest "tail of the empty list tail returns" $ + assertEvalError "tail-tail-empty" "builtins.tail (builtins.tail [ 1 ])" "'tail' called on an empty list", + runTest "head of an integer" $ + assertEvalError "head-int" "builtins.head 1" "expected a list but found an integer: 1", + runTest "head of a string" $ + assertEvalError "head-string" "builtins.head \"x\"" "expected a list but found a string: \"x\"", + runTest "tail of null" $ + assertEvalError "tail-null" "builtins.tail null" "expected a list but found null: null", + runTest "tail of a Boolean" $ + assertEvalError "tail-bool" "builtins.tail true" "expected a list but found a Boolean: true", + runTest "tryEval does not catch head of an empty list" $ + assertEvalError "head-empty-tryeval" "builtins.tryEval (builtins.head [ ])" "list index 0 is out of bounds", + runTest "tryEval does not catch tail of a non-list" $ + assertEvalError "tail-int-tryeval" "builtins.tryEval (builtins.tail 1)" "expected a list but found an integer: 1", + runTest "length of an integer" $ + assertEvalError "length-int" "builtins.length 1" "expected a list but found an integer: 1", + runTest "length of null" $ + assertEvalError "length-null" "builtins.length null" "expected a list but found null: null", + runTestM "drop and index on a C list agree with the materialized list" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genCase $ \(values, drops, index) -> + QC.ioProperty $ do + ptrs <- mapM cthunkNewComputedInt values + let dropped = foldl' (flip clistDrop) (clistFromThunks ptrs) drops + model = foldl' (flip drop) ptrs drops + modelAt i + | i < 0 = Nothing + | otherwise = listToMaybe (drop i model) + pure $ + (clistThunks dropped, clistLen dropped, clistIndex dropped index) + QC.=== (model, length model, modelAt index) + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + where + -- Short lists and a few drops, so the drops and the index land on + -- both sides of the bounds, negatives included. + genCount = QC.choose (-2, 12) + genCase = (,,) <$> QC.resize 10 (QC.listOf QC.arbitrary) <*> QC.resize 4 (QC.listOf genCount) <*> genCount + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Lambda +-- --------------------------------------------------------------------------- + +testEvalLambda :: IO [Bool] +testEvalLambda = do + putStrLn "eval/lambda" + sequence + [ runTest "identity" $ + assertEval "id" "(x: x) 42" (VInt 42), + runTest "closure" $ + assertEval "closure" "let f = x: x + 1; in f 5" (VInt 6), + runTest "set pattern" $ + assertEval "set-pat" "({ a, b }: a + b) { a = 1; b = 2; }" (VInt 3), + runTest "default param" $ + assertEval "default" "({ a ? 10 }: a) { }" (VInt 10), + -- Zero-formal set patterns marshal count 0 / entries NULL; the + -- second force of the same lambda thunk re-reads the entries and + -- must not underflow the unsigned count. + runTest "empty formals forced twice" $ + assertEval "empty-formals" "let f = {}: 1; in f {} + f {}" (VInt 2), + runTest "ellipsis-only formals forced twice" $ + assertEval "ellipsis-only" "let f = { ... }: 1; in f {} + f {}" (VInt 2), + runTest "named empty formals forced twice" $ + assertEval "named-empty" "let f = args@{ ... }: 1; in f {} + f {}" (VInt 2) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - With +-- --------------------------------------------------------------------------- + +testEvalWith :: IO [Bool] +testEvalWith = do + putStrLn "eval/with" + sequence + [ runTest "with basic" $ + assertEval "with" "with { a = 1; }; a" (VInt 1), + runTest "with lexical wins" $ + assertEval "lexical" "let a = 1; in with { a = 2; }; a" (VInt 1), + -- EWithVar: with-scoped variable inside lambda (closure trimming must preserve with-scopes) + runTest "with inside lambda" $ + assertEval + "with-lambda" + "with { a = 1; }; let f = x: a + x; in f 2" + (VInt 3), + -- Nested with: inner with wins + runTest "nested with inner wins" $ + assertEval + "nested-with" + "with { a = 1; }; with { a = 2; }; a" + (VInt 2), + -- Let shadows with + runTest "let shadows with" $ + assertEval + "let-shadows-with" + "with { a = 1; }; let a = 2; in a" + (VInt 2), + -- A fallback (nested-path) let/rec binding shadows with too: the + -- NameBarrier must not be upgraded to a with-variable. + runTest "barrier let shadows with" $ + assertEval + "barrier-shadows-with" + "let a.b = 1; x = 42; in with { x = 99; }; x" + (VInt 42), + runTest "barrier rec binding shadows with" $ + assertEval + "barrier-rec-shadows-with" + "with { q = 99; }; (rec { c.d = 1; q = 5; b = q; }).b" + (VInt 5), + -- Static globals bind at parse time; with never shadows them. + runTest "with cannot shadow global map" $ + assertEval + "with-global-map" + "builtins.typeOf (with { map = 42; }; map)" + (mkStr "lambda"), + -- fetchurl is NOT an upstream global: the with-scope must win, or + -- nixpkgs-style 'with pkgs; fetchurl' would bind the builtin. + runTest "with shadows non-global fetchurl" $ + assertEval + "with-fetchurl" + "with { fetchurl = 42; }; fetchurl" + (VInt 42), + -- Builtin fallback: builtins still accessible inside with + runTest "with builtin fallback" $ + assertEval + "with-builtin" + "with { a = 1; }; true" + (VBool True), + -- Builtin attr fallback: builtins.length still works inside with + runTest "with builtin attr fallback" $ + assertEval + "with-builtin-attr" + "with { a = 1; }; builtins.length [1 2 3]" + (VInt 3), + -- With in rec attrs + runTest "with in rec attrs" $ + assertEval + "with-rec" + "with { a = 1; }; rec { b = a + 1; c = b + 1; }.c" + (VInt 3), + -- AST test: parse "with a; b" produces EWithVar + runTest "parse with produces EWithVar" $ + assertRight "with-ast" (parseNixWithScope (withGlobals ["a"]) testBaseDir testOrigin "with a; b") $ \case + EWith (EVar "a") (EWithVar "b") -> Pass + other -> Fail ("expected EWith (EVar a) (EWithVar b), got: " <> T.pack (show other)), + -- AST test: formal wins over with + runTest "parse lambda formal wins over with" $ + assertRight "formal-wins" (parseNixWithScope (withGlobals ["a"]) testBaseDir testOrigin "x: with a; x") $ \case + ELambda _ (EWith _ (EResolvedVar 0 0)) _ -> Pass + other -> Fail ("expected formal to win, got: " <> T.pack (show other)), + -- Trimming test: lambda inside with gets CapturesWithScopes + runTest "with lambda trimmed with CapturesWithScopes" $ + assertRight "with-trim" (parseNixWithScope (withGlobals ["a"]) testBaseDir testOrigin "with a; x: b + x") $ \case + EWith _ (ELambda _ _ (CapturesWithScopes _)) -> Pass + other -> Fail ("expected CapturesWithScopes, got: " <> T.pack (show other)) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Builtins +-- --------------------------------------------------------------------------- + +testEvalBuiltins :: IO [Bool] +testEvalBuiltins = do + putStrLn "eval/builtins" + sequence + [ runTest "typeOf int" $ + assertEval "typeOf-int" "builtins.typeOf 42" (mkStr "int"), + runTest "typeOf string" $ + assertEval "typeOf-str" "builtins.typeOf \"hi\"" (mkStr "string"), + runTest "isNull true" $ + assertEval "isNull-t" "builtins.isNull null" (VBool True), + runTest "isNull false" $ + assertEval "isNull-f" "builtins.isNull 1" (VBool False), + runTest "stringLength" $ + assertEval "strlen" "builtins.stringLength \"hello\"" (VInt 5), + runTest "a builtin taking a string coerces a set as upstream's coerceToString" $ + assertEval "strlen-outpath" "builtins.stringLength { outPath = \"abc\"; }" (VInt 3) + `andThen` assertEval "strlen-tostring" "builtins.stringLength { __toString = s: \"ab\"; }" (VInt 2) + `andThen` assertEval "substring-outpath" "builtins.substring 1 1 { outPath = \"abc\"; }" (mkStr "b") + `andThen` assertEval "discard-outpath" "builtins.unsafeDiscardStringContext { outPath = \"abc\"; }" (mkStr "abc") + `andThen` assertEval "discard-output-outpath" "builtins.unsafeDiscardOutputDependency { outPath = \"abc\"; }" (mkStr "abc"), + runTest "a builtin taking a string refuses what coerceToString refuses" $ + assertEvalError "strlen-int" "builtins.stringLength 1" "cannot coerce an integer to a string: 1" + `andThen` assertEvalError "substring-int" "builtins.substring 0 1 1" "cannot coerce an integer to a string: 1" + `andThen` assertEvalError "discard-int" "builtins.unsafeDiscardStringContext 1" "cannot coerce an integer to a string: 1" + `andThen` assertEvalError "discard-output-int" "builtins.unsafeDiscardOutputDependency 1" "cannot coerce an integer to a string: 1" + `andThen` assertEvalError "add-output-int" "builtins.addDrvOutputDependencies 1" "cannot coerce an integer to a string: 1", + -- Lexer edge cases pinned to upstream: $${ is literal, ''' escapes to '', \q -> q. + runTest "$${ does not interpolate (double dollar is literal)" $ + assertEval "dollar-dollar-str" "builtins.stringLength \"a$${b}c\"" (VInt 7), + runTest "$${ literal in indented string" $ + assertEval "dollar-dollar-ind" "builtins.stringLength ''a$${b}c''" (VInt 7), + runTest "''' escapes two quotes in indented string" $ + assertEval "triple-quote" "''a'''b'' == \"a''b\"" (VBool True), + runTest "unknown escape drops backslash (regular string)" $ + assertEval "esc-drop-str" "\"a\\qb\" == \"aqb\"" (VBool True), + runTest "unknown escape drops backslash (indented string)" $ + assertEval "esc-drop-ind" "''a''\\qb'' == \"aqb\"" (VBool True), + -- Indentation stripping is upstream's stripIndentation rule for + -- rule (parser-state.hh at 2.24.9), every case checked against + -- nix-instantiate 2.33.2. The scan skips an escape, so the spaces + -- after an escaped newline are never measured; the strip runs over + -- escapes like any literal, so those spaces are stripped by the + -- minimum measured elsewhere. An interpolation is opaque to both. + runTest "escaped newline: following spaces are stripped, not measured" $ + assertEval "ind-esc-nl-strip" "'' a''\\n b''" (mkStr "a\nb"), + runTest "escaped newline: a shallower line after it is not the minimum" $ + assertEval "ind-esc-nl-indent" "''\n x''\\n y\n z''" (mkStr "x\ny\nz"), + runTest "escaped newline at line start keeps the next line stripped" $ + assertEval "ind-esc-nl-start" "''\n ''\\n b''" (mkStr "\nb"), + runTest "interpolated newline leaves the next chunk mid-line" $ + assertEval "ind-interp-nl" "''\n ${\"\\n\"} b''" (mkStr "\n b"), + -- The minimum starts at a sentinel, so a string with no measured + -- line loses every leading space (#220). + runTest "blank line then a spaces-only line strips to the newline" $ + assertEval "ind-blank-spaces" "''\n\n ''" (mkStr "\n"), + runTest "spaces-only line strips to nothing" $ + assertEval "ind-spaces-only" "''\n ''" (mkStr ""), + runTest "spaces between opener and closer strip to nothing" $ + assertEval "ind-spaces-same-line" "'' ''" (mkStr ""), + -- Only a space is indentation: a tab fixes the minimum at its + -- column and survives. + runTest "tabs are content, not indentation" $ + assertEval "ind-tabs" "''\n\t\ta\n\t\tb\n''" (mkStr "\t\ta\n\t\tb\n"), + runTest "a tab after the opener is content" $ + assertEval "ind-opener-tab" "''\t\n a\n''" (mkStr "\t\n a\n"), + -- The last part sheds a final line of spaces after stripping; the + -- rule runs on that part alone. + runTest "closing indentation after a blank line is dropped" $ + assertEval "ind-closer-spaces" "''\n a\n\n ''" (mkStr "a\n\n"), + runTest "closing indentation after an interpolation is dropped" $ + assertEval "ind-closer-after-interp" "''\n ${\"v\"}\n ''" (mkStr "v\n"), + runTest "spaces after an interpolation on the last line survive" $ + assertEval "ind-interp-last-line" "''\n ${\"v\"} ''" (mkStr "v "), + -- The opener consumes its own line's trailing spaces and newline. + runTest "spaces before the opener's newline are not a line" $ + assertEval "ind-opener-spaces" "'' \n a\n''" (mkStr "a\n"), + runTest "an opener line of spaces then the closer is empty" $ + assertEval "ind-opener-only" "'' \n''" (mkStr ""), + runTest "toString int" $ + assertEval "toStr" "builtins.toString 42" (mkStr "42") + ] + +-- | A list coerced to a string, as upstream's @coerceToString@ joins one +-- under @coerceMore@ (eval.cc at 2.24.9). Each expected string is +-- nix-instantiate 2.24.9's. +testListCoercion :: IO [Bool] +testListCoercion = do + putStrLn "eval/list-coercion" + let joins label source expected = runTest label (assertEval label ("builtins.toString " <> source) (mkStr expected)) + bytes = BS.pack <$> QC.listOf QC.arbitrary + quickCheckPasses property = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + sequence + [ joins "elements are joined with spaces" "[ 1 \"a\" 2 ]" "1 a 2", + joins "an empty list element takes no space after it" "[ [ ] 1 ]" "1", + joins "an empty list between two elements leaves one space" "[ 1 [ ] 2 ]" "1 2", + joins "an element before an empty list keeps its space" "[ 1 [ ] ]" "1 ", + joins "a list holding an empty list is not empty" "[ [ [ ] ] 1 ]" " 1", + joins "an empty string element keeps its space" "[ \"\" 1 ]" " 1", + joins "nested lists flatten through the same join" "[ [ 1 [ 2 3 ] ] 4 ]" "1 2 3 4", + joins "a __toString may return a list" "{ __toString = s: [ 1 2 ]; }" "1 2", + joins "an outPath may be a list" "{ outPath = [ 1 2 ]; }" "1 2", + joins "an element whose __toString is an empty list keeps its space" "[ { __toString = s: [ ]; } 1 ]" " 1", + runTest "interpolation still refuses a list" $ + assertEvalError "interp-list" "\"${[ 1 2 ]}\"" "cannot coerce a list to a string: [ 1 2 ]", + runTestM "without empty lists the join is intercalate" $ + quickCheckPasses $ + QC.forAll (QC.listOf bytes) $ \parts -> + joinCoercedList [(part, False) | part <- parts] QC.=== BS.intercalate " " parts, + runTestM "an empty list before any element changes nothing" $ + quickCheckPasses $ + QC.forAll (QC.listOf bytes) $ \before -> + QC.forAll (QC.listOf1 bytes) $ \after -> + let marked = map (,False) + in joinCoercedList (marked before <> [("", True)] <> marked after) QC.=== joinCoercedList (marked (before <> after)) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Errors +-- --------------------------------------------------------------------------- + +testEvalErrors :: IO [Bool] +testEvalErrors = do + putStrLn "eval/errors" + sequence + [ runTest "type error in add (set + list)" $ + assertEvalFail "type-add" "{} + []", + runTest "call non-function" $ + assertEvalFail "call-non" "42 1", + runTest "builtins.throw" $ + assertEvalFail "throw" "builtins.throw \"boom\"" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Higher-order builtins +-- --------------------------------------------------------------------------- + +testEvalHigherOrder :: IO [Bool] +testEvalHigherOrder = do + putStrLn "eval/higher-order" + sequence + [ -- map + runTest "map basic" $ + assertEval "map" "builtins.map (x: x + 1) [ 1 2 3 ] == [ 2 3 4 ]" (VBool True), + runTest "map identity" $ + assertEval "map-id" "builtins.map (x: x) [ 1 2 ] == [ 1 2 ]" (VBool True), + runTest "map empty" $ + assertEval "map-empty" "builtins.map (x: x) [ ]" (VList emptyCList), + runTest "map lazy" $ + assertEval "map-lazy" "let xs = builtins.map (x: x * 2) [ 1 (throw \"boom\") 3 ]; in builtins.elemAt xs 0" (VInt 2), + -- filter + runTest "filter match" $ + assertEval "filter" "builtins.filter (x: x == 2) [ 1 2 3 ] == [ 2 ]" (VBool True), + runTest "filter none" $ + assertEval "filter-none" "builtins.filter (x: false) [ 1 2 ] == [ ]" (VBool True), + -- foldl' + runTest "foldl' sum" $ + assertEval "foldl-sum" "builtins.foldl' (a: b: a + b) 0 [ 1 2 3 ]" (VInt 6), + runTest "foldl' string concat" $ + assertEval "foldl-str" "builtins.foldl' (a: b: a + b) \"\" [ \"x\" \"y\" \"z\" ]" (mkStr "xyz"), + runTest "foldl' empty" $ + assertEval "foldl-empty" "builtins.foldl' (a: b: a + b) 0 [ ]" (VInt 0), + -- genList + runTest "genList basic" $ + assertEval "genList" "builtins.genList (i: i * 2) 4 == [ 0 2 4 6 ]" (VBool True), + runTest "genList zero" $ + assertEval "genList-0" "builtins.genList (i: i) 0" (VList emptyCList), + runTest "genList lazy" $ + assertEval "genList-lazy" "let xs = builtins.genList (i: if i == 0 then 42 else throw \"boom\") 5; in builtins.elemAt xs 0" (VInt 42), + -- sort + runTest "sort ints" $ + assertEval "sort" "builtins.sort (a: b: a < b) [ 3 1 2 ] == [ 1 2 3 ]" (VBool True), + runTest "sort already sorted" $ + assertEval "sort-sorted" "builtins.sort (a: b: a < b) [ 1 2 3 ] == [ 1 2 3 ]" (VBool True), + -- Stable: comparator-equal elements keep their input order (std::stable_sort). + runTest "sort is stable across ties" $ + assertEval + "sort-stable" + "builtins.sort (a: b: a.k < b.k) [ { k = 1; v = 1; } { k = 0; v = 2; } { k = 1; v = 3; } { k = 0; v = 4; } ] == [ { k = 0; v = 2; } { k = 0; v = 4; } { k = 1; v = 1; } { k = 1; v = 3; } ]" + (VBool True), + runTest "sort preserves order of all-equal elements" $ + assertEval + "sort-stable-all" + "builtins.sort (a: b: a.k < b.k) [ { k = 0; v = 1; } { k = 0; v = 2; } { k = 0; v = 3; } ] == [ { k = 0; v = 1; } { k = 0; v = 2; } { k = 0; v = 3; } ]" + (VBool True), + -- concatMap + runTest "concatMap" $ + assertEval "concatMap" "builtins.concatMap (x: [ x (x * 2) ]) [ 1 2 ] == [ 1 2 2 4 ]" (VBool True), + -- any + runTest "any true" $ + assertEval "any-t" "builtins.any (x: x == 2) [ 1 2 3 ]" (VBool True), + runTest "any false" $ + assertEval "any-f" "builtins.any (x: x == 5) [ 1 2 3 ]" (VBool False), + -- all + runTest "all true" $ + assertEval "all-t" "builtins.all (x: x > 0) [ 1 2 3 ]" (VBool True), + runTest "all false" $ + assertEval "all-f" "builtins.all (x: x > 1) [ 1 2 3 ]" (VBool False), + -- elem + runTest "elem found" $ + assertEval "elem-t" "builtins.elem 2 [ 1 2 3 ]" (VBool True), + runTest "elem not found" $ + assertEval "elem-f" "builtins.elem 5 [ 1 2 3 ]" (VBool False), + -- elemAt + runTest "elemAt valid" $ + assertEval "elemAt" "builtins.elemAt [ 10 20 30 ] 1" (VInt 20), + -- The messages 2.24.9 raises (elemAt in primops.cc, forceInt in + -- eval.cc, forceList in eval-inline.hh). The index is forced and + -- checked before the list. 2.26.0 reworded the bounds message; + -- 2.33.2 prints "'builtins.elemAt' called with index 5 on a list of + -- size 2". + runTest "elemAt past the end" $ + assertEvalError "elemAt-oob" "builtins.elemAt [ 1 2 ] 5" "list index 5 is out of bounds", + runTest "elemAt at the length" $ + assertEvalError "elemAt-length" "builtins.elemAt [ 1 2 ] 2" "list index 2 is out of bounds", + runTest "elemAt negative index" $ + assertEvalError "elemAt-negative" "builtins.elemAt [ 1 2 ] (-1)" "list index -1 is out of bounds", + runTest "elemAt on an empty list" $ + assertEvalError "elemAt-empty" "builtins.elemAt [ ] 0" "list index 0 is out of bounds", + runTest "elemAt of a non-list" $ + assertEvalError "elemAt-int" "builtins.elemAt 1 0" "expected a list but found an integer: 1", + runTest "elemAt with a string index" $ + assertEvalError "elemAt-string-index" "builtins.elemAt [ 1 2 ] \"x\"" "expected an integer but found a string: \"x\"", + runTest "elemAt checks the index before the list" $ + assertEvalError "elemAt-index-first" "builtins.elemAt 1 \"x\"" "expected an integer but found a string: \"x\"", + -- partition + runTest "partition right" $ + assertEval "partition-right" "(builtins.partition (x: x > 2) [ 1 2 3 4 ]).right == [ 3 4 ]" (VBool True), + runTest "partition wrong" $ + assertEval "partition-wrong" "(builtins.partition (x: x > 2) [ 1 2 3 4 ]).wrong == [ 1 2 ]" (VBool True), + -- groupBy + runTest "groupBy pos" $ + assertEval "groupBy-pos" "(builtins.groupBy (x: if x > 0 then \"pos\" else \"neg\") [ 1 (- 2) 3 ]).pos == [ 1 3 ]" (VBool True), + runTest "groupBy neg" $ + assertEval "groupBy-neg" "(builtins.groupBy (x: if x > 0 then \"pos\" else \"neg\") [ 1 (- 2) 3 ]).neg == [ (- 2) ]" (VBool True), + -- attrNames + runTest "attrNames sorted" $ + assertEval "attrNames" "builtins.attrNames { b = 2; a = 1; c = 3; } == [ \"a\" \"b\" \"c\" ]" (VBool True), + -- attrValues + runTest "attrValues count" $ + assertEval "attrValues" "builtins.length (builtins.attrValues { a = 1; b = 2; })" (VInt 2), + -- hasAttr + runTest "hasAttr true" $ + assertEval "hasAttr-t" "builtins.hasAttr \"a\" { a = 1; }" (VBool True), + runTest "hasAttr false" $ + assertEval "hasAttr-f" "builtins.hasAttr \"z\" { a = 1; }" (VBool False), + -- getAttr + runTest "getAttr" $ + assertEval "getAttr" "builtins.getAttr \"a\" { a = 42; }" (VInt 42), + runTest "getAttr missing" $ + assertEvalFail "getAttr-miss" "builtins.getAttr \"z\" { a = 1; }", + -- removeAttrs + runTest "removeAttrs" $ + assertEval "removeAttrs" "builtins.attrNames (builtins.removeAttrs { a = 1; b = 2; c = 3; } [ \"b\" ]) == [ \"a\" \"c\" ]" (VBool True), + -- intersectAttrs + runTest "intersectAttrs" $ + assertEval "intersectAttrs" "(builtins.intersectAttrs { a = 1; b = 2; } { b = 20; c = 30; }).b" (VInt 20), + runTest "intersectAttrs keys" $ + assertEval "intersectAttrs-keys" "builtins.attrNames (builtins.intersectAttrs { a = 1; b = 2; } { b = 20; c = 30; }) == [ \"b\" ]" (VBool True), + -- catAttrs + runTest "catAttrs" $ + assertEval "catAttrs" "builtins.catAttrs \"a\" [ { a = 1; } { b = 2; } { a = 3; } ] == [ 1 3 ]" (VBool True), + -- listToAttrs + runTest "listToAttrs" $ + assertEval "listToAttrs" "(builtins.listToAttrs [ { name = \"x\"; value = 1; } { name = \"y\"; value = 2; } ]).x" (VInt 1), + -- substring + runTest "substring basic" $ + assertEval "substr" "builtins.substring 1 2 \"hello\"" (mkStr "el"), + runTest "substring clamped" $ + assertEval "substr-clamp" "builtins.substring 3 100 \"hello\"" (mkStr "lo"), + -- concatStringsSep + runTest "concatStringsSep" $ + assertEval "concatSep" "builtins.concatStringsSep \", \" [ \"a\" \"b\" \"c\" ]" (mkStr "a, b, c"), + -- Partial application + runTest "partial application" $ + assertEval "partial" "let f = builtins.map (x: x + 1); in f [ 1 2 3 ] == [ 2 3 4 ]" (VBool True) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Builtin argument order +-- --------------------------------------------------------------------------- + +-- | A primop that forces an argument later than it is applied takes it +-- unforced and forces it where upstream does. Each expectation follows +-- upstream's primops.cc and eval.cc at 2.24.9: with only the first +-- argument throwing, a collection that is empty never forces it, and +-- with both throwing, the argument upstream forces first is the error. +testBuiltinArgumentOrder :: IO [Bool] +testBuiltinArgumentOrder = do + putStrLn "eval/builtin-argument-order" + let yields source expected = runTest source (assertEval source source expected) + fails source expected = runTest (source <> " fails with " <> expected) (assertEvalError source source expected) + sequence $ + [ yields "map (throw \"a\") [ ]" (VList emptyCList), + yields "builtins.filter (throw \"a\") [ ]" (VList emptyCList), + yields "builtins.sort (throw \"a\") [ ]" (VList emptyCList), + yields "builtins.mapAttrs (throw \"a\") { } == { }" (VBool True), + yields "builtins.elem (throw \"a\") [ ]" (VBool False) + ] + <> [ fails source "b" + | source <- + [ "map (throw \"a\") (throw \"b\")", + "builtins.filter (throw \"a\") (throw \"b\")", + "builtins.genList (throw \"a\") (throw \"b\")", + "builtins.sort (throw \"a\") (throw \"b\")", + "builtins.mapAttrs (throw \"a\") (throw \"b\")", + "builtins.elem (throw \"a\") (throw \"b\")", + "builtins.elemAt (throw \"a\") (throw \"b\")", + "builtins.filterSource (throw \"a\") (throw \"b\")", + "builtins.scopedImport (throw \"a\") (throw \"b\")" + ] + ] + <> [ -- genList forces its function even for no elements, and elem + -- forces the needle before the element it compares. + fails "builtins.genList (throw \"a\") 0" "a", + fails "builtins.elem (throw \"a\") [ (throw \"b\") ]" "a", + -- mapAttrs never forces its function itself. + yields "builtins.attrNames (builtins.mapAttrs (throw \"a\") { x = 1; }) == [ \"x\" ]" (VBool True), + -- Forced where upstream forces it, a function argument is + -- checked there as forceFunction checks it, functors included. + fails "builtins.length (map 1 [ 1 ])" "expected a function but found an integer: 1", + fails "builtins.length (builtins.genList 1 1)" "expected a function but found an integer: 1", + yields "map { __functor = self: x: x + 1; } [ 1 ] == [ 2 ]" (VBool True), + -- foldl' hands its initial accumulator to the first step + -- unforced, and forces it itself only for an empty list. + yields "builtins.foldl' (acc: x: x) (throw \"a\") [ 1 ]" (VInt 1), + fails "builtins.foldl' (acc: x: x) (throw \"a\") (throw \"c\")" "c", + fails "builtins.foldl' (acc: x: x) (throw \"a\") [ ]" "a", + -- A partial application holds the argument unforced however it + -- is applied: from source, by a higher-order builtin with an + -- unforced element, or with a value already forced. + yields "builtins.typeOf (map (throw \"a\"))" (mkStr "lambda"), + yields "builtins.elemAt (map (map (throw \"a\")) [ [ ] ]) 0 == [ ]" (VBool True), + yields "builtins.all (builtins.elem (throw \"a\")) [ [ ] ]" (VBool False), + yields "builtins.foldl' builtins.elem 1 [ [ 1 ] [ true ] ]" (VBool True) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Lexer +-- --------------------------------------------------------------------------- + +testLexer :: IO [Bool] +testLexer = do + putStrLn "parser/lexer" + sequence + [ runTest "integer" $ + assertRight "lex int" (tokenize "" "42") $ \toks -> + assertEqual "tokens" [TokInt 42] (tokenTypes toks), + runTest "float" $ + assertRight "lex float" (tokenize "" "3.14") $ \toks -> + assertEqual "tokens" [TokFloat 3.14] (tokenTypes toks), + runTest "trailing-dot float lexes as one float token" $ + assertRight "lex trailing-dot" (tokenize "" "12.") $ \toks -> + assertEqual "tokens" [TokFloat 12.0] (tokenTypes toks), + -- Maximal munch: a dot-led run with a /-segment is one PATH token + -- (upstream's PATH regex), while a slashless dot-run is not. + runTest "dot-relative path lexes as one token" $ + assertRight "lex dot-path" (tokenize "" ".github/x") $ \toks -> + assertEqual "tokens" [TokPath ".github/x"] (tokenTypes toks), + runTest "leading-dot float still lexes as float" $ + assertRight "lex dot-float" (tokenize "" ".5") $ \toks -> + assertEqual "tokens" [TokFloat 0.5] (tokenTypes toks), + runTest "trailing-dot float with exponent lexes as one float token" $ + assertRight "lex trailing-dot-exp" (tokenize "" "12.e2") $ \toks -> + assertEqual "tokens" [TokFloat 1200.0] (tokenTypes toks), + -- Float literals convert with a single rounding (strtod semantics). + -- The exact value here sits between representable ..992 and ..994, + -- nearer ..994; rounding whole and fraction separately lands on ..992. + runTest "float literal rounds once at the 2^53 boundary" $ + assertRight "lex float-tie" (tokenize "" "9007199254740993.5") $ \toks -> + assertEqual "tokens" [TokFloat 9007199254740994.0] (tokenTypes toks), + -- A float 10 ^^ exponent overflows on subnormals and flushes to 0. + runTest "subnormal float literal survives" $ + assertRight "lex float-subnormal" (tokenize "" "1.0e-320") $ \toks -> + assertEqual "tokens" [TokFloat 1.0e-320] (tokenTypes toks), + -- Bounded number lexing: a literal's cost must follow its length, + -- never its exponent's magnitude, and megadigit literals must + -- resolve promptly. The watchdog turns a cost regression into a + -- FAIL instead of a stuck suite; the checks force full values. + runTestM "huge positive exponent saturates to Infinity" $ do + let saturated = case tokenize "" "1.0e999999999" of + Right toks | [TokFloat f] <- tokenTypes toks -> isInfinite f && f > 0 + _ -> False + outcome <- timeout walkWatchdogMicros (evaluate saturated) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong tokens for a huge positive exponent" + Nothing -> Fail "lexing did not return promptly", + runTestM "huge negative exponent saturates to zero" $ do + let flushed = case tokenize "" "1.0e-999999999" of + Right toks -> tokenTypes toks == [TokFloat 0.0] + Left _ -> False + outcome <- timeout walkWatchdogMicros (evaluate flushed) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong tokens for a huge negative exponent" + Nothing -> Fail "lexing did not return promptly", + runTestM "zero mantissa ignores a huge exponent" $ do + let zeroed = case tokenize "" "0.0e999999999" of + Right toks -> tokenTypes toks == [TokFloat 0.0] + Left _ -> False + outcome <- timeout walkWatchdogMicros (evaluate zeroed) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong tokens for a zero mantissa" + Nothing -> Fail "lexing did not return promptly", + runTestM "megadigit integer literal rejects promptly" $ do + let rejected = case tokenize "" (BS8.replicate 1000000 '9') of + Left _ -> True + Right _ -> False + outcome <- timeout walkWatchdogMicros (evaluate rejected) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "megadigit literal was not rejected" + Nothing -> Fail "range rejection did not return promptly", + runTestM "megadigit mantissa still rounds correctly" $ do + -- 1.999...9e5 sits within half an ulp of 200000.0; the kept-768 + -- digits plus the sticky digit must round it there. + let rounded = case tokenize "" ("1." <> BS8.replicate 1000000 '9' <> "e5") of + Right toks -> tokenTypes toks == [TokFloat 200000.0] + Left _ -> False + outcome <- timeout walkWatchdogMicros (evaluate rounded) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong rounding for a megadigit mantissa" + Nothing -> Fail "lexing did not return promptly", + runTest "true" $ + assertRight "lex true" (tokenize "" "true") $ \toks -> + assertEqual "tokens" [TokTrue] (tokenTypes toks), + runTest "false" $ + assertRight "lex false" (tokenize "" "false") $ \toks -> + assertEqual "tokens" [TokFalse] (tokenTypes toks), + runTest "null" $ + assertRight "lex null" (tokenize "" "null") $ \toks -> + assertEqual "tokens" [TokNull] (tokenTypes toks), + runTest "identifier" $ + assertRight "lex ident" (tokenize "" "foo") $ \toks -> + assertEqual "tokens" [TokIdent "foo"] (tokenTypes toks), + runTest "hyphened identifier" $ + assertRight "lex hyphened" (tokenize "" "hello-world") $ \toks -> + assertEqual "tokens" [TokIdent "hello-world"] (tokenTypes toks), + runTest "path ./foo" $ + assertRight "lex path" (tokenize "" "./foo") $ \toks -> + assertEqual "tokens" [TokPath "./foo"] (tokenTypes toks), + runTest "path ~/foo" $ + assertRight "lex path home" (tokenize "" "~/foo") $ \toks -> + assertEqual "tokens" [TokPath "~/foo"] (tokenTypes toks), + runTest "search path" $ + assertRight "lex search path" (tokenize "" "") $ \toks -> + assertEqual "tokens" [TokSearchPath "nixpkgs"] (tokenTypes toks), + runTest "URI" $ + assertRight "lex uri" (tokenize "" "https://example.com") $ \toks -> + assertEqual "tokens" [TokUri "https://example.com"] (tokenTypes toks), + -- Upstream URI = [a-zA-Z][a-zA-Z0-9+.-]*:[uri-char]+ with flex + -- maximal munch: no // required, and the URI beats identifiers, + -- keywords, and the lambda colon when it matches more characters. + runTest "scheme-only URI x:y" $ + assertRight "lex uri x:y" (tokenize "" "x:y") $ \toks -> + assertEqual "tokens" [TokUri "x:y"] (tokenTypes toks), + runTest "scheme-only URI mailto" $ + assertRight "lex uri mailto" (tokenize "" "mailto:foo@example.com") $ \toks -> + assertEqual "tokens" [TokUri "mailto:foo@example.com"] (tokenTypes toks), + runTest "URI scheme allows + . -" $ + assertRight "lex uri scheme" (tokenize "" "a+b.c:d") $ \toks -> + assertEqual "tokens" [TokUri "a+b.c:d"] (tokenTypes toks), + runTest "URI beats keyword by maximal munch" $ + assertRight "lex uri keyword" (tokenize "" "then:x") $ \toks -> + assertEqual "tokens" [TokUri "then:x"] (tokenTypes toks), + runTest "hash is not a URI char (starts a comment)" $ + assertRight "lex uri hash" (tokenize "" "http://a#frag") $ \toks -> + assertEqual "tokens" [TokUri "http://a"] (tokenTypes toks), + runTest "apostrophe and star are URI chars" $ + assertRight "lex uri quote star" (tokenize "" "http://e.com/a'b*c") $ \toks -> + assertEqual "tokens" [TokUri "http://e.com/a'b*c"] (tokenTypes toks), + runTest "lambda colon needs the space" $ + assertRight "lex lambda colon" (tokenize "" "x: y") $ \toks -> + assertEqual "tokens" [TokIdent "x", TokColon, TokIdent "y"] (tokenTypes toks), + runTest "underscore cannot start a URI scheme" $ + assertRight "lex underscore colon" (tokenize "" "_a:b") $ \toks -> + assertEqual "tokens" [TokIdent "_a", TokColon, TokIdent "b"] (tokenTypes toks), + -- Raw CR/CRLF normalizes to LF in double-quoted strings (upstream + -- unescapeStr); an escaped CR survives; indented strings keep CR + -- verbatim because upstream's IND_STRING chunks skip unescapeStr. + runTest "CRLF in double-quoted string normalizes to LF" $ + assertRight "lex crlf string" (tokenize "" "\"a\r\nb\"") $ \toks -> + assertEqual "tokens" [TokStringOpen, TokStringLit "a\nb", TokStringClose] (tokenTypes toks), + runTest "lone CR in double-quoted string normalizes to LF" $ + assertRight "lex cr string" (tokenize "" "\"a\rb\"") $ \toks -> + assertEqual "tokens" [TokStringOpen, TokStringLit "a\nb", TokStringClose] (tokenTypes toks), + runTest "escaped CR stays a literal CR" $ + assertRight "lex escaped cr" (tokenize "" "\"a\\\rb\"") $ \toks -> + assertEqual "tokens" [TokStringOpen, TokStringLit "a\rb", TokStringClose] (tokenTypes toks), + runTest "indented string keeps CRLF verbatim" $ + assertRight "lex ind crlf" (tokenize "" "''a\r\nb''") $ \toks -> + assertEqual "tokens" [TokIndStringOpen, TokStringLit "a\r\nb", TokIndStringClose] (tokenTypes toks), + -- The opener is '' with an optional run of spaces and one newline + -- (upstream lexer.l); a tab is not part of it. + runTest "indented string opener consumes trailing spaces and newline" $ + assertRight "lex ind opener" (tokenize "" "'' \n a''") $ \toks -> + assertEqual "tokens" [TokIndStringOpen, TokStringLit " a", TokIndStringClose] (tokenTypes toks), + runTest "indented string opener stops at a tab" $ + assertRight "lex ind opener tab" (tokenize "" "''\t\na''") $ \toks -> + assertEqual "tokens" [TokIndStringOpen, TokStringLit "\t\na", TokIndStringClose] (tokenTypes toks), + runTest "multi-char operators" $ + assertRight "lex ops" (tokenize "" "++ // -> == != && || <= >=") $ \toks -> + assertEqual + "tokens" + [TokConcat, TokUpdate, TokImpl, TokEq, TokNeq, TokAnd, TokOr, TokLte, TokGte] + (tokenTypes toks), + runTest "single-char operators" $ + assertRight "lex single ops" (tokenize "" "+ - * ! ? < >") $ \toks -> + assertEqual + "tokens" + [TokPlus, TokMinus, TokStar, TokNot, TokQuestion, TokLt, TokGt] + (tokenTypes toks), + runTest "division vs path" $ + assertRight "lex div" (tokenize "" "6 / 3") $ \toks -> + assertEqual "tokens" [TokInt 6, TokSlash, TokInt 3] (tokenTypes toks), + runTest "string tokens" $ + assertRight "lex string" (tokenize "" "\"hello\"") $ \toks -> + assertEqual + "tokens" + [TokStringOpen, TokStringLit "hello", TokStringClose] + (tokenTypes toks), + runTest "empty string" $ + assertRight "lex empty string" (tokenize "" "\"\"") $ \toks -> + assertEqual + "tokens" + [TokStringOpen, TokStringClose] + (tokenTypes toks), + runTest "string interpolation tokens" $ + assertRight "lex interp" (tokenize "" "\"a${x}b\"") $ \toks -> + assertEqual + "tokens" + [ TokStringOpen, + TokStringLit "a", + TokInterpOpen, + TokIdent "x", + TokInterpClose, + TokStringLit "b", + TokStringClose + ] + (tokenTypes toks), + runTest "line comment" $ + assertRight "lex comment" (tokenize "" "# comment\n42") $ \toks -> + assertEqual "tokens" [TokInt 42] (tokenTypes toks), + runTest "block comment" $ + assertRight "lex block comment" (tokenize "" "/* comment */ 42") $ \toks -> + assertEqual "tokens" [TokInt 42] (tokenTypes toks), + runTest "ellipsis" $ + assertRight "lex ellipsis" (tokenize "" "...") $ \toks -> + assertEqual "tokens" [TokEllipsis] (tokenTypes toks), + runTest "punctuation" $ + assertRight "lex punct" (tokenize "" ". @ : ; = ,") $ \toks -> + assertEqual + "tokens" + [TokDot, TokAt, TokColon, TokSemicolon, TokAssign, TokComma] + (tokenTypes toks), + runTest "delimiters" $ + assertRight "lex delimiters" (tokenize "" "( ) { } [ ]") $ \toks -> + assertEqual + "tokens" + [TokLParen, TokRParen, TokLBrace, TokRBrace, TokLBracket, TokRBracket] + (tokenTypes toks), + runTest "keywords" $ + assertRight "lex keywords" (tokenize "" "if then else let in with assert rec inherit") $ \toks -> + assertEqual + "tokens" + [TokIf, TokThen, TokElse, TokLet, TokIn, TokWith, TokAssert, TokRec, TokInherit] + (tokenTypes toks), + runTest "or is identifier" $ + assertRight "lex or" (tokenize "" "or") $ \toks -> + assertEqual "tokens" [TokIdent "or"] (tokenTypes toks), + runTest "string escape sequences" $ + assertRight "lex escapes" (tokenize "" "\"\\n\\t\\\\\\\"\"") $ \toks -> + assertEqual + "tokens" + [TokStringOpen, TokStringLit "\n\t\\\"", TokStringClose] + (tokenTypes toks), + runTest "a string keeps bytes that are not UTF-8" $ + assertRight "lex invalid UTF-8" (tokenize "" (BS.pack [0x22, 0x61, 0xFF, 0xC3, 0x28, 0x22])) $ \toks -> + assertEqual "tokens" [TokStringOpen, TokStringLit (BS.pack [0x61, 0xFF, 0xC3, 0x28]), TokStringClose] (tokenTypes toks), + -- The e-acute's two bytes take one column, so x is at 5. + runTest "columns count characters" $ + assertRight "lex columns" (tokenize "" (TE.encodeUtf8 "\"\233\" x")) $ \toks -> + assertEqual "x" [(1, 5)] [(locLine tok, locCol tok) | tok <- toks, locToken tok == TokIdent "x"], + runTest "an escaped newline in an indented string ends a line" $ + assertRight "lex escaped newline" (tokenize "" "''a''\\\n'' x") $ \toks -> + assertEqual "x" [(2, 4)] [(locLine tok, locCol tok) | tok <- toks, locToken tok == TokIdent "x"], + -- Upstream's ID class is ASCII (lexer.l), so a letter outside it is + -- the character no rule but the catch-all takes. + runTest "a letter outside ASCII starts no token" $ + assertEqual "message" (Left "unexpected character: \233") (lexOutcome (TE.encodeUtf8 "\233")), + runTest "a byte that is no character is named as a byte" $ + assertEqual "message" (Left "unexpected byte 0xff") (lexOutcome (BS.pack [0xFF])), + -- Upstream's whitespace is [ \t\r\n] (lexer.l). + runTest "a vertical tab is not whitespace" $ + assertEqual "message" (Left "unexpected character: \v") (lexOutcome "1\v") + ] + where + lexOutcome source = either (Left . peMessage) (Right . length) (tokenize "" source) + +-- --------------------------------------------------------------------------- +-- Tests: Line endings +-- --------------------------------------------------------------------------- + +-- | A line ends at an LF, a CRLF or a bare CR, as upstream's position +-- table splits a source (@Pos::LinesIterator@, position.cc at 2.24.9), and +-- a line comment ends before the first CR or LF (@\#[^\\r\\n]*@, lexer.l). +testLineEndings :: IO [Bool] +testLineEndings = do + putStrLn "parser/line-endings" + let quickCheckPasses property = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + positionsIn label source expected = + assertRight label (tokenize "" source) $ \toks -> + assertEqual label expected [(locLine tok, locCol tok) | tok <- toks, locToken tok /= TokEOF] + xAt label source expected = + assertRight label (tokenize "" source) $ \toks -> + assertEqual label [expected] [(locLine tok, locCol tok) | tok <- toks, locToken tok == TokIdent "x"] + sequence + [ runTest "a line comment ends at a carriage return" $ + assertEval "comment" "# c\r1" (VInt 1), + runTest "a line comment's CRLF ends one line" $ + xAt "comment crlf" "# c\r\nx" (2, 1), + runTest "an LF, a CRLF and a bare CR each end one line" $ + positionsIn "endings" "a\nb\r\nc\rd" [(1, 1), (2, 1), (3, 1), (4, 1)], + runTest "an LF before a CR ends a line of its own" $ + xAt "lf cr" "\n\rx" (3, 1), + runTest "a bare CR ends a line in a block comment" $ + xAt "block comment" "/* a\r */ x" (2, 5), + runTest "a bare CR ends a line in a double-quoted string" $ + xAt "string" "\"a\rb\" x" (2, 4), + runTest "a bare CR ends a line in an indented string" $ + xAt "indented string" "''a\rb'' x" (2, 5), + runTest "an escaped bare CR ends a line" $ + xAt "escaped cr" "\"\\\r\" x" (2, 3), + -- The escape takes the CR and the string's next run its LF; the two + -- are still one line ending. + runTest "an escaped CR and the LF after it end one line" $ + xAt "escaped crlf" "\"\\\r\n\" x" (2, 3), + runTest "an indented string's escaped CR and the LF after it end one line" $ + xAt "indented escaped crlf" "''a''\\\r\n'' x" (2, 4), + -- Upstream's opener is @''(\ *\n)?@ (lexer.l): its newline is an LF, + -- so after a CR the opening line is content. + runTest "a CRLF after an indented string's opener is content" $ + assertRight "opener crlf" (tokenize "" "''\r\na''") $ \toks -> + assertEqual "tokens" [TokIndStringOpen, TokStringLit "\r\na", TokIndStringClose] (tokenTypes toks), + -- Upstream puts an end-of-file syntax error at the end of the input + -- (yyerror, parser.y at 2.24.9), which a trailing comment runs to. + runTest "the end of input after a line comment is past the comment" $ + assertRight "eof after comment" (syntaxErrorOf "(\n# c") $ \err -> + assertEqual "position" (2, 4) (peLine err, peCol err), + runTestM "a source's tokens stand on the same lines whichever line endings it uses" $ + quickCheckPasses $ + QC.forAll genLineEndingSource $ \pieces -> + case tokensOutsideStrings (renderSource (map withLf pieces)) of + Left err -> QC.counterexample (show err) False + Right expected -> tokensOutsideStrings (renderSource pieces) QC.=== Right expected + ] + where + -- A string's content is not compared: an indented string keeps its + -- CRs, and the content after an opener starts on the opening line + -- unless an LF ends it. + tokensOutsideStrings source = do + toks <- tokenize "" source + pure [(locToken tok, locLine tok, locCol tok) | tok <- toks, not (isStringContent (locToken tok))] + isStringContent (TokStringLit _) = True + isStringContent (TokStringEsc _) = True + isStringContent _ = False + withLf (SourceLineEnding _) = SourceLineEnding Lf + withLf piece = piece + +-- | A line ending of the kind upstream's position table splits at. +data LineEnding = Lf | CrLf | Cr + deriving (Show) + +-- | A piece of a generated source: bytes, or a line ending. +data SourcePiece = SourceBytes !BS.ByteString | SourceLineEnding !LineEnding + deriving (Show) + +-- | The bytes of a generated source. +renderSource :: [SourcePiece] -> BS.ByteString +renderSource = BS.concat . map pieceBytes + where + pieceBytes (SourceBytes bytes) = bytes + pieceBytes (SourceLineEnding Lf) = "\n" + pieceBytes (SourceLineEnding CrLf) = "\r\n" + pieceBytes (SourceLineEnding Cr) = "\r" + +-- | Sources whose line endings sit wherever the lexer can meet one: +-- between tokens, at a line comment's end, in a block comment, in a +-- double-quoted and an indented string, after an indented string's +-- opener, and escaped in either string. Each fragment ends at a space, +-- so no two fragments run together into another token, and a byte other +-- than LF follows each line ending, so no bare CR and the LF after it +-- read as one CRLF. +genLineEndingSource :: QC.Gen [SourcePiece] +genLineEndingSource = concat <$> QC.listOf (QC.oneof (map sequence fragments)) + where + ending = SourceLineEnding <$> QC.elements [Lf, CrLf, Cr] + bytes = pure . SourceBytes + fragments = + [ [bytes "x "], + [bytes "1 "], + [bytes "+ "], + [bytes "\"\195\169\" "], + [ending, bytes " "], + [bytes "# c", ending, bytes " "], + [bytes "/* c", ending, bytes "c */ "], + [bytes "\"s", ending, bytes "s\" "], + [bytes "\"\\", ending, bytes "\" "], + [bytes "''", ending, bytes "s'' "], + [bytes "''s", ending, bytes "s'' "], + [bytes "''s''\\", ending, bytes "'' "] + ] + +-- --------------------------------------------------------------------------- +-- Tests: Parser expressions +-- --------------------------------------------------------------------------- + +testParserExprs :: IO [Bool] +testParserExprs = do + putStrLn "parser/exprs" + sequence + [ -- Atoms + runTest "parse int" $ + assertParse "int" "42" (ELit (NixInt 42)), + runTest "parse float" $ + assertParse "float" "3.14" (ELit (NixFloat 3.14)), + runTest "parse true" $ + assertParse "true" "true" (ELit (NixBool True)), + runTest "parse false" $ + assertParse "false" "false" (ELit (NixBool False)), + runTest "parse null" $ + assertParse "null" "null" (ELit NixNull), + runTest "parse var" $ + assertParseIn ["x"] "var" "x" (EVar "x"), + runTest "parse empty string" $ + assertParse "empty string" "\"\"" (EStr []), + runTest "parse string literal" $ + assertParse "string" "\"hello\"" (EStr [StrLit "hello"]), + runTest "parse string interpolation" $ + assertParseIn + ["name"] + "interp" + "\"hello ${name}\"" + (EStr [StrLit "hello ", StrInterp (EVar "name")]), + runTest "parse nested string interpolation" $ + assertParse + "nested interp" + "\"${\"inner\"}\"" + (EStr [StrInterp (EStr [StrLit "inner"])]), + -- Arithmetic + runTest "parse add" $ + assertParse "add" "1 + 2" (EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2))), + runTest "parse sub" $ + assertParse "sub" "3 - 1" (EBinary OpSub (ELit (NixInt 3)) (ELit (NixInt 1))), + runTest "parse mul" $ + assertParse "mul" "2 * 3" (EBinary OpMul (ELit (NixInt 2)) (ELit (NixInt 3))), + runTest "parse left-assoc add" $ + assertParse + "left-assoc" + "1 + 2 + 3" + (EBinary OpAdd (EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2))) (ELit (NixInt 3))), + runTest "parse precedence mul over add" $ + assertParse + "precedence" + "1 + 2 * 3" + (EBinary OpAdd (ELit (NixInt 1)) (EBinary OpMul (ELit (NixInt 2)) (ELit (NixInt 3)))), + -- Unary + runTest "parse negation" $ + assertParse "negate" "-1" (EUnary OpNegate (ELit (NixInt 1))), + runTest "parse logical not" $ + assertParse "not" "!true" (EUnary OpNot (ELit (NixBool True))), + -- Non-associative + runTest "parse eq" $ + assertParse "eq" "1 == 2" (EBinary OpEq (ELit (NixInt 1)) (ELit (NixInt 2))), + runTest "parse lt" $ + assertParse "lt" "1 < 2" (EBinary OpLt (ELit (NixInt 1)) (ELit (NixInt 2))), + -- Right-associative + runTest "parse implication" $ + assertParseIn + ["a", "b", "c"] + "impl" + "a -> b -> c" + (EBinary OpImpl (EVar "a") (EBinary OpImpl (EVar "b") (EVar "c"))), + runTest "parse concat right" $ + assertParseIn + ["a", "b", "c"] + "concat" + "a ++ b ++ c" + (EBinary OpConcat (EVar "a") (EBinary OpConcat (EVar "b") (EVar "c"))), + runTest "parse update right" $ + assertParseIn + ["a", "b", "c"] + "update" + "a // b // c" + (EBinary OpUpdate (EVar "a") (EBinary OpUpdate (EVar "b") (EVar "c"))), + -- Lambda + -- After variable resolution, lambda-bound vars become EResolvedVar. + -- FormalName "x" maps to slot 0; FormalSet [a,b] maps to a=0, b=1; + -- FormalNamedSet "args" [a] maps to args=0, a=1. + runTest "parse simple lambda" $ + assertParse "lambda" "x: x" (ELambda (FormalName "x") (EResolvedVar 0 0) NoCaptureInfo), + runTest "parse set pattern lambda" $ + assertParse + "set pattern" + "{ a, b }: a" + ( ELambda + (FormalSet [Formal "a" Nothing, Formal "b" Nothing] False) + (EResolvedVar 0 0) + NoCaptureInfo + ), + runTest "parse set pattern with defaults" $ + assertParse + "defaults" + "{ a ? 1 }: a" + ( ELambda + (FormalSet [Formal "a" (Just (ELit (NixInt 1)))] False) + (EResolvedVar 0 0) + NoCaptureInfo + ), + runTest "parse set pattern with ellipsis" $ + assertParse + "ellipsis" + "{ a, ... }: a" + ( ELambda + (FormalSet [Formal "a" Nothing] True) + (EResolvedVar 0 0) + NoCaptureInfo + ), + runTest "parse named set pattern (name@{...})" $ + assertParse + "named set" + "args@{ a }: a" + ( ELambda + (FormalNamedSet "args" [Formal "a" Nothing] False) + (EResolvedVar 0 1) + NoCaptureInfo + ), + runTest "parse named set pattern ({...}@name)" $ + assertParse + "set@name" + "{ a }@args: a" + ( ELambda + (FormalNamedSet "args" [Formal "a" Nothing] False) + (EResolvedVar 0 1) + NoCaptureInfo + ), + -- Application + runTest "parse application" $ + assertParseIn ["f", "x"] "app" "f x" (EApp (EVar "f") (EVar "x")), + runTest "parse left-assoc application" $ + assertParseIn ["f", "x", "y"] "app left" "f x y" (EApp (EApp (EVar "f") (EVar "x")) (EVar "y")), + runTest "parse application with parens" $ + assertParseIn + ["f"] + "app parens" + "f (1 + 2)" + (EApp (EVar "f") (EBinary OpAdd (ELit (NixInt 1)) (ELit (NixInt 2)))), + -- Select + runTest "parse select" $ + assertParseIn ["a"] "select" "a.b" (ESelect (EVar "a") [StaticKey "b"] Nothing), + runTest "parse nested select" $ + assertParseIn + ["a"] + "nested select" + "a.b.c" + (ESelect (EVar "a") [StaticKey "b", StaticKey "c"] Nothing), + runTest "parse select or default" $ + assertParseIn + ["a"] + "select or" + "a.b or 1" + (ESelect (EVar "a") [StaticKey "b"] (Just (ELit (NixInt 1)))), + runTest "parse has-attr" $ + assertParseIn ["a"] "has-attr" "a ? b" (EHasAttr (EVar "a") [StaticKey "b"]), + -- Attr sets + runTest "parse empty attrs" $ + assertParse "empty attrs" "{ }" (EAttrs False [] NoCaptureInfo), + runTest "parse attrs with binding" $ + assertParse + "attrs" + "{ a = 1; }" + (EAttrs False [NamedBinding (testPos 1 3) (StaticKey "a") (ELit (NixInt 1))] NoCaptureInfo), + runTest "parse rec attrs" $ + assertParse + "rec attrs" + "rec { a = 1; }" + (EAttrs True [NamedBinding (testPos 1 7) (StaticKey "a") (ELit (NixInt 1))] NoCaptureInfo), + -- inherit x y; is one binding per name, each holding the variable it + -- copies, which resolution binds like any other variable. + runTest "parse inherit" $ + assertParseIn + ["x", "y"] + "inherit" + "{ inherit x y; }" + (EAttrs False [Inherit (testPos 1 11) "x" (EVar "x"), Inherit (testPos 1 13) "y" (EVar "y")] NoCaptureInfo), + runTest "parse inherit from" $ + assertParseIn + ["a"] + "inherit from" + "{ inherit (a) x; }" + (EAttrs False [InheritFrom (EVar "a") [InheritedName (testPos 1 15) "x"]] NoCaptureInfo), + -- Let/if/with/assert + runTest "parse let" $ + assertParse + "let" + "let x = 1; in x" + (ELet [NamedBinding (testPos 1 5) (StaticKey "x") (ELit (NixInt 1))] (EResolvedVar 0 0) NoCaptureInfo), + runTest "parse if-then-else" $ + assertParse + "if" + "if true then 1 else 2" + (EIf (ELit (NixBool True)) (ELit (NixInt 1)) (ELit (NixInt 2))), + runTest "parse with" $ + assertParseIn + ["a"] + "with" + "with a; b" + (EWith (EVar "a") (EWithVar "b")), + runTest "parse assert" $ + assertParse + "assert" + "assert true; 1" + (EAssert (ELit (NixBool True)) (ELit (NixInt 1))), + -- Lists + runTest "parse empty list" $ + assertParse "empty list" "[ ]" (EList []), + runTest "parse list elements" $ + assertParse + "list" + "[ 1 2 3 ]" + (EList [ELit (NixInt 1), ELit (NixInt 2), ELit (NixInt 3)]), + -- Parens + runTest "parse parens" $ + assertParse "parens" "(42)" (ELit (NixInt 42)), + -- 'or' as identifier + runTest "or as identifier" $ + assertParseIn ["or"] "or ident" "or" (EVar "or"), + -- 'or' as attr key + runTest "or as attr key" $ + assertParse + "or attr key" + "{ or = 1; }" + (EAttrs False [NamedBinding (testPos 1 3) (StaticKey "or") (ELit (NixInt 1))] NoCaptureInfo) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Parser errors +-- --------------------------------------------------------------------------- + +testParserErrors :: IO [Bool] +testParserErrors = do + putStrLn "parser/errors" + sequence + [ runTest "empty input" $ + assertLeft "empty" (parseNix testBaseDir testOrigin ""), + runTest "unclosed paren" $ + assertLeft "unclosed paren" (parseNix testBaseDir testOrigin "(1"), + runTest "unclosed string" $ + assertLeft "unclosed string" (parseNix testBaseDir testOrigin "\"hello"), + runTest "unclosed brace" $ + assertLeft "unclosed brace" (parseNix testBaseDir testOrigin "{ a = 1;"), + runTest "missing semicolon" $ + assertLeft "missing semi" (parseNix testBaseDir testOrigin "{ a = 1 }"), + runTest "unclosed bracket" $ + assertLeft "unclosed bracket" (parseNix testBaseDir testOrigin "[ 1 2"), + runTest "unexpected token" $ + assertLeft "unexpected" (parseNix testBaseDir testOrigin ")"), + -- A failure deep in a lambda body is reported where it happened: + -- a parsed lambda header commits, instead of backtracking into + -- the attr-set reading and reporting its early stumble (a real + -- error at line 410 of a nixpkgs file used to surface at line 2). + runTest "deep formals-lambda body error reports its own line" $ + assertRight "deep body" (syntaxErrorOf "{ a, b }:\n{\n x = 1;\n y = (;\n}") $ \err -> + assertEqual "error line" 4 (peLine err), + runTest "simple-lambda body error reports its own line" $ + assertRight "simple body" (syntaxErrorOf "x:\n(;") $ \err -> + assertEqual "error line" 2 (peLine err), + -- The empty attr set is a successful PREFIX parse of "{ }: body", + -- so without commitment the outer parser complained at the colon. + runTest "empty-formals lambda body error reports its own line" $ + assertRight "empty formals body" (syntaxErrorOf "{ }:\n(;") $ \err -> + assertEqual "error line" 2 (peLine err), + -- When neither reading parses, the deeper failure wins: the + -- malformed formal at column 7, not the attr-set branch's + -- stumble over the first comma at column 4. + runTest "a malformed formal beats the attr-set branch's earlier error" $ + assertRight "malformed formal" (syntaxErrorOf "{ a, b.c }: x") $ \err -> + assertEqual "deeper than the attr-set stumble" True ((peLine err, peCol err) > (1, 4)), + -- End-of-input failures carry no position and must rank as the + -- furthest a branch can get. + runTest "truncated lambda reports end of input" $ + assertRight "truncated lambda" (syntaxErrorOf "{ a, b }:") $ \err -> + assertEqual "end of input" True ("end of input" `T.isInfixOf` peMessage err) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Source bytes +-- --------------------------------------------------------------------------- + +-- | A source is bytes, as upstream's lexer reads it (lexer.l at 2.24.9): a +-- string literal's bytes are its value's whether or not they are UTF-8, +-- every other token is ASCII, and a byte order mark selects UTF-16, read +-- as its UTF-8. +testSourceBytes :: IO [Bool] +testSourceBytes = do + putStrLn "parser/source-bytes" + let quickCheckPasses property = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + -- NUL is left out: upstream's unescapeStr stops at one (lexer.l), so + -- a literal holding it is no round trip there. + literalBytes = BS.pack <$> QC.listOf (QC.choose (1, maxBound :: Word8)) + literalText = T.pack <$> QC.listOf (QC.arbitrary `QC.suchThat` (/= '\NUL')) + utf16Le = (BS.pack [0xFF, 0xFE] <>) . TE.encodeUtf16LE + utf16Be = (BS.pack [0xFE, 0xFF] <>) . TE.encodeUtf16BE + errorAt err = (peLine err, peCol err, peMessage err) + sequence + [ runTestM "a string literal's bytes are its value's" $ + quickCheckPasses $ + QC.forAll literalBytes $ \bytes -> + evalNixBytes (stringLiteralBytes bytes) QC.=== Right (VStr bytes emptyContext), + runTestM "a UTF-16 source is read as its UTF-8, in either byte order" $ + quickCheckPasses $ + QC.forAll literalText $ \text -> + let expected = Right (VStr (TE.encodeUtf8 text) emptyContext) + in evalNixBytes (utf16Le (stringLiteralText text)) QC.=== expected + QC..&&. evalNixBytes (utf16Be (stringLiteralText text)) QC.=== expected, + runTest "an indented string keeps bytes that are not UTF-8" $ + assertEqual "value" (Right (VStr (BS.pack [0x61, 0xFF, 0x62]) emptyContext)) (evalNixBytes ("''" <> BS.pack [0x61, 0xFF, 0x62] <> "''")), + runTest "a comment may hold bytes that are not UTF-8" $ + assertEqual "value" (Right (VInt 1)) (evalNixBytes ("# " <> BS.pack [0xFF] <> "\n/* " <> BS.pack [0xC3, 0x28] <> " */ 1")), + -- Upstream's PATH_CHAR is ASCII (lexer.l): the byte ends the path + -- and starts no token of its own. + runTest "a byte outside ASCII ends a path" $ + assertEqual "error" (Right (1, 4, "unexpected byte 0xff")) (errorAt <$> syntaxErrorOfBytes ("./a" <> BS.pack [0xFF] <> "b")), + runTest "a string attribute name must be UTF-8" $ + assertEqual "error" (Right (1, 3, "attribute name is not valid UTF-8")) (errorAt <$> syntaxErrorOfBytes ("{ \"" <> BS.pack [0xFF] <> "\" = 1; }")), + -- A dot commits to the key after it, so the key's error is the one + -- reported, not a complaint about the dot. + runTest "a string attribute name after a dot must be UTF-8" $ + assertEqual "error" (Right (1, 5, "attribute name is not valid UTF-8")) (errorAt <$> syntaxErrorOfBytes ("{ a.\"" <> BS.pack [0xFF] <> "\" = 1; }")), + runTest "a string name after a dot in a has-attribute path must be UTF-8" $ + assertEqual "error" (Right (1, 9, "attribute name is not valid UTF-8")) (errorAt <$> syntaxErrorOfBytes ("{ } ? a.\"" <> BS.pack [0xFF] <> "\"")), + runTest "a quoted inherit name must be UTF-8" $ + assertEqual "error" (Right (1, 17, "attribute name is not valid UTF-8")) (errorAt <$> syntaxErrorOfBytes ("{ inherit ({ }) \"" <> BS.pack [0xFF] <> "\"; }")), + runTest "a UTF-8 byte order mark is dropped" $ + assertEqual "value" (Right (VInt 1)) (evalNixBytes (BS.pack [0xEF, 0xBB, 0xBF] <> "1")), + runTest "an unpaired UTF-16 surrogate is a syntax error where it stands" $ + assertEqual "error" (Right (2, 3, "unpaired UTF-16 surrogate")) (errorAt <$> syntaxErrorOfBytes (utf16Le "1\n +" <> BS.pack [0x00, 0xD8])), + runTest "a bare CR ends a line for a UTF-16 source's error" $ + assertEqual "error" (Right (2, 3, "unpaired UTF-16 surrogate")) (errorAt <$> syntaxErrorOfBytes (utf16Le "1\r +" <> BS.pack [0x00, 0xD8])), + runTest "a UTF-16 source with an odd byte at its end is a syntax error" $ + assertEqual "error" (Right (1, 2, "UTF-16 source with an odd number of bytes")) (errorAt <$> syntaxErrorOfBytes (utf16Be "1" <> BS.pack [0x41])) + ] + +-- | Bytes as a double-quoted literal of them: each byte with a meaning +-- there escaped ('literalEscape'), every other kept as it is. +stringLiteralBytes :: BS.ByteString -> BS.ByteString +stringLiteralBytes bytes = "\"" <> BS8.concatMap escaped bytes <> "\"" + where + escaped c = maybe (BS8.singleton c) TE.encodeUtf8 (literalEscape c) + +-- | Text as a double-quoted literal of it, escaped as 'stringLiteralBytes'. +stringLiteralText :: Text -> Text +stringLiteralText text = "\"" <> T.concatMap escaped text <> "\"" + where + escaped c = fromMaybe (T.singleton c) (literalEscape c) + +-- | The escape a character needs in a double-quoted literal: the quote, +-- the backslash, the dollar, and the carriage return, which a raw literal +-- reads as a newline (unescapeStr, lexer.l at 2.24.9). +literalEscape :: Char -> Maybe Text +literalEscape '"' = Just "\\\"" +literalEscape '\\' = Just "\\\\" +literalEscape '$' = Just "\\$" +literalEscape '\r' = Just "\\r" +literalEscape _ = Nothing + +-- --------------------------------------------------------------------------- +-- Tests: Parser integration +-- --------------------------------------------------------------------------- + +testParserIntegration :: IO [Bool] +testParserIntegration = do + putStrLn "parser/integration" + sequence + [ runTest "shell.nix pattern" $ + assertRight "shell.nix" (parseNix testBaseDir testOrigin "{ pkgs ? import {} }: pkgs.mkShell { buildInputs = [ pkgs.ghc ]; }") $ \case + ELambda {} -> Pass + other -> Fail ("expected ELambda, got: " <> T.pack (show other)), + runTest "let with multiple bindings" $ + assertParse + "multi-let" + "let x = 1; y = 2; in x + y" + ( ELet + [ NamedBinding (testPos 1 5) (StaticKey "x") (ELit (NixInt 1)), + NamedBinding (testPos 1 12) (StaticKey "y") (ELit (NixInt 2)) + ] + (EBinary OpAdd (EResolvedVar 0 0) (EResolvedVar 0 1)) + NoCaptureInfo + ), + runTest "nested attr set" $ + -- Normalization hoists a nested attrpath into nested literal sets + -- (upstream parser.y addAttr), so a.b.c = 1 parses like + -- a = { b = { c = 1; }; }, every level at the path's position. + assertParse + "nested attrs" + "{ a.b.c = 1; d = { e = 2; }; }" + ( EAttrs + False + [ NamedBinding + (testPos 1 3) + (StaticKey "a") + ( EAttrs + False + [ NamedBinding + (testPos 1 3) + (StaticKey "b") + (EAttrs False [NamedBinding (testPos 1 3) (StaticKey "c") (ELit (NixInt 1))] NoCaptureInfo) + ] + NoCaptureInfo + ), + NamedBinding (testPos 1 14) (StaticKey "d") (EAttrs False [NamedBinding (testPos 1 20) (StaticKey "e") (ELit (NixInt 2))] NoCaptureInfo) + ] + NoCaptureInfo + ), + runTest "indented string" $ + assertRight "ind string" (parseNix testBaseDir testOrigin "''hello''") $ \case + EIndStr _ -> Pass + other -> Fail ("expected EIndStr, got: " <> T.pack (show other)), + runTest "indented string escape is its own part" $ + assertRight "ind string esc" (parseNix testBaseDir testOrigin "''a'''b''") $ \case + EIndStr [StrLit "a", StrEsc "''", StrLit "b"] -> Pass + other -> Fail ("expected literal, escape, literal, got: " <> T.pack (show other)), + -- Positional let/rec resolution tests + runTest "let inherit from outer lambda" $ + assertRight "let-inherit-lambda" (parseNix testBaseDir testOrigin "x: let inherit x; in x") $ \case + -- x: let inherit x; in x + -- The lambda formal x is at level 0, index 0. + -- The let scope is level 0 (for the let body). + -- The inherited variable resolves against the outer (lambda) + -- scope, one level up from the let it is evaluated in. + -- The body x resolves to level 0, index 0 (the let scope). + ELambda _ (ELet [Inherit _ "x" _rhsExpr] (EResolvedVar 0 0) _) _ -> Pass + other -> Fail ("expected ELambda with let-inherit, got: " <> T.pack (show other)), + runTest "nested lambda in let" $ + assertEval + "let-nested-lambda" + "let f = x: x + 1; g = y: f y; in g 5" + (VInt 6), + runTest "rec attrs positional resolution" $ + assertEval + "rec-positional" + "let s = rec { a = 1; b = a + 1; }; in s.b" + (VInt 2) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 1 - Trivial pure builtins + constants +-- --------------------------------------------------------------------------- + +testBatch1 :: IO [Bool] +testBatch1 = do + putStrLn "eval/builtins-batch1" + sequence + [ -- isPath + runTest "isPath true" $ + assertEval "isPath-t" "builtins.isPath ./foo" (VBool True), + runTest "isPath false" $ + assertEval "isPath-f" "builtins.isPath \"foo\"" (VBool False), + -- ceil + runTest "ceil float" $ + assertEval "ceil" "builtins.ceil 1.2" (VInt 2), + runTest "ceil int passthrough" $ + assertEval "ceil-int" "builtins.ceil 5" (VInt 5), + runTest "ceil negative" $ + assertEval "ceil-neg" "builtins.ceil (- 1.7)" (VInt (-1)), + runTest "ceil type error" $ + assertEvalFail "ceil-err" "builtins.ceil \"hi\"", + -- floor + runTest "floor float" $ + assertEval "floor" "builtins.floor 1.7" (VInt 1), + runTest "floor int passthrough" $ + assertEval "floor-int" "builtins.floor 5" (VInt 5), + runTest "floor negative" $ + assertEval "floor-neg" "builtins.floor (- 1.2)" (VInt (-2)), + -- NaN, infinity, and out-of-range floats are eval errors (Nix 2.24), + -- not whatever Int64 Haskell's unchecked conversion produces. + runTest "ceil NaN fails" $ + assertEvalFail "ceil-nan" "builtins.ceil ((1.0e308 * 10) * 0.0)", + runTest "floor infinity fails" $ + assertEvalFail "floor-inf" "builtins.floor (1.0e308 * 10)", + runTest "ceil out of integer range fails" $ + assertEvalFail "ceil-range" "builtins.ceil 1.0e300", + -- seq + runTest "seq returns second" $ + assertEval "seq" "builtins.seq 1 42" (VInt 42), + -- trace + runTest "trace returns second" $ + assertEval "trace" "builtins.trace \"msg\" 42" (VInt 42), + -- unsafeDiscardStringContext + runTest "discardContext" $ + assertEval "discard" "builtins.unsafeDiscardStringContext \"hello\"" (mkStr "hello"), + -- unsafeDiscardOutputDependency + runTest "discardOutputDep" $ + assertEval "discardOut" "builtins.unsafeDiscardOutputDependency \"hello\"" (mkStr "hello"), + -- baseNameOf + runTest "baseNameOf string" $ + assertEval "baseName-str" "builtins.baseNameOf \"/foo/bar/baz\"" (mkStr "baz"), + runTest "baseNameOf path" $ + assertEval "baseName-path" "builtins.baseNameOf ./foo/bar" (mkStr "bar"), + runTest "baseNameOf no slash" $ + assertEval "baseName-flat" "builtins.baseNameOf \"filename\"" (mkStr "filename"), + runTest "baseNameOf type error" $ + assertEvalFail "baseName-err" "builtins.baseNameOf 42", + -- dirOf + runTest "dirOf string" $ + assertEval "dirOf-str" "builtins.dirOf \"/foo/bar/baz\"" (mkStr "/foo/bar"), + runTest "dirOf no slash" $ + assertEval "dirOf-flat" "builtins.dirOf \"filename\"" (mkStr "."), + runTest "dirOf root-level path" $ + assertEval "dirOf-root" "builtins.dirOf \"/foo\"" (mkStr "/"), + -- Path VALUES arrive native-spelled when eval's base dir is a + -- native path (the CLI case); the path-operand splits must be + -- separator-aware. The forward-slash tests above use a '/' + -- base and cannot see this. + runTestM "baseNameOf on a native-based path value" $ do + cwd <- Dir.getCurrentDirectory + result <- evalNixIO cwd "builtins.baseNameOf ./regression-name.nix" + pure $ case result of + Right v + | v == mkStr "regression-name.nix" -> Pass + | otherwise -> Fail ("wrong basename: " <> T.pack (show v)) + Left err -> Fail ("eval failed: " <> T.pack (show err)), + -- The path-value spec: absolute, lexically canonical, and + -- slash-spelled regardless of the base dir's native spelling. + runTestM "path values are slash-canonical from a native base" $ do + cwd <- Dir.getCurrentDirectory + result <- evalNixIO cwd "toString ./spec-name.nix" + let expected = mkStr (T.replace "\\" "/" (T.pack cwd) <> "/spec-name.nix") + pure $ case result of + Right v + | v == expected -> Pass + | otherwise -> Fail ("wrong spelling: " <> T.pack (show v)) + Left err -> Fail ("eval failed: " <> T.pack (show err)), + runTest "canonPathValue folds platform separators only" $ + let folded = canonPathValue "C:\\a\\.\\b" + expectedByPlatform = + if SI.os == "mingw32" + then "C:/a/b" -- '\\' is a separator here and folds + else "C:\\a\\.\\b" -- '\\' is a file-name character, preserved + in assertEqual "platform fold" expectedByPlatform folded, + runTestM "dirOf on a native-based path value" $ do + cwd <- Dir.getCurrentDirectory + dirResult <- evalNixIO cwd "builtins.dirOf ./sub/regression-name.nix" + parentResult <- evalNixIO cwd "./sub" + pure $ + if dirResult == parentResult + then Pass + else + Fail + ( "dirOf mismatch: " + <> T.pack (show dirResult) + <> " vs " + <> T.pack (show parentResult) + ), + -- appendContext: a key that is not a store path must refuse, as + -- upstream does - a fabricated identity would flow into + -- derivation inputs. + runTest "appendContext rejects a non-store-path key" $ + assertEvalFail + "appendContext-badkey" + "builtins.appendContext \"x\" { \"not-a-store-path\" = { path = true; }; }", + runTest "appendContext accepts a store-path key" $ + assertEval + "appendContext-ok" + "if (builtins.appendContext \"x\" { \"/nix/store/00000000000000000000000000000000-y\" = { path = true; }; }) == \"x\" then \"ok\" else \"no\"" + (mkStr "ok"), + -- storePath: the hash component is charset-validated like every + -- other store-path parse boundary ('E' is outside nix-base32), and + -- refused with upstream's StorePath constructor text (path.cc at + -- 2.24.9). + runTest "storePath rejects a non-base32 hash" $ + assertEvalError + "storePath-badhash" + "builtins.storePath \"/nix/store/EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE-x\"" + "store path 'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE-x' contains illegal base-32 character 'E'", + runTest "storePath refuses a path outside the store" $ + assertEvalError "storePath-outside" "builtins.storePath \"/x\"" "path '/x' is not in the Nix store", + runTest "storePath refuses the store directory itself" $ + assertEvalError "storePath-storedir" "builtins.storePath \"/nix/store/\"" "path '/nix/store' is not in the Nix store", + runTest "storePath refuses a component too short for a hash" $ + assertEvalError "storePath-short" "builtins.storePath \"/nix/store/x\"" "'x' is too short to be a valid store path", + runTest "storePath refuses an empty name" $ + assertEvalError "storePath-empty-name" "builtins.storePath \"/nix/store/00000000000000000000000000000000-\"" "path '00000000000000000000000000000000-' is not a valid store path: name must not be empty", + runTest "storePath refuses an illegal name" $ + assertEvalError "storePath-bad-name" "builtins.storePath \"/nix/store/00000000000000000000000000000000-a b\"" "path '00000000000000000000000000000000-a b' is not a valid store path: name 'a b' contains illegal character ' '", + runTest "storePath accepts a valid store path" $ + assertEval + "storePath-ok" + "if (builtins.storePath \"/nix/store/00000000000000000000000000000000-x\") == \"/nix/store/00000000000000000000000000000000-x\" then \"ok\" else \"no\"" + (mkStr "ok"), + runTest "dirOf root" $ + assertEval "dirOf-slash" "builtins.dirOf \"/\"" (mkStr "/"), + -- concatLists + runTest "concatLists basic" $ + assertEval "concatLists" "builtins.concatLists [ [ 1 2 ] [ 3 ] [ 4 5 ] ] == [ 1 2 3 4 5 ]" (VBool True), + runTest "concatLists empty" $ + assertEval "concatLists-empty" "builtins.concatLists [ ]" (VList emptyCList), + runTest "concatLists type error" $ + assertEvalFail "concatLists-err" "builtins.concatLists [ 1 2 ]", + -- lessThan + runTest "lessThan true" $ + assertEval "lt-t" "builtins.lessThan 1 2" (VBool True), + runTest "lessThan false" $ + assertEval "lt-f" "builtins.lessThan 2 1" (VBool False), + runTest "lessThan strings" $ + assertEval "lt-str" "builtins.lessThan \"a\" \"b\"" (VBool True), + -- List < decides at the first UNEQUAL pair, as upstream: a pair + -- where < holds in neither direction (NaN) decides False rather + -- than being skipped as equal. + -- Distinct NaN values: a shared binding would be skipped as equal + -- via reference identity, which upstream's eqValues also does. + runTest "list compare decides at the first unequal pair" $ + assertEval "lt-list-nan" "let inf = 1.0e308 * 10; in [ (inf - inf) 1 ] < [ (inf - inf) 2 ]" (VBool False), + runTest "list compare skips equal prefixes" $ + assertEval "lt-list-prefix" "[ 1 2 ] < [ 1 3 ]" (VBool True), + -- Constants + runTest "storeDir" $ + assertEval "storeDir" "builtins.storeDir" (mkStr defaultStoreDirText), + runTest "nixVersion" $ + assertEval "nixVersion" "builtins.nixVersion" (mkStr "2.24.9"), + runTest "langVersion" $ + assertEval "langVersion" "builtins.langVersion" (VInt 6), + runTest "nixPath" $ + assertEval "nixPath" "builtins.nixPath" (VList emptyCList) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 2 - Arithmetic + bitwise builtins +-- --------------------------------------------------------------------------- + +testBatch2 :: IO [Bool] +testBatch2 = do + putStrLn "eval/builtins-batch2" + sequence + [ -- add + runTest "add ints" $ + assertEval "add-int" "builtins.add 3 4" (VInt 7), + runTest "add int+float" $ + assertEval "add-mixed" "builtins.add 1 2.5" (VFloat 3.5), + runTest "add type error" $ + assertEvalFail "add-err" "builtins.add \"a\" 1", + -- sub + runTest "sub ints" $ + assertEval "sub-int" "builtins.sub 10 3" (VInt 7), + runTest "sub float" $ + assertEval "sub-float" "builtins.sub 5.5 2.0" (VFloat 3.5), + -- mul + runTest "mul ints" $ + assertEval "mul-int" "builtins.mul 3 4" (VInt 12), + runTest "mul float" $ + assertEval "mul-float" "builtins.mul 2 3.0" (VFloat 6.0), + -- div + runTest "div ints" $ + assertEval "div-int" "builtins.div 10 3" (VInt 3), + runTest "div float" $ + assertEval "div-float" "builtins.div 7.0 2.0" (VFloat 3.5), + runTest "div by zero" $ + assertEvalFail "div-zero" "builtins.div 1 0", + -- bitAnd + runTest "bitAnd" $ + assertEval "bitAnd" "builtins.bitAnd 12 10" (VInt 8), + runTest "bitAnd type error" $ + assertEvalFail "bitAnd-err" "builtins.bitAnd 1.0 2", + -- bitOr + runTest "bitOr" $ + assertEval "bitOr" "builtins.bitOr 12 10" (VInt 14), + -- bitXor + runTest "bitXor" $ + assertEval "bitXor" "builtins.bitXor 12 10" (VInt 6) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 3 - Attrset higher-order builtins +-- --------------------------------------------------------------------------- + +testBatch3 :: IO [Bool] +testBatch3 = do + putStrLn "eval/builtins-batch3" + let functionArgsError = "'functionArgs' requires a function" + sequence + [ -- mapAttrs + runTest "mapAttrs basic" $ + assertEval "mapAttrs" "(builtins.mapAttrs (name: val: val + 1) { a = 1; b = 2; }).a" (VInt 2), + runTest "mapAttrs name usage" $ + assertEval "mapAttrs-name" "(builtins.mapAttrs (name: val: name) { a = 1; }).a" (mkStr "a"), + runTest "mapAttrs type error" $ + assertEvalFail "mapAttrs-err" "builtins.mapAttrs (n: v: v) [ 1 ]", + runTest "mapAttrs lazy" $ + assertEval "mapAttrs-lazy" "let s = builtins.mapAttrs (k: v: if k == \"a\" then v else throw \"boom\") { a = 1; b = 2; }; in s.a" (VInt 1), + -- functionArgs + runTest "functionArgs set pattern" $ + assertEval "funcArgs" "(builtins.functionArgs ({ a, b ? 1 }: a)).b" (VBool True), + runTest "functionArgs no default" $ + assertEval "funcArgs-nodef" "(builtins.functionArgs ({ a, b ? 1 }: a)).a" (VBool False), + runTest "functionArgs simple lambda" $ + assertEval "funcArgs-simple" "builtins.functionArgs (x: x)" (VAttrs (attrSetFromMap Map.empty)), + -- Upstream's prim_functionArgs message (primops.cc at 2.24.9), the + -- same whatever the argument, and tryEval does not catch it. + runTest "functionArgs of a set is upstream's error" $ + assertEvalError "funcArgs-set" "builtins.functionArgs {}" functionArgsError, + runTest "functionArgs of a path is upstream's error" $ + assertEvalError "funcArgs-path" "builtins.functionArgs ./foo" functionArgsError, + runTest "functionArgs of an integer is upstream's error" $ + assertEvalError "funcArgs-int" "builtins.functionArgs 42" functionArgsError, + runTest "functionArgs of a string is upstream's error" $ + assertEvalError "funcArgs-string" "builtins.functionArgs \"s\"" functionArgsError, + runTest "tryEval does not catch the functionArgs error" $ + assertEvalError "funcArgs-tryEval" "builtins.tryEval (builtins.functionArgs {})" functionArgsError, + -- The builtins set is observable (hasAttr/attrNames), so it must + -- match upstream's primop set exactly: no mod/min/max/ + -- setFunctionArgs extensions (nixpkgs lib defines those in Nix), + -- and functionArgs never consults __functionArgs - a functor set + -- is an error, as upstream throws (lib.functionArgs unwraps + -- functor sets itself before reaching the builtin). + runTest "no invented arithmetic builtins" $ + assertEval + "no-fake-builtins" + "!(builtins ? mod) && !(builtins ? min) && !(builtins ? max) && !(builtins ? setFunctionArgs)" + (VBool True), + runTest "functionArgs rejects functor sets" $ + assertEvalFail + "funcArgs-functor-err" + "builtins.functionArgs { __functor = self: x: x; __functionArgs = { a = false; }; }", + -- zipAttrsWith + runTest "zipAttrsWith basic" $ + assertEval + "zipAttrs" + "(builtins.zipAttrsWith (name: vals: builtins.head vals) [ { a = 1; } { a = 2; b = 3; } ]).b" + (VInt 3), + runTest "zipAttrsWith collect" $ + assertEval + "zipAttrs-collect" + "builtins.length (builtins.zipAttrsWith (name: vals: vals) [ { a = 1; } { a = 2; } ]).a" + (VInt 2) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 4 - String operations +-- --------------------------------------------------------------------------- + +testBatch4 :: IO [Bool] +testBatch4 = do + putStrLn "eval/builtins-batch4" + sequence + [ -- replaceStrings + runTest "replaceStrings basic" $ + assertEval "replace" "builtins.replaceStrings [ \"o\" ] [ \"0\" ] \"foobar\"" (mkStr "f00bar"), + runTest "replaceStrings multi" $ + assertEval "replace-multi" "builtins.replaceStrings [ \"a\" \"b\" ] [ \"A\" \"B\" ] \"abc\"" (mkStr "ABc"), + runTest "replaceStrings empty from" $ + assertEval "replace-empty" "builtins.replaceStrings [ \"\" ] [ \"x\" ] \"ab\"" (mkStr "xaxbx"), + runTest "replaceStrings no match" $ + assertEval "replace-nomatch" "builtins.replaceStrings [ \"z\" ] [ \"Z\" ] \"abc\"" (mkStr "abc"), + -- Match-gated forcing: an unmatched replacement is never evaluated. + runTest "replaceStrings never forces an unmatched replacement" $ + assertEval "replace-lazy" "builtins.replaceStrings [ \"z\" ] [ (builtins.throw \"unused\") ] \"abc\"" (mkStr "abc"), + -- compareVersions + runTest "compareVersions equal" $ + assertEval "cmpVer-eq" "builtins.compareVersions \"1.2.3\" \"1.2.3\"" (VInt 0), + runTest "compareVersions less" $ + assertEval "cmpVer-lt" "builtins.compareVersions \"1.2\" \"1.3\"" (VInt (-1)), + runTest "compareVersions greater" $ + assertEval "cmpVer-gt" "builtins.compareVersions \"2.0\" \"1.9\"" (VInt 1), + runTest "compareVersions type error" $ + assertEvalFail "cmpVer-err" "builtins.compareVersions 1 2", + runTest "compareVersions treats - as a separator" $ + assertEval "cmpVer-dash" "builtins.compareVersions \"1.0-2\" \"1.0.2\"" (VInt 0), + -- splitVersion + runTest "splitVersion basic" $ + assertEval "splitVer" "builtins.splitVersion \"1.2.3\" == [ \"1\" \"2\" \"3\" ]" (VBool True), + runTest "splitVersion pre" $ + assertEval "splitVer-pre" "builtins.splitVersion \"1.2pre\" == [ \"1\" \"2\" \"pre\" ]" (VBool True), + runTest "splitVersion type error" $ + assertEvalFail "splitVer-err" "builtins.splitVersion 42", + -- parseDrvName + runTest "parseDrvName basic" $ + assertEval "parseDrv" "(builtins.parseDrvName \"hello-1.2.3\").name" (mkStr "hello"), + runTest "parseDrvName version" $ + assertEval "parseDrv-ver" "(builtins.parseDrvName \"hello-1.2.3\").version" (mkStr "1.2.3"), + runTest "parseDrvName no version" $ + assertEval "parseDrv-nover" "(builtins.parseDrvName \"hello\").version" (mkStr ""), + runTest "parseDrvName type error" $ + assertEvalFail "parseDrv-err" "builtins.parseDrvName 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 5 - Serialization + hashing +-- --------------------------------------------------------------------------- + +testBatch5 :: IO [Bool] +testBatch5 = do + putStrLn "eval/builtins-batch5" + sequence + [ -- toJSON + runTest "toJSON int" $ + assertEval "toJSON-int" "builtins.toJSON 42" (mkStr "42"), + runTest "toJSON string" $ + assertEval "toJSON-str" "builtins.toJSON \"hello\"" (mkStr "\"hello\""), + runTest "toJSON null" $ + assertEval "toJSON-null" "builtins.toJSON null" (mkStr "null"), + runTest "toJSON bool" $ + assertEval "toJSON-bool" "builtins.toJSON true" (mkStr "true"), + runTest "toJSON list" $ + assertEval "toJSON-list" "builtins.toJSON [ 1 2 3 ]" (mkStr "[1,2,3]"), + runTest "toJSON attrs" $ + assertEval "toJSON-attrs" "builtins.toJSON { a = 1; }" (mkStr "{\"a\":1}"), + runTest "toJSON lambda error" $ + assertEvalFail "toJSON-fn" "builtins.toJSON (x: x)", + -- fromJSON + runTest "fromJSON int" $ + assertEval "fromJSON-int" "builtins.fromJSON \"42\"" (VInt 42), + runTest "fromJSON string" $ + assertEval "fromJSON-str" "builtins.fromJSON \"\\\"hello\\\"\"" (mkStr "hello"), + runTest "fromJSON null" $ + assertEval "fromJSON-null" "builtins.fromJSON \"null\"" VNull, + runTest "fromJSON bool" $ + assertEval "fromJSON-bool" "builtins.fromJSON \"true\"" (VBool True), + runTest "fromJSON array" $ + assertEval "fromJSON-arr" "builtins.length (builtins.fromJSON \"[1,2,3]\")" (VInt 3), + runTest "fromJSON object" $ + assertEval "fromJSON-obj" "(builtins.fromJSON \"{\\\"a\\\": 1}\").a" (VInt 1), + runTest "fromJSON roundtrip" $ + assertEval "fromJSON-rt" "let x = builtins.fromJSON (builtins.toJSON { a = 1; b = [ 2 3 ]; }); in x.a == 1 && x.b == [ 2 3 ]" (VBool True), + runTest "fromJSON invalid" $ + assertEvalFail "fromJSON-bad" "builtins.fromJSON \"not json\"", + -- The integer range as json-to-value.cc has it at 2.25 and after. + runTest "fromJSON reads the largest int" $ + assertEval "fromJSON-int-max" "builtins.fromJSON \"9223372036854775807\"" (VInt 9223372036854775807), + runTest "fromJSON reads the smallest int" $ + assertEval "fromJSON-int-min" "builtins.fromJSON \"-9223372036854775808\"" (VInt (-9223372036854775808)), + runTest "fromJSON refuses one past the largest int" $ + assertEvalError "fromJSON-past-int" "builtins.fromJSON \"9223372036854775808\"" "unsigned json number 9223372036854775808 outside of Nix integer range", + runTest "fromJSON refuses the largest unsigned" $ + assertEvalError "fromJSON-uint-max" "builtins.fromJSON \"18446744073709551615\"" "unsigned json number 18446744073709551615 outside of Nix integer range", + runTest "fromJSON refuses an unsigned number inside a list" $ + assertEvalError "fromJSON-uint-list" "builtins.fromJSON \"[1,[18446744073709551615]]\"" "unsigned json number 18446744073709551615 outside of Nix integer range", + runTest "fromJSON refuses an unsigned number inside a set" $ + assertEvalError "fromJSON-uint-set" "builtins.fromJSON ''{\"a\":18446744073709551615}''" "unsigned json number 18446744073709551615 outside of Nix integer range", + runTest "fromJSON names the first such number in the document, not in key order" $ + assertEvalError "fromJSON-uint-order" "builtins.fromJSON ''{\"b\":18446744073709551615,\"a\":9223372036854775808}''" "unsigned json number 18446744073709551615 outside of Nix integer range", + runTest "fromJSON refuses such a number ahead of a later syntax error" $ + assertEvalError "fromJSON-uint-syntax" "builtins.fromJSON \"[18446744073709551615,nonsense\"" "unsigned json number 18446744073709551615 outside of Nix integer range", + -- nlohmann's grammar (json-to-value.cc at 2.24.9), strict RFC 8259: + -- each case below is refused or read as nix-instantiate reads it. + runTest "fromJSON reads the backspace and form feed escapes" $ + assertEval "fromJSON-bf" "builtins.fromJSON ''\"a\\bb\\fc\"''" (mkStr "a\bb\fc"), + runTest "fromJSON reads a surrogate pair" $ + assertEval "fromJSON-pair" "builtins.fromJSON ''\"\\ud83d\\ude00\"''" (mkStr "\128512"), + runTest "fromJSON skips a leading byte order mark" $ + assertEval "fromJSON-bom" "builtins.fromJSON \"\65279 1\"" (VInt 1), + runTest "fromJSON refuses an unterminated string" $ + assertEvalError "fromJSON-unterminated" "builtins.fromJSON ''\"abc''" "unterminated string", + runTest "fromJSON refuses a trailing comma in an array" $ + assertEvalError "fromJSON-array-comma" "builtins.fromJSON \"[1,]\"" "unexpected ']', expected a JSON value", + runTest "fromJSON refuses a trailing comma in an object" $ + assertEvalError "fromJSON-object-comma" "builtins.fromJSON ''{\"a\":1,}''" "unexpected '}' in an object, expected a member name", + runTest "fromJSON refuses a leading zero" $ + assertEvalError "fromJSON-leading-zero" "builtins.fromJSON \"01\"" "unexpected content after the JSON value: '1'", + runTest "fromJSON refuses a raw control character in a string" $ + assertEvalError "fromJSON-raw-tab" "builtins.fromJSON \"\\\"a\\tb\\\"\"" "control character U+0009 must be escaped", + runTest "fromJSON refuses a \\u escape short of four hex digits" $ + assertEvalError "fromJSON-short-u" "builtins.fromJSON ''\"\\u12\"''" "invalid \\u escape '12\"'", + runTest "fromJSON refuses a lone high surrogate" $ + assertEvalError "fromJSON-lone-high" "builtins.fromJSON ''\"\\ud800\"''" "a high surrogate must be followed by a low surrogate", + runTest "fromJSON refuses a lone low surrogate" $ + assertEvalError "fromJSON-lone-low" "builtins.fromJSON ''\"\\udc00\"''" "a low surrogate must follow a high surrogate", + runTest "fromJSON refuses an unknown escape" $ + assertEvalError "fromJSON-bad-escape" "builtins.fromJSON ''\"a\\x\"''" "invalid escape \\x", + runTest "fromJSON refuses a number past the double range" $ + assertEvalError "fromJSON-overflow" "builtins.fromJSON \"1e400\"" "number overflow parsing '1e400'", + runTest "fromJSON refuses whitespace JSON does not define" $ + assertEvalError "fromJSON-nbsp" "builtins.fromJSON \"\160 1\"" "unexpected '\160 1', expected a JSON value", + runTest "fromJSON refuses a vertical tab around a value" $ + assertEvalError "fromJSON-vt" "builtins.fromJSON \"\v1\"" "unexpected '\v1', expected a JSON value", + -- hashString + runTest "hashString sha256" $ + assertEval "hash-sha256" "builtins.hashString \"sha256\" \"hello\"" (mkStr "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824"), + runTest "hashString md5" $ + assertEval "hash-md5" "builtins.hashString \"md5\" \"hello\"" (mkStr "5d41402abc4b2a76b9719d911017c592"), + runTest "hashString sha1" $ + assertEval "hash-sha1" "builtins.hashString \"sha1\" \"hello\"" (mkStr "aaf4c61ddcc5e8a2dabede0f3b482cd9aea9434d"), + runTest "hashString unknown algo" $ + assertEvalFail "hash-bad" "builtins.hashString \"sha999\" \"hello\"", + runTest "hashString type error" $ + assertEvalFail "hash-err" "builtins.hashString \"sha256\" 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 6 - tryEval + deepSeq +-- --------------------------------------------------------------------------- + +testBatch6 :: IO [Bool] +testBatch6 = do + putStrLn "eval/builtins-batch6" + sequence + [ -- tryEval success + runTest "tryEval success" $ + assertEval "tryEval-ok" "(builtins.tryEval 42).value" (VInt 42), + runTest "tryEval success flag" $ + assertEval "tryEval-flag" "(builtins.tryEval 42).success" (VBool True), + -- tryEval failure + runTest "tryEval catches throw" $ + assertEval "tryEval-throw" "(builtins.tryEval (builtins.throw \"boom\")).success" (VBool False), + runTest "tryEval failure value" $ + assertEval "tryEval-fval" "(builtins.tryEval (builtins.throw \"boom\")).value" (VBool False), + -- tryEval catches ONLY throw/assert (upstream ThrownError/ + -- AssertionError); type errors and missing attrs escape it. + runTest "tryEval catches failed assert" $ + assertEval "tryEval-assert" "(builtins.tryEval (assert false; 1)).success" (VBool False), + runTest "tryEval does not catch a type error" $ + assertEvalFail "tryEval-tyerr" "(builtins.tryEval ({} + [])).success", + runTest "tryEval does not catch a missing attribute" $ + assertEvalFail "tryEval-noattr" "(builtins.tryEval ({ a = 1; }.b)).success", + runTest "tryEval catches a throw nested under forcing" $ + assertEval "tryEval-deep-throw" "(builtins.tryEval (builtins.deepSeq [ (builtins.throw \"x\") ] 1)).success" (VBool False), + -- tryEval passed as a VALUE (comparator/element positions) instead + -- of applied syntactically: every application path must keep the + -- catch around the argument's evaluation, and none may leak the + -- old internal 'unreachable' dispatch error. + runTest "tryEval as sort comparator fails like upstream" $ + case evalNix "builtins.sort builtins.tryEval [ 1 2 ]" of + Left err + | "unreachable" `T.isInfixOf` err -> Fail ("internal error leaked: " <> err) + | otherwise -> Pass + Right v -> Fail ("expected a boolean-coercion failure, got " <> T.pack (show v)), + runTest "tryEval via map catches a throwing element" $ + assertEval + "tryEval-map" + "(builtins.elemAt (builtins.map builtins.tryEval [ (builtins.throw \"m\") ]) 0).success" + (VBool False), + runTest "tryEval via map success-wraps a clean element" $ + assertEval + "tryEval-map-ok" + "(builtins.elemAt (builtins.map builtins.tryEval [ 7 ]) 0).value" + (VInt 7), + runTest "tryEval through filter catches the element throw" $ + case evalNix "builtins.filter builtins.tryEval [ (builtins.throw \"leaked\") ]" of + Left err + | "leaked" `T.isInfixOf` err -> Fail ("throw escaped tryEval: " <> err) + | otherwise -> Pass + Right v -> Fail ("expected a boolean-coercion failure, got " <> T.pack (show v)), + runTest "functor returning tryEval keeps the catch" $ + assertEval + "tryEval-functor" + "(({ __functor = self: builtins.tryEval; }) (builtins.throw \"f\")).success" + (VBool False), + -- deepSeq + runTest "deepSeq returns second" $ + assertEval "deepSeq" "builtins.deepSeq [ 1 2 3 ] 42" (VInt 42), + runTest "deepSeq forces nested" $ + assertEvalFail "deepSeq-err" "builtins.deepSeq [ (builtins.throw \"boom\") ] 42", + runTest "deepSeq forces attrs" $ + assertEvalFail "deepSeq-attr" "builtins.deepSeq { a = builtins.throw \"boom\"; } 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch 7 - genericClosure +-- --------------------------------------------------------------------------- + +testBatch7 :: IO [Bool] +testBatch7 = do + putStrLn "eval/builtins-batch7" + sequence + [ runTest "genericClosure basic" $ + assertEval + "closure-basic" + "builtins.length (builtins.genericClosure { startSet = [ { key = 1; } ]; operator = item: [ ]; })" + (VInt 1), + runTest "genericClosure expansion" $ + assertEval + "closure-expand" + "builtins.length (builtins.genericClosure { startSet = [ { key = 1; next = 2; } ]; operator = item: if item.next == 0 then [ ] else [ { key = item.next; next = 0; } ]; })" + (VInt 2), + runTest "genericClosure dedup" $ + assertEval + "closure-dedup" + "builtins.length (builtins.genericClosure { startSet = [ { key = 1; } { key = 1; } ]; operator = item: [ ]; })" + (VInt 1), + runTest "genericClosure missing startSet" $ + assertEvalFail "closure-nostart" "builtins.genericClosure { operator = x: [ ]; }", + runTest "genericClosure type error" $ + assertEvalFail "closure-tyerr" "builtins.genericClosure 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: import and IO builtins (pure) +-- --------------------------------------------------------------------------- + +testImportPure :: IO [Bool] +testImportPure = do + putStrLn "eval/import-pure" + sequence + [ runTest "import errors in pure mode" $ + assertEvalFail "import-pure" "import ./foo.nix", + runTest "builtins.typeOf import is lambda" $ + assertEval "typeof-import" "builtins.typeOf import" (mkStr "lambda"), + runTest "pathExists returns false in pure mode" $ + assertEval "pathExists-pure" "builtins.pathExists ./nonexistent" (VBool False), + runTest "readFile errors in pure mode" $ + assertEvalFail "readFile-pure" "builtins.readFile ./foo.nix", + runTest "readDir errors in pure mode" $ + assertEvalFail "readDir-pure" "builtins.readDir ./some-dir" + ] + +-- --------------------------------------------------------------------------- +-- Tests: import and IO builtins (IO) +-- --------------------------------------------------------------------------- + +-- | Parse and evaluate Nix source using the IO evaluator. +-- | The per-suite temp store 'evalNixIO' evaluates against, exposed so +-- a test inspecting materialized trees resolves the same directory. +evalNixIOStoreDir :: IO StoreDir +evalNixIOStoreDir = do + tmpBase <- getTemporaryDirectory + pure (StoreDir (tmpBase "nova-nix-test-eval-store")) + +-- | IO eval against a per-suite temp store, so no test needs a real, +-- writable platform store root: eval-time store writes land under the +-- temp directory, and the suite runs everywhere without provisioning. +evalNixIO :: FilePath -> Text -> IO (Either Text NixValue) +evalNixIO baseDir source = do + storeDir <- evalNixIOStoreDir + evalNixIOStore storeDir baseDir source + +-- | 'evalNixIO' keeping a failure whole, its lines of context included. +evalNixIOTraced :: FilePath -> Text -> IO (Either EvalFailure NixValue) +evalNixIOTraced baseDir source = case parseNix baseDir testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left (EvalFailure [] (T.pack (show err)))) + Right expr -> do + storeDir <- evalNixIOStoreDir + st <- newEvalState storeDir baseDir + runEvalIOTraced st (eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr) + +-- | IO eval of a derivation expression to the 'Derivation' the session +-- recorded for it: forcing the expression's @drvPath@ runs derivationStrict, +-- which records the @.drv@ under that path, and the recipe is read back the +-- way the build driver reads it. Only the IO evaluator keeps the record. +evalDerivationIO :: FilePath -> Text -> IO (Either Text Derivation) +evalDerivationIO baseDir source = case parseNix baseDir testOrigin (TE.encodeUtf8 ("(" <> source <> ").drvPath")) of + Left err -> pure (Left (T.pack (show err))) + Right expr -> do + storeDir <- evalNixIOStoreDir + st <- newEvalState storeDir baseDir + runEvalIO st $ do + pathVal <- eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr + case pathVal of + VStr pathBytes _ -> do + recorded <- lookupSessionDrv (bytesText pathBytes) + maybe (throwEvalError ("no .drv was recorded for " <> bytesText pathBytes)) pure recorded + other -> throwEvalError ("expected a drvPath string, got " <> typeName other) + +-- | Run a named IO eval test - single label, no double-wrapping. +runTestIO :: Text -> FilePath -> Text -> NixValue -> IO Bool +runTestIO label baseDir source expected = do + result <- evalNixIO baseDir source + runTest label $ assertRight label result $ \actual -> + assertEqual label expected actual + +-- | Run a named IO eval test that should fail. +runTestIOFail :: Text -> FilePath -> Text -> IO Bool +runTestIOFail label baseDir source = do + result <- evalNixIO baseDir source + runTest label $ assertLeft label result + +-- | Quoted path literal for embedding absolute paths in Nix source. +nixQuotedPath :: FilePath -> Text +nixQuotedPath p = T.pack (show p) + +-- | The name, builder and system of a derivation, read as upstream's +-- derivationStrict reads them (primops.cc at 2.24.9): the name with +-- forceStringNoCtx, the builder and system as their environment entries +-- coerce, each checked for presence once all are read. Every expected +-- message is nix-instantiate 2.24.9's final error line. +testDerivationFields :: IO [Bool] +testDerivationFields = do + putStrLn "eval/derivation-fields" + let drvWith fields = "(derivation { " <> fields <> " }).drvPath" + plain = "system = \"x\"; builder = \"/bin/sh\";" + withDep body = "let d = derivation { name = \"d\"; " <> plain <> " }; in " <> body + fails label source expected = runTest label (assertEvalError label source expected) + depOut = "/nix/store/simq0c07kvm2wyvasl0k1f619wishj4y-d" + depDrv = "wwk71dy0w17kn5spjd8hbsrk6520xs11-d.drv" + sequence + [ fails "a name that is not a string is refused" (drvWith ("name = 1; " <> plain)) "expected a string but found an integer: 1", + fails "a name with an output's context names it" (withDep (drvWith ("name = \"x${d}\"; " <> plain))) ("the string 'x" <> depOut <> "' is not allowed to refer to a store path (such as '!out!" <> depDrv <> "')"), + fails "a name with a drvPath's context names it" (withDep (drvWith ("name = \"x${d.drvPath}\"; " <> plain))) ("the string 'x/nix/store/" <> depDrv <> "' is not allowed to refer to a store path (such as '=" <> depDrv <> "')"), + fails "a plain path comes first among a name's context" (withDep (drvWith ("name = builtins.appendContext \"x${d}\" { \"/nix/store/00000000000000000000000000000000-a\" = { path = true; }; }; " <> plain))) ("the string 'x" <> depOut <> "' is not allowed to refer to a store path (such as '00000000000000000000000000000000-a')"), + fails "all outputs come before one among a name's context" (withDep (drvWith ("name = \"x${d}${d.drvPath}\"; " <> plain))) ("the string 'x" <> depOut <> "/nix/store/" <> depDrv <> "' is not allowed to refer to a store path (such as '=" <> depDrv <> "')"), + fails "an absent name is getAttr's error" (drvWith plain) "attribute 'name' missing", + fails "an absent builder is refused" (drvWith "name = \"a\"; system = \"x\";") "required attribute 'builder' missing", + fails "an empty builder is refused as absent" (drvWith "name = \"a\"; system = \"x\"; builder = \"\";") "required attribute 'builder' missing", + fails "an empty system is refused as absent" (drvWith "name = \"a\"; system = \"\"; builder = \"/bin/sh\";") "required attribute 'system' missing", + fails "the builder is checked before the system" (drvWith "name = \"a\";") "required attribute 'builder' missing", + fails "an empty name is invalid" (drvWith ("name = \"\"; " <> plain)) "invalid derivation name: name must not be empty. Please pass a different 'name'.", + fails "a dot name is invalid" (drvWith ("name = \".\"; " <> plain)) "invalid derivation name: name '.' is not valid. Please pass a different 'name'.", + fails "a dot component is invalid" (drvWith ("name = \".-a\"; " <> plain)) "invalid derivation name: name '.-a' is not valid: first dash-separated component must not be '.'. Please pass a different 'name'.", + fails "an illegal character is named" (drvWith ("name = \"a b\"; " <> plain)) "invalid derivation name: name 'a b' contains illegal character ' '. Please pass a different 'name'." + ] + +-- | A path as a derivation's builder or system is copied to the store, as +-- its environment entry is, so the .drv's builder and platform fields hold +-- the store path. Each drvPath is nix-instantiate 2.24.9's. +testDerivationPathFieldsIO :: IO [Bool] +testDerivationPathFieldsIO = do + putStrLn "eval/derivation-path-fields-io" + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-derivation-path-fields" + drvPathOf fields = "builtins.unsafeDiscardStringContext (derivation { name = \"a\"; " <> fields <> " }).drvPath" + script = "/. + " <> nixQuotedPath (dir "b.sh") + Dir.removePathForcibly dir + createDirectoryIfMissing True dir + BS.writeFile (dir "b.sh") "echo hi\n" + results <- + sequence + [ runTestIO "a path builder is copied to the store" dir (drvPathOf ("system = \"x\"; builder = " <> script <> ";")) (mkStr "/nix/store/gz23n4381jlqwn1gvjqgs3411vr3w4nx-a.drv"), + runTestIO "a path system is copied to the store" dir (drvPathOf ("system = " <> script <> "; builder = \"/bin/sh\";")) (mkStr "/nix/store/382y120pp033h5kx5zfw02q0pglf297l-a.drv") + ] + Dir.removePathForcibly dir + pure results + +-- | A builtin taking a path coerces its argument as upstream's +-- coerceToPath does (eval.cc at 2.24.9), and baseNameOf and dirOf as +-- their coerceToString does. Each expected value or message is +-- nix-instantiate 2.24.9's. +testPathArguments :: IO [Bool] +testPathArguments = do + putStrLn "eval/path-arguments" + let refuses label source = runTest label (assertEvalError label source "cannot coerce an integer to a string: 1") + fails label source expected = runTest label (assertEvalError label source expected) + gives label source expected = runTest label (assertEval label source expected) + sequence + [ refuses "readFile coerces its argument" "builtins.readFile 1", + refuses "readDir coerces its argument" "builtins.readDir 1", + refuses "pathExists coerces its argument" "builtins.pathExists 1", + refuses "hashFile coerces its path" "builtins.hashFile \"sha256\" 1", + refuses "readFileType coerces its argument" "builtins.readFileType 1", + refuses "import coerces its argument" "import 1", + refuses "scopedImport coerces its path" "builtins.scopedImport { } 1", + refuses "builtins.path coerces its path" "builtins.path { path = 1; }", + refuses "filterSource coerces its path" "builtins.filterSource (p: t: true) 1", + refuses "toPath coerces its argument" "builtins.toPath 1", + fails "a coerced path must be absolute" "builtins.toPath \"a\"" "string 'a' doesn't represent an absolute path", + fails "builtins.path needs a path" "builtins.path { name = \"x\"; }" "missing required 'path' attribute in the first argument to builtins.path", + fails "baseNameOf refuses null as coerceToString does" "builtins.baseNameOf null" "cannot coerce null to a string: null", + fails "dirOf refuses a Boolean as coerceToString does" "builtins.dirOf true" "cannot coerce a Boolean to a string: true", + gives "toPath gives a string" "builtins.typeOf (builtins.toPath \"/a/b\")" (mkStr "string"), + gives "toPath canonicalizes an outPath" "builtins.toPath { outPath = \"/a//b/\"; }" (mkStr "/a/b"), + gives "toPath keeps the context it coerced" "let d = derivation { name = \"d\"; system = \"x\"; builder = \"/bin/sh\"; }; in builtins.concatStringsSep \",\" (builtins.attrNames (builtins.getContext (builtins.toPath \"${d}/bin\")))" (mkStr "/nix/store/wwk71dy0w17kn5spjd8hbsrk6520xs11-d.drv"), + gives "baseNameOf takes a __toString" "builtins.baseNameOf { __toString = s: \"/a/b\"; }" (mkStr "b"), + gives "dirOf takes an outPath, giving a string" "builtins.dirOf { outPath = /a/b; }" (mkStr "/a"), + gives "dirOf of a path stays a path" "builtins.typeOf (builtins.dirOf /a/b)" (mkStr "path") + ] + +-- | The same coercion reaching the filesystem: an outPath or a __toString +-- names the file read. +testPathArgumentsIO :: IO [Bool] +testPathArgumentsIO = do + putStrLn "eval/path-arguments-io" + -- readFileType refuses a symlink above its path, as upstream's does, and + -- macOS keeps the temporary directory under /var, a link. + tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory + let dir = tmpBase "nova-nix-test-path-arguments" + file = nixQuotedPath (dir "f") + Dir.removePathForcibly dir + createDirectoryIfMissing True dir + BS.writeFile (dir "f") "contents" + results <- + sequence + [ runTestIO "readFile reads an outPath" dir ("builtins.readFile { outPath = " <> file <> "; }") (mkStr "contents"), + runTestIO "pathExists follows an outPath" dir ("builtins.pathExists { outPath = " <> file <> "; }") (VBool True), + runTestIO "readFileType follows a __toString" dir ("builtins.readFileType { __toString = s: " <> file <> "; }") (mkStr "regular"), + runTestIO "hashFile hashes an outPath" dir ("builtins.hashFile \"sha256\" { outPath = " <> file <> "; }") (mkStr "d1b2a59fbea7e20077af9f91b27e95e865061b270be03ff539ab3b73587882e8") + ] + Dir.removePathForcibly dir + pure results + +-- | The lines of context a failure gathers on its way out of +-- derivationStrict, and how the CLI reports them (#221). Only the IO +-- evaluator keeps them. +testDerivationTraceIO :: IO [Bool] +testDerivationTraceIO = do + putStrLn "eval/derivation-trace" + let derivationFailure attrs expected = do + tmpBase <- getTemporaryDirectory + result <- evalNixIOTraced tmpBase ("(derivation { builder = \"b\"; " <> attrs <> " }).drvPath") + pure $ case result of + Left failure -> assertEqual "derivation-failure" expected failure + Right val -> Fail ("expected a failure, got " <> T.pack (show val)) + sequence + [ -- A failure processing one attribute carries upstream's line naming + -- it and its derivation (derivationStrictInternal, primops.cc at + -- 2.24.9); the message itself is unchanged. + runTestM + "a failing derivation attribute is named in the failure's trace" + ( derivationFailure + "system = \"s\"; name = \"x\"; foo = { };" + (EvalFailure ["while evaluating attribute 'foo' of derivation 'x'"] "cannot coerce a set to a string: { }") + ), + runTestM + "a structured attribute with no JSON form is named in the failure's trace" + ( derivationFailure + "system = \"s\"; name = \"x\"; __structuredAttrs = true; foo = x: x;" + (EvalFailure ["while evaluating attribute 'foo' of derivation 'x'"] "builtins.toJSON: cannot convert a function to JSON") + ), + -- prim_derivationStrict adds its own line outside forceStringNoCtx's. + runTestM + "a failing name carries both of upstream's lines" + ( derivationFailure + "system = \"s\"; name = throw \"n\";" + ( EvalFailure + [ "while evaluating the derivation attribute 'name'", + "while evaluating the `name` attribute passed to builtins.derivationStrict" + ] + "n" + ) + ), + runTestM + "a switch that is not a Boolean is named in the failure's trace" + ( derivationFailure + "system = \"s\"; name = \"x\"; __ignoreNulls = 1;" + (EvalFailure ["while evaluating the `__ignoreNulls` attribute passed to builtins.derivationStrict"] "expected a Boolean but found an integer: 1") + ), + runTestM + "a structured-attributes switch that is not a Boolean is named in the failure's trace" + ( derivationFailure + "system = \"s\"; name = \"x\"; __structuredAttrs = 1;" + (EvalFailure ["while evaluating the `__structuredAttrs` attribute passed to builtins.derivationStrict"] "expected a Boolean but found an integer: 1") + ), + runTestM + "a structured string field that is not a string is named in the failure's trace" + ( derivationFailure + "system = \"s\"; name = \"x\"; __structuredAttrs = true; outputHash = 1;" + (EvalFailure ["while evaluating attribute 'outputHash' of derivation 'x'"] "expected a string but found an integer: 1") + ), + runTestM + "a missing attribute is refused without a line naming it" + (derivationFailure "name = \"x\";" (EvalFailure [] "required attribute 'system' missing")), + runTestM "a failure in a dependency is traced through each derivation, outermost first" $ do + tmpBase <- getTemporaryDirectory + result <- + evalNixIOTraced tmpBase $ + "let inner = derivation { name = \"inner\"; system = \"s\"; builder = \"b\"; bad = { }; };" + <> " in (derivation { name = \"outer\"; system = \"s\"; builder = \"b\"; dep = inner; }).drvPath" + pure $ case result of + Left failure -> + assertEqual + "nested-trace" + ["while evaluating attribute 'dep' of derivation 'outer'", "while evaluating attribute 'bad' of derivation 'inner'"] + (failureTrace failure) + Right val -> Fail ("expected a failure, got " <> T.pack (show val)), + runTestM "a throw in a derivation attribute stays catchable" $ do + tmpBase <- getTemporaryDirectory + result <- evalNixIO tmpBase "(builtins.tryEval (derivation { name = \"x\"; system = \"s\"; builder = \"b\"; foo = throw \"t\"; }).drvPath).success" + pure $ assertRight "trace-catchable" result (assertEqual "trace-catchable" (VBool False)), + -- upstream's showErrorInfo and indent (error.cc at 2.24.9), checked + -- against nix-instantiate 2.24.9's report for the same failure with + -- its positioned lines left out. + runTest "a failure renders as upstream reports it" $ + assertEqual + "render-traced" + "error:\n \x2026 while evaluating attribute 'foo' of derivation 'x'\n\n error: a\n b" + (renderEvalFailure (EvalFailure ["while evaluating attribute 'foo' of derivation 'x'"] "a\nb")), + runTest "a failure with no trace renders on the error line" $ + assertEqual "render-untraced" "error: a\n b" (renderEvalFailure (EvalFailure [] "a\nb")) + ] + +-- | Regression: a thunk whose force throws a catchable error (builtins.throw, +-- a type error) must be restored to PENDING, not left BLACKHOLE - otherwise a +-- later force of the same shared thunk aborts with a bogus "infinite recursion" +-- that escapes tryEval. Genuine self-recursion must still escape tryEval. +-- EvalIO-only: PureEval never blackholes. +testBlackholeRecoveryIO :: IO [Bool] +testBlackholeRecoveryIO = do + putStrLn "eval/blackhole-recovery-io" + sequence + [ runTestIO + "tryEval twice on a shared throwing thunk recovers (no bogus recursion)" + "." + "let x = builtins.throw \"boom\"; in (if (builtins.tryEval x).success then 1 else 0) + (if (builtins.tryEval x).success then 1 else 0)" + (VInt 0), + runTestIOFail + "genuine infinite recursion still escapes tryEval" + "." + "builtins.tryEval (let y = y; in y)" + ] + +-- | builtins.path/filterSource with a filter: the tree is serialized with +-- rejected entries removed (a rejected directory prunes its subtree), +-- content-addressed over the FILTERED NAR, and materialized to the store. +testPathFilterIO :: IO [Bool] +testPathFilterIO = do + putStrLn "eval/path-filter-io" + testPathFilterBody + +testPathFilterBody :: IO [Bool] +testPathFilterBody = do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-path-filter" + setup = do + removeIfExists srcDir + createDirectoryIfMissing True (srcDir "sub") + createDirectoryIfMissing True (srcDir "dropdir") + BS.writeFile (srcDir "keep.txt") "keep" + BS.writeFile (srcDir "drop.log") "drop" + BS.writeFile (srcDir "sub" "inner.txt") "inner" + BS.writeFile (srcDir "dropdir" "x.txt") "gone" + quoted = nixQuotedPath srcDir + filterExpr = "(p: t: builtins.match \".*[.]log\" p == null && baseNameOf p != \"dropdir\")" + filteredPath = "(builtins.path { path = " <> quoted <> "; name = \"src\"; filter = " <> filterExpr <> "; })" + unfilteredPath = "(builtins.path { path = " <> quoted <> "; name = \"src\"; })" + -- bracket_: cleanup runs even if tests throw + bracket_ setup (removeIfExists srcDir) $ + sequence + [ runTestIO + "kept file survives with its content" + "." + ("builtins.readFile (" <> filteredPath <> " + \"/keep.txt\")") + (mkStr "keep"), + runTestIO + "kept subtree survives" + "." + ("builtins.readFile (" <> filteredPath <> " + \"/sub/inner.txt\")") + (mkStr "inner"), + runTestIO + "rejected file is dropped" + "." + ("builtins.pathExists (" <> filteredPath <> " + \"/drop.log\")") + (VBool False), + runTestIO + "rejected directory prunes its subtree" + "." + ("builtins.pathExists (" <> filteredPath <> " + \"/dropdir\")") + (VBool False), + runTestIO + "filtered and unfiltered store paths differ" + "." + (filteredPath <> " == " <> unfilteredPath) + (VBool False), + runTestIO + "same filter yields the same store path" + "." + (filteredPath <> " == " <> filteredPath) + (VBool True), + runTestIO + "filterSource is path-with-filter under the source basename" + "." + ( "builtins.filterSource (p: t: true) " + <> quoted + <> " == builtins.path { path = " + <> quoted + <> "; filter = (p: t: true); }" + ) + (VBool True) + ] + +-- | Whether this host can create symlinks (Windows needs Developer Mode +-- or elevation). The symlink-walk fixtures cannot be built without it, +-- so their groups skip loudly rather than fail. +symlinksAvailable :: IO Bool +symlinksAvailable = do + tmpBase <- getTemporaryDirectory + let probeDir = tmpBase "nova-nix-test-link-probe" + Dir.removePathForcibly probeDir + createDirectoryIfMissing True probeDir + BS.writeFile (probeDir "target.txt") "t" + outcome <- try (Dir.createFileLink "target.txt" (probeDir "link")) + Dir.removePathForcibly probeDir + pure $ case (outcome :: Either SomeException ()) of + Left _ -> False + Right () -> True + +-- | Interpolating a path that is a symlink copies what it points to, +-- under the link's own name: upstream's copyPathToStore stores +-- path.resolveSymlinks() under path.baseName() (eval.cc at 2.24.9). +testInterpolatedSymlinkIO :: IO [Bool] +testInterpolatedSymlinkIO = do + putStrLn "eval/interpolated-symlink-io" + canLink <- symlinksAvailable + if not canLink + then do + putStrLn " SKIP needs symlink privilege" + pure [] + else testInterpolatedSymlinkBody + +testInterpolatedSymlinkBody :: IO [Bool] +testInterpolatedSymlinkBody = do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-interpolated-symlink" + Dir.removePathForcibly dir + createDirectoryIfMissing True (dir "sub") + BS.writeFile (dir "data.txt") "linked bytes" + BS.writeFile (dir "sub" "inner.txt") "inner" + Dir.createFileLink "data.txt" (dir "filelink") + Dir.createDirectoryLink "sub" (dir "dirlink") + fileEntry <- NAR.serialiseFromPath (dir "data.txt") + dirEntry <- NAR.serialiseFromPath (dir "sub") + let interpolated name = evalNixIO "." ("\"${/. + " <> nixQuotedPath (dir name) <> "}\"") + copiedAs name entry = + either (const Nothing) (Just . storePathToText defaultStoreDir) (makeFixedOutputPath (T.pack name) "sha256" "recursive" (sha256Digest (NAR.serialise entry))) + copies name entry = runTestM ("interpolating " <> T.pack name <> " copies its target") $ do + result <- interpolated name + pure $ case (result, copiedAs name entry) of + (_, Nothing) -> Fail "fixture store path rejected" + (Right (VStr got _), Just expected) -> assertEqual (T.pack name) (TE.encodeUtf8 expected) got + (Right other, _) -> Fail ("expected a string, got " <> T.pack (show other)) + (Left err, _) -> Fail ("eval failed: " <> err) + results <- + sequence + [ copies "filelink" fileEntry, + copies "dirlink" dirEntry + ] + Dir.removePathForcibly dir + pure results + +-- | A failed source-path access reworded as upstream's PosixSourceAccessor +-- words it (2.24.9), from IOExceptions shaped as GHC raises them. +testSourceErrorMessage :: IO [Bool] +testSourceErrorMessage = do + putStrLn "eval/source-error-message" + let errnoFailure kind (Errno code) description = + IOError Nothing kind "test" description (Just code) (Just "/d/x") + absent = errnoFailure NoSuchThing eNOENT "No such file or directory" + notDirectory = errnoFailure InappropriateType eNOTDIR "Not a directory" + denied = errnoFailure PermissionDenied eACCES "Permission denied" + isDirectory = errnoFailure InappropriateType eISDIR "Is a directory" + -- GHC's openFile refuses a directory itself, with no errno. + ghcDirectory = IOError Nothing InappropriateType "openFile" "is a directory" Nothing (Just "/d/dir") + says label access path err expected = + runTest label (assertEqual label expected (sourceErrorMessage access path err)) + sequence + [ says "a stat of an absent path" StatPath "/d/nope" absent "path '/d/nope' does not exist", + says "a stat through a file is absent too" StatPath "/d/file/x" notDirectory "path '/d/file/x' does not exist", + says "a stat refused otherwise names the stat" StatPath "/d/x" denied "getting status of '/d/x': Permission denied", + says "opening an absent file" ReadFile "/d/nope" absent "opening file '/d/nope': No such file or directory", + says "opening a file refused" ReadFile "/d/x" denied "opening file '/d/x': Permission denied", + says "reading a directory as a file" ReadFile "/d/dir" isDirectory "reading from file '/d/dir': Is a directory", + says "GHC's own directory refusal reads as upstream's" ReadFile "/d/dir" ghcDirectory "reading from file '/d/dir': Is a directory", + says "listing a file" ReadDirectory "/d/file" notDirectory "reading directory /d/file: Not a directory" + ] + +-- | The same failures through the IO evaluator, against a real tree. +-- POSIX only: Windows reports its own error text, and a path there is +-- spelled with a drive. +testSourceReadErrorsIO :: IO [Bool] +testSourceReadErrorsIO = do + putStrLn "eval/source-read-errors-io" + if SI.os == "mingw32" + then do + putStrLn " SKIP POSIX error text" + pure [] + else testSourceReadErrorsBody + +testSourceReadErrorsBody :: IO [Bool] +testSourceReadErrorsBody = do + -- The temporary directory's own symlinks resolved (macOS keeps it under + -- /var, a link), so the only link in play is the one made below. + tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory + let dir = tmpBase "nova-nix-test-source-read-errors" + Dir.removePathForcibly dir + createDirectoryIfMissing True (dir "sub") + createDirectoryIfMissing True (dir "real") + BS.writeFile (dir "file") "f" + Dir.createDirectoryLink "real" (dir "link") + let resolved = T.pack dir + given = T.pack dir + at name = "/. + " <> nixQuotedPath (dir name) + fails label source expected = runTestM label (assertEvalErrorIO dir label source expected) + results <- + sequence + [ fails "readFile of an absent file" ("builtins.readFile (" <> at "nope" <> ")") ("opening file '" <> resolved <> "/nope': No such file or directory"), + fails "hashFile of an absent file" ("builtins.hashFile \"sha256\" (" <> at "nope" <> ")") ("opening file '" <> resolved <> "/nope': No such file or directory"), + fails "readFile through a file" ("builtins.readFile (" <> at "file/x" <> ")") ("opening file '" <> resolved <> "/file/x': Not a directory"), + fails "readFile of a directory" ("builtins.readFile (" <> at "sub" <> ")") ("reading from file '" <> resolved <> "/sub': Is a directory"), + fails "readDir of an absent directory" ("builtins.readDir (" <> at "nope" <> ")") ("reading directory " <> resolved <> "/nope: No such file or directory"), + fails "readDir of a file" ("builtins.readDir (" <> at "file" <> ")") ("reading directory " <> resolved <> "/file: Not a directory"), + fails "readFileType of an absent path" ("builtins.readFileType (" <> at "nope" <> ")") ("path '" <> given <> "/nope' does not exist"), + fails "interpolating an absent path" ("\"${" <> at "nope" <> "}\"") ("path '" <> resolved <> "/nope' does not exist"), + fails "builtins.path of an absent path" ("builtins.path { path = " <> at "nope" <> "; }") ("path '" <> resolved <> "/nope' does not exist"), + fails "importing an absent path" ("import (" <> at "nope" <> ")") ("path '" <> resolved <> "/nope' does not exist"), + fails "importing a directory without default.nix" ("import (" <> at "sub" <> ")") ("opening file '" <> resolved <> "/sub/default.nix': No such file or directory"), + -- Through a symlinked directory a read names the resolved path, as + -- realisePath resolves it, and readFileType refuses the link. + fails "readFile through a link names the resolved path" ("builtins.readFile (" <> at "link/nope" <> ")") ("opening file '" <> resolved <> "/real/nope': No such file or directory"), + fails "readDir through a link names the resolved path" ("builtins.readDir (" <> at "link/nope" <> ")") ("reading directory " <> resolved <> "/real/nope: No such file or directory"), + fails "import through a link names the resolved path" ("import (" <> at "link/nope" <> ")") ("path '" <> resolved <> "/real/nope' does not exist"), + fails "readFileType through a link refuses the link" ("builtins.readFileType (" <> at "link/nope" <> ")") ("path '" <> given <> "/link' is a symlink") + ] + Dir.removePathForcibly dir + pure results + +-- | Watchdog for cycle-termination tests: with symlinks as leaves every +-- walk returns promptly, while a regression to link-following recurses +-- forever - and a hung suite is worse than a failed one. +walkWatchdogMicros :: Int +walkWatchdogMicros = 30 * 1000 * 1000 + +-- | @builtins.path@ with no filter over a tree that contains a symlink. +-- The store-path name comes from the NAR serialization, which records +-- the link as a leaf entry - so the copy must replicate the link for +-- the stored bytes to still match the recorded content address. +testPathSymlinkIO :: IO [Bool] +testPathSymlinkIO = do + putStrLn "eval/path-symlink-io" + canLink <- symlinksAvailable + if not canLink + then do + putStrLn " SKIP needs symlink privilege" + pure [] + else testPathSymlinkBody + +testPathSymlinkBody :: IO [Bool] +testPathSymlinkBody = do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-path-symlink" + cycleDir = tmpBase "nova-nix-test-path-cycle" + Dir.removePathForcibly srcDir + Dir.removePathForcibly cycleDir + createDirectoryIfMissing True srcDir + BS.writeFile (srcDir "data.txt") "linked bytes" + Dir.createFileLink "data.txt" (srcDir "link") + createDirectoryIfMissing True cycleDir + BS.writeFile (cycleDir "f.txt") "f" + Dir.createDirectoryLink "." (cycleDir "loop") + linkEntry <- NAR.serialiseFromPath srcDir + cycleEntry <- NAR.serialiseFromPath cycleDir + let pathExprFor dir name = + "builtins.path { path = " <> nixQuotedPath dir <> "; name = \"" <> name <> "\"; }" + spFor name entry = + makeFixedOutputPath name "sha256" "recursive" (sha256Digest (NAR.serialise entry)) + results <- case (spFor "path-symlink-src" linkEntry, spFor "path-symlink-cycle" cycleEntry) of + (Right linkSp, Right cycleSp) -> do + -- The same mapping the evaluator's copy uses for its destination. + evalStore <- evalNixIOStoreDir + let linkDest = storePathToFilePath evalStore linkSp + cycleDest = storePathToFilePath evalStore cycleSp + -- A leftover materialization from an earlier (possibly pre-fix) run + -- would short-circuit the copy under test. + Dir.removePathForcibly linkDest + Dir.removePathForcibly cycleDest + linkEval <- evalNixIO "." (pathExprFor srcDir "path-symlink-src") + cycleEval <- timeout walkWatchdogMicros (evalNixIO "." (pathExprFor cycleDir "path-symlink-cycle")) + sequence + [ runTestM "unfiltered builtins.path replicates a symlink" $ + case linkEval of + Left err -> pure (Fail ("eval failed: " <> err)) + Right _ -> do + isLink <- Dir.pathIsSymbolicLink (linkDest "link") + if isLink + then do + target <- Dir.getSymbolicLinkTarget (linkDest "link") + pure (assertEqual "link target" "data.txt" target) + else pure (Fail "materialized 'link' is not a symlink"), + runTestM "materialized bytes reproduce the recorded content address" $ + case linkEval of + Left err -> pure (Fail ("eval failed: " <> err)) + Right _ -> do + onDisk <- NAR.serialiseFromPath linkDest + pure $ case spFor "path-symlink-src" onDisk of + Left err -> Fail ("on-disk tree's name rejected: " <> T.pack (show err)) + Right recomputed -> assertEqual "recomputed path" linkSp recomputed, + runTestM "builtins.path terminates on a link cycle" $ + case cycleEval of + Nothing -> pure (Fail "copy did not terminate on a link cycle") + Just (Left err) -> pure (Fail ("eval failed: " <> err)) + Just (Right _) -> do + isLink <- Dir.pathIsSymbolicLink (cycleDest "loop") + pure (if isLink then Pass else Fail "cycle link not replicated as a link") + ] + (badLink, badCycle) -> + sequence + [ runTest "path-symlink fixture store paths accepted" $ + Fail ("test store path rejected: " <> T.pack (show (badLink, badCycle))) + ] + Dir.removePathForcibly srcDir + Dir.removePathForcibly cycleDir + pure results + +testImportIO :: IO [Bool] +testImportIO = do + putStrLn "eval/import-io" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-import" + subDir = testDir "sub" + setup = do + createDirectoryIfMissing True subDir + TIO.writeFile (testDir "literal.nix") "42" + TIO.writeFile (testDir "expr.nix") "1 + 2" + TIO.writeFile (testDir "nested-inner.nix") "99" + TIO.writeFile (testDir "nested-outer.nix") "import ./nested-inner.nix" + TIO.writeFile (testDir "attrset.nix") "{ x = 1; y = 2; }" + TIO.writeFile (testDir "uses-arg.nix") "let f = x: x + 10; in f 5" + TIO.writeFile (testDir "positions.nix") "{\n a = 1;\n}\n" + TIO.writeFile (subDir "from-sub.nix") "7" + cleanup = do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + -- bracket_: cleanup runs even if tests throw + bracket_ setup cleanup $ + sequence + [ -- import + runTestIO "import literal" testDir "import ./literal.nix" (VInt 42), + runTestIO "import expression" testDir "import ./expr.nix" (VInt 3), + runTestIO "import nested (A imports B)" testDir "import ./nested-outer.nix" (VInt 99), + runTestIO + "import cache (same file twice)" + testDir + "(import ./literal.nix) + (import ./literal.nix)" + (VInt 84), + runTestIOFail "import nonexistent -> error" testDir "import ./nonexistent.nix", + runTestIO "import attrset + select" testDir "(import ./attrset.nix).x" (VInt 1), + runTestIO "import let/lambda" testDir "import ./uses-arg.nix" (VInt 15), + -- A position in an imported file names the file the import read. + -- The import runs from the directory's canonical spelling, where + -- the path as written (upstream's) and the path with its symlinks + -- resolved (the one the import reads here) are the same. + do + canonicalDir <- Dir.canonicalizePath testDir + file <- Dir.canonicalizePath (canonicalDir "positions.nix") + runTestIO + "unsafeGetAttrPos names the imported file" + canonicalDir + "let p = builtins.unsafeGetAttrPos \"a\" (import ./positions.nix); in \"${p.file}:${toString p.line}:${toString p.column}\"" + (mkStr (T.pack file <> ":2:3")), + -- A string is coerced to a path only when it spells an absolute + -- one; upstream refuses a relative string outright. + runTestIOFail "import refuses a relative string" testDir "import \"./literal.nix\"", + -- pathExists + runTestIO + "pathExists true" + testDir + ("builtins.pathExists " <> nixQuotedPath (testDir "literal.nix")) + (VBool True), + runTestIO + "pathExists false" + testDir + ("builtins.pathExists " <> nixQuotedPath (testDir "nope.nix")) + (VBool False), + -- readFile + runTestIO + "readFile contents" + testDir + ("builtins.readFile " <> nixQuotedPath (testDir "literal.nix")) + (mkStr "42"), + runTestIOFail + "readFile missing -> error" + testDir + ("builtins.readFile " <> nixQuotedPath (testDir "ghost.nix")), + -- readDir: entries have correct file types + runTestIO + "readDir classifies directory" + testDir + ("(builtins.readDir " <> nixQuotedPath testDir <> ").sub") + (mkStr "directory"), + runTestIO + "readDir classifies regular file" + testDir + ("builtins.getAttr \"literal.nix\" (builtins.readDir " <> nixQuotedPath testDir <> ")") + (mkStr "regular") + ] + +-- --------------------------------------------------------------------------- +-- Tests: builtins.unsafeGetAttrPos +-- --------------------------------------------------------------------------- + +-- | The file 'evalNixInFile' parses its source as. +positionsFile :: Text +positionsFile = "/nova-nix-test/positions.nix" + +-- | The file the derivation wrapper's positions name, upstream's name for +-- its wrapper. +derivationWrapperFile :: Text +derivationWrapperFile = "/derivation-internal.nix" + +-- | 'evalNix' for source parsed as the file 'positionsFile', so the +-- positions recorded in it name that file, as upstream's do for a file. +evalNixInFile :: Text -> Either Text NixValue +evalNixInFile source = case parseNix testBaseDir (SourceFile positionsFile) (TE.encodeUtf8 source) of + Left err -> Left (sourceFailure err) + Right expr -> runPureEval (eval (builtinEnv unrestrictedPolicy 0 []) expr) + +-- | Each expected position is derived from upstream's source at 2.24.9: +-- @prim_unsafeGetAttrPos@ (primops.cc) answers @EvalState::mkPos@ of the +-- attribute's position, a set of @file@, @line@ and @column@ for one in a +-- file and null for none; the parser records a binding at its attribute +-- path's first token and an inherited name at itself (parser.y, +-- parser-state.hh); and the builtins that copy an attribute copy its +-- position. The expressions put every attribute under test past line 1, +-- so the @builtins.toJSON (@ the helper prefixes moves no column. +testUnsafeGetAttrPos :: IO [Bool] +testUnsafeGetAttrPos = do + putStrLn "eval/unsafeGetAttrPos" + sequence + [ inFile "a binding is at its name" "builtins.unsafeGetAttrPos \"a\" {\n a = 1;\n}" (2, 3), + noPosition "a missing attribute has none" "builtins.unsafeGetAttrPos \"b\" {\n a = 1;\n}", + inFile "an inherited name is at itself" "let x = 1; in builtins.unsafeGetAttrPos \"x\" {\n inherit x;\n}" (2, 11), + inFile "a name inherited from a set is at itself" "builtins.unsafeGetAttrPos \"y\" {\n inherit ({ x = 1; y = 2; }) x y;\n}" (2, 33), + inFile "a quoted inherited name is at its quote" "builtins.unsafeGetAttrPos \"or\" {\n inherit ({ or = 1; }) \"or\";\n}" (2, 25), + inFile "a quoted static name is at its quote" "builtins.unsafeGetAttrPos \"q\" {\n \"q\" = 1;\n}" (2, 3), + -- The e-acute's two bytes take one column, as the lexer counts. + inFile "a column counts the characters before it" "builtins.unsafeGetAttrPos \"b\" {\n a = \"\233\"; b = 1;\n}" (2, 12), + inFile "a dynamic name is at its interpolation" "builtins.unsafeGetAttrPos \"k\" {\n ${\"k\"} = 1;\n}" (2, 3), + inFile "each level of a dotted path is at the path" "builtins.unsafeGetAttrPos \"c\" {\n a.b.c = 1;\n}.a.b" (2, 3), + inFile "a merged path's first definition keeps its position" "builtins.unsafeGetAttrPos \"a\" {\n a.b = 1;\n a.c = 2;\n}" (2, 3), + -- A line ends at an LF, a CRLF or a bare CR (Pos::LinesIterator, + -- position.cc), so the file spelled with each gives one line. + inFile "a line ends at an LF" (afterCommentLine "\n") (3, 3), + inFile "a line ends at a CRLF" (afterCommentLine "\r\n") (3, 3), + inFile "a line ends at a bare CR" (afterCommentLine "\r") (3, 3), + inFile "a path merged into keeps each definition's own" "builtins.unsafeGetAttrPos \"c\" {\n a.b = 1;\n a.c = 2;\n}.a" (3, 3), + inFile "a set merged into a path keeps its bindings' own" "builtins.unsafeGetAttrPos \"b\" {\n a.c = 1;\n a = {\n b = 2;\n };\n}.a" (4, 5), + inFile "a rec set's binding is at its name" "builtins.unsafeGetAttrPos \"b\" rec {\n a = 1;\n b = a;\n}" (3, 3), + inFile "a rec set's dynamic name is at its interpolation" "builtins.unsafeGetAttrPos \"b\" rec {\n a = \"b\";\n ${a} = 2;\n}" (3, 3), + inFile "a rec set with a dynamic name keeps its static names'" "builtins.unsafeGetAttrPos \"a\" rec {\n a = \"b\";\n ${a} = 2;\n}" (2, 3), + inFile "an update keeps the left side's position" "builtins.unsafeGetAttrPos \"a\" ({\n a = 1;\n b = 2;\n} // {\n b = 3;\n})" (2, 3), + inFile "an update takes the right side's position with its value" "builtins.unsafeGetAttrPos \"b\" ({\n a = 1;\n b = 2;\n} // {\n b = 3;\n})" (5, 3), + inFile "removeAttrs keeps the positions it keeps" "builtins.unsafeGetAttrPos \"b\" (builtins.removeAttrs {\n a = 1;\n b = 2;\n} [ \"a\" ])" (3, 3), + inFile "intersectAttrs keeps the right set's position" "builtins.unsafeGetAttrPos \"a\" (builtins.intersectAttrs { a = null; } {\n a = 1;\n})" (2, 3), + inFile "listToAttrs is at the element's value" "builtins.unsafeGetAttrPos \"k\" (builtins.listToAttrs [ {\n name = \"k\";\n value = 1;\n} ])" (3, 3), + noPosition "mapAttrs makes attributes with none" "builtins.unsafeGetAttrPos \"a\" (builtins.mapAttrs (n: v: v) {\n a = 1;\n})", + noPosition "a builtin has none" "builtins.unsafeGetAttrPos \"map\" builtins", + -- A derivation's own attributes are on the wrapper's lines + -- ('derivationWrapperSource'), under upstream's file name. + inWrapper "a derivation's type is in the wrapper" "type" (7, 7), + inWrapper "a derivation's output is at the wrapper's listToAttrs value" "out" (6, 5), + inWrapper "a derivation's inherited drvAttrs is at the name" "drvAttrs" (17, 15), + inFile "a derivation keeps its argument's positions" (derivationAttrPos "name") (2, 3), + -- Text with no file behind it records positions that name none, + -- as upstream's Pos::String origin makes mkPos answer null. + runTest "text with no file gives no position" $ + assertEval "text origin" "builtins.unsafeGetAttrPos \"a\" {\n a = 1;\n}" VNull, + runTest "the name must be a string" $ + assertEvalError "name" "builtins.unsafeGetAttrPos 1 { }" "expected a string but found an integer: 1", + -- The set throws when forced, so only a name checked before the set + -- is forced reports the name. + runTest "the name is checked before the set is forced" $ + assertEvalError "name first" "builtins.unsafeGetAttrPos 1 (throw \"the set\")" "expected a string but found an integer: 1", + runTest "the name may not carry context" $ + assertEvalError + "name context" + "builtins.unsafeGetAttrPos (builtins.appendContext \"x\" { \"/nix/store/00000000000000000000000000000000-a\" = { path = true; }; }) { }" + "the string 'x' is not allowed to refer to a store path (such as '00000000000000000000000000000000-a')", + runTest "the second argument must be a set" $ + assertEvalError "set" "builtins.unsafeGetAttrPos \"a\" 1" "expected a set but found an integer: 1" + ] + where + inFile label source (line, column) = position label source (positionJson positionsFile line column) + inWrapper label name (line, column) = position label (derivationAttrPos name) (positionJson derivationWrapperFile line column) + noPosition label source = position label source "null" + -- toJSON pins the set mkPos builds: these three attributes only, the + -- file a string and the line and column integers. + position label source expected = + runTest label $ + assertRight label (evalNixInFile ("builtins.toJSON (" <> source <> ")")) $ \actual -> + assertEqual label (mkStr expected) actual + positionJson file line column = + "{\"column\":" <> T.pack (show (column :: Int)) <> ",\"file\":\"" <> file <> "\",\"line\":" <> T.pack (show (line :: Int)) <> "}" + derivationAttrPos name = + "builtins.unsafeGetAttrPos \"" <> name <> "\" (derivation {\n name = \"n\";\n builder = \"b\";\n system = \"s\";\n})" + afterCommentLine ending = + T.intercalate ending ["builtins.unsafeGetAttrPos \"b\" {", " # a comment", " b = 1;", "}"] + +-- --------------------------------------------------------------------------- +-- Tests: Batch A - getEnv, currentTime, toPath +-- --------------------------------------------------------------------------- + +testBatchA :: IO [Bool] +testBatchA = do + putStrLn "eval/builtins-batchA" + sequence + [ -- getEnv + runTest "getEnv pure returns empty" $ + assertEval "getEnv-pure" "builtins.getEnv \"HOME\"" (mkStr ""), + runTest "getEnv type error" $ + assertEvalFail "getEnv-err" "builtins.getEnv 42", + -- toPath + runTest "toPath absolute" $ + assertEval "toPath-abs" "builtins.toPath \"/foo/bar\"" (mkStr "/foo/bar"), + runTest "toPath rejects relative" $ + assertEvalFail "toPath-rel" "builtins.toPath \"foo/bar\"", + runTest "toPath of a path gives its string" $ + assertEval "toPath-vpath" "builtins.toPath /foo/bar" (mkStr "/foo/bar"), + runTest "toPath type error" $ + assertEvalFail "toPath-err" "builtins.toPath 42", + runTest "toPath rejects empty" $ + assertEvalFail "toPath-empty" "builtins.toPath \"\"", + -- currentTime + runTest "currentTime is int" $ + assertEval "currentTime" "builtins.typeOf builtins.currentTime" (mkStr "int"), + runTest "currentTime is 0 in pure" $ + assertEval "currentTime-pure" "builtins.currentTime" (VInt 0), + runTest "currentTime >= 0" $ + assertEval "currentTime-pos" "builtins.currentTime >= 0" (VBool True) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch A - IO tests (getEnv) +-- --------------------------------------------------------------------------- + +testBatchAIO :: IO [Bool] +testBatchAIO = do + putStrLn "eval/builtins-batchA-io" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-batchA" + bracket_ + (createDirectoryIfMissing True testDir) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ -- getEnv HOME should be non-empty in IO mode + do + result <- evalNixIO testDir "builtins.getEnv \"PATH\"" + runTest "getEnv PATH non-empty (IO)" $ assertRight "getEnv-io" result $ \val -> + case val of + VStr s _ -> if BS.null s then Fail "PATH was empty" else Pass + _ -> Fail ("expected VStr, got " <> T.pack (show val)), + -- currentTime in IO should be > 0 + do + result <- evalNixIO testDir "builtins.currentTime" + runTest "currentTime > 0 (IO)" $ assertRight "currentTime-io" result $ \val -> + case val of + VInt n -> if n > 0 then Pass else Fail ("expected > 0, got " <> T.pack (show n)) + _ -> Fail ("expected VInt, got " <> T.pack (show val)) + ] + +-- --------------------------------------------------------------------------- +-- Tests: environment values as bytes +-- --------------------------------------------------------------------------- + +-- | An environment value reaches the evaluator as its bytes, through +-- @builtins.getEnv@ and through @NIX_PATH@, as upstream's @getenv@ reads +-- it; each case's outcome was read off nix-instantiate 2.33.2 under the +-- same environment. A POSIX environment is bytes and a Windows one is +-- UTF-16, so each platform runs the cases its environment can express. +testEnvironmentBytes :: IO [Bool] +testEnvironmentBytes = do + putStrLn "eval/environment-bytes" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-env-bytes" + pkgDir = testDir "mypkg" + bracket_ + ( do + createDirectoryIfMissing True pkgDir + BS.writeFile (pkgDir "default.nix") "42" + BS.writeFile (testDir "name.bin") nonUtf8EnvName + ) + (Dir.removePathForcibly testDir) + $ do + getEnvResults <- mapM (getEnvCase testDir) envByteCases + nixPathResults <- mapM (nixPathCase testDir) envByteCases + rest <- + sequence + [ withEnvBytes "a lookup passes a NIX_PATH entry whose prefix has no UTF-8 reading" (TE.encodeUtf8 nixPathVarName) ("\xFC=/nonexistent:mypkg=" <> TE.encodeUtf8 (T.pack pkgDir)) $ + assertEqual "lookup" (Right (VInt 42)) <$> evalNixIO testDir "import ", + withEnvBytes "getEnv looks a name up by its bytes" nonUtf8EnvName "hello" $ + expectBytes "name" "hello" <$> evalNixIO testDir "builtins.getEnv (builtins.readFile ./name.bin)", + unpairedSurrogateGetEnv testDir, + unpairedSurrogateNixPath testDir + ] + pure (getEnvResults ++ nixPathResults ++ rest) + where + getEnvCase dir (label, bytes) = + withEnvBytes ("getEnv carries " <> label) (TE.encodeUtf8 testEnvVarName) bytes $ + expectBytes "getEnv" bytes <$> evalNixIO dir ("builtins.getEnv \"" <> testEnvVarName <> "\"") + nixPathCase dir (label, bytes) = + withEnvBytes ("NIX_PATH carries " <> label <> " into prefix and path") (TE.encodeUtf8 nixPathVarName) (bytes <> "=/x" <> bytes) $ + expectBytes "nixPath" (bytes <> "|/x" <> bytes) <$> evalNixIO dir "let e = builtins.head builtins.nixPath; in e.prefix + \"|\" + e.path" + expectBytes label expected = \case + Right (VStr actual _) -> assertEqual label expected actual + other -> Fail (label <> ": expected a string, got " <> T.pack (show other)) + +-- | The values the environment cases carry: a byte with no UTF-8 reading, +-- a multibyte UTF-8 character, and nothing at all. +envByteCases :: [(Text, BS.ByteString)] +envByteCases = + [ ("a byte with no UTF-8 reading", "\xFC"), + ("a multibyte UTF-8 value", "caf\xC3\xA9"), + ("an empty value", "") + ] + +testEnvVarName :: Text +testEnvVarName = "NOVA_NIX_TEST_ENV_BYTES" + +nixPathVarName :: Text +nixPathVarName = "NIX_PATH" + +-- | A variable name holding a byte with no UTF-8 reading. +nonUtf8EnvName :: BS.ByteString +nonUtf8EnvName = "NOVA_NIX_TEST_ENV_\xFC" + +-- | Run one case with a variable set to the given bytes, restoring it +-- afterwards. A Windows environment is UTF-16 and cannot hold a byte +-- with no UTF-8 reading, so such a case skips there. +withEnvBytes :: Text -> BS.ByteString -> BS.ByteString -> IO TestResult -> IO Bool +withEnvBytes label name value check = do + spelledName <- envSpelling name + spelledValue <- envSpelling value + case (,) <$> spelledName <*> spelledValue of + Nothing -> True <$ putStrLn (" SKIP " <> T.unpack label <> ": a Windows environment cannot hold a byte with no UTF-8 reading") + Just (nameSpelling, valueSpelling) -> runTestM label (withEnvVar nameSpelling valueSpelling check) + +-- | The 'String' that base's environment setters and file functions, and +-- a spawned process's environment, write as the given bytes: on POSIX +-- they encode with the file-system encoding, whose round-trip escape +-- restores every byte its decoding escaped, and on Windows they write +-- UTF-16. +envSpelling :: BS.ByteString -> IO (Maybe String) +envSpelling bytes + | SI.os == "mingw32" = pure (either (const Nothing) (Just . T.unpack) (TE.decodeUtf8' bytes)) + | otherwise = do + encoding <- getFileSystemEncoding + Just <$> BS.useAsCStringLen bytes (GHCForeign.peekCStringLen encoding) + +-- | Run an action with a variable set (to an empty value too, which +-- 'setEnv' would unset), restoring what the variable held afterwards. +withEnvVar :: String -> String -> IO a -> IO a +withEnvVar name value action = + bracket (lookupEnv name) restore (const (Blank.setEnv name value True >> action)) + where + restore = maybe (unsetEnv name) (\saved -> Blank.setEnv name saved True) + +-- | A Windows value holding an unpaired UTF-16 surrogate has no UTF-8 +-- form, so getEnv refuses it rather than substituting U+FFFD. +unpairedSurrogateGetEnv :: FilePath -> IO Bool +unpairedSurrogateGetEnv dir + | SI.os /= "mingw32" = True <$ putStrLn unpairedSurrogateSkip + | otherwise = + runTestM "getEnv refuses a value holding an unpaired surrogate" $ + withEnvVar (T.unpack testEnvVarName) "a\xD800" $ do + result <- evalNixIO dir ("builtins.getEnv \"" <> testEnvVarName <> "\"") + pure $ case result of + Left err | unpairedSurrogateWords `T.isInfixOf` err -> Pass + other -> Fail ("expected the unpaired-surrogate refusal, got " <> T.pack (show other)) + +-- | The same refusal for @NIX_PATH@, raised as the evaluation state is +-- created. +unpairedSurrogateNixPath :: FilePath -> IO Bool +unpairedSurrogateNixPath dir + | SI.os /= "mingw32" = True <$ putStrLn unpairedSurrogateSkip + | otherwise = + runTestM "NIX_PATH holding an unpaired surrogate is refused" $ + withEnvVar (T.unpack nixPathVarName) "a=\xD800" $ do + storeDir <- evalNixIOStoreDir + outcome <- try (newEvalState storeDir dir) + pure $ case outcome of + Left (err :: IOException) + | unpairedSurrogateWords `T.isInfixOf` T.pack (displayException err) -> Pass + | otherwise -> Fail ("wrong error: " <> T.pack (displayException err)) + Right _ -> Fail "NIX_PATH was accepted" + +unpairedSurrogateWords :: Text +unpairedSurrogateWords = "unpaired UTF-16 surrogate" + +unpairedSurrogateSkip :: String +unpairedSurrogateSkip = " SKIP an unpaired UTF-16 surrogate exists only in a Windows environment" + +-- --------------------------------------------------------------------------- +-- Tests: Batch B - placeholder, storePath +-- --------------------------------------------------------------------------- + +testBatchB :: IO [Bool] +testBatchB = do + putStrLn "eval/builtins-batchB" + sequence + [ -- placeholder + runTest "placeholder out matches Nix hashPlaceholder" $ + assertRight "placeholder-out" (evalNix "builtins.placeholder \"out\"") $ \val -> + case val of + VStr p _ -> assertEqual "placeholder out" "/1rz4g4znpzjwh1xymhjpm42vipw92pr73vdgl6xs1hycac8kf2n9" p + _ -> Fail ("expected VStr, got " <> T.pack (show val)), + runTest "placeholder deterministic" $ + assertRight "placeholder-det" (evalNix "builtins.placeholder \"out\" == builtins.placeholder \"out\"") $ \val -> + assertEqual "deterministic" (VBool True) val, + runTest "placeholder out /= placeholder dev" $ + assertRight "placeholder-diff" (evalNix "builtins.placeholder \"out\" == builtins.placeholder \"dev\"") $ \val -> + assertEqual "different" (VBool False) val, + runTest "placeholder type error" $ + assertEvalFail "placeholder-err" "builtins.placeholder 42", + -- storePath returns a STRING marked already-in-store (SCPlain context), + -- not a bare path - the marker is what stops a later coercion re-NARing it. + runTest "storePath returns an in-store string" $ + assertEval + "storePath-isstring" + "builtins.isString (builtins.storePath \"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\")" + (VBool True), + runTest "storePath result carries a plain-path context" $ + assertEval + "storePath-hasctx" + "(builtins.getContext (builtins.storePath \"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\")).\"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\".path" + (VBool True), + runTest "storePath preserves the path text" $ + assertEval + "storePath-text" + "builtins.unsafeDiscardStringContext (builtins.storePath \"/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1\")" + (mkStr "/nix/store/s66mzxpvicwk07gjbjfw9izjfa797vsw-hello-2.12.1"), + runTest "storePath invalid" $ + assertEvalFail "storePath-bad" "builtins.storePath \"/tmp/not-a-store-path\"", + runTest "storePath type error" $ + assertEvalFail "storePath-err" "builtins.storePath 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch C - findFile +-- --------------------------------------------------------------------------- + +testBatchC :: IO [Bool] +testBatchC = do + putStrLn "eval/builtins-batchC" + sequence + [ runTest "findFile empty list errors" $ + assertEvalFail "findFile-empty" "builtins.findFile [ ] \"foo\"", + runTest "findFile type error arg1" $ + assertEvalFail "findFile-err1" "builtins.findFile 42 \"foo\"", + runTest "findFile type error arg2" $ + assertEvalFail "findFile-err2" "builtins.findFile [ ] 42" + ] + +testBatchCIO :: IO [Bool] +testBatchCIO = do + putStrLn "eval/builtins-batchC-io" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-batchC" + nixpkgsDir = testDir "nixpkgs" + bracket_ + ( do + createDirectoryIfMissing True nixpkgsDir + TIO.writeFile (nixpkgsDir "default.nix") "42" + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ runTestIO + "findFile with matching entry" + testDir + ( "builtins.findFile [ { prefix = \"nixpkgs\"; path = " + <> nixQuotedPath nixpkgsDir + <> "; } ] \"nixpkgs\"" + ) + (VPath (canonPathValue (T.pack nixpkgsDir))), + runTestIOFail + "findFile no match" + testDir + "builtins.findFile [ { prefix = \"other\"; path = \"/nope\"; } ] \"nixpkgs\"" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Blackhole (infinite recursion detection) +-- --------------------------------------------------------------------------- + +testBlackhole :: IO [Bool] +testBlackhole = do + putStrLn "eval/blackhole" + tmpBase <- getTemporaryDirectory + sequence + [ runTestIOFail "let x = x; in x" tmpBase "let x = x; in x", + runTestIOFail "rec { a = a; }.a" tmpBase "rec { a = a; }.a", + runTestIOFail "let a = b; b = a; in a" tmpBase "let a = b; b = a; in a", + -- Non-recursive cases must still work + runTestIO "rec { a = 1; b = a; }.b" tmpBase "rec { a = 1; b = a; }.b" (VInt 1), + runTestIO "let a = 1; b = a + 1; in b" tmpBase "let a = 1; b = a + 1; in b" (VInt 2) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Eval - Call depth (max-call-depth) +-- --------------------------------------------------------------------------- + +-- | The issue's counter recursion to a given depth. +counterRecursion :: Int -> Text +counterRecursion n = "let f = n: if n == 0 then 0 else 1 + f (n - 1); in f " <> T.pack (show n) + +-- | The identity applied to itself syntactically @n@ deep: a chain of pure +-- lambda frames with nothing else counted. +lambdaNesting :: Int -> Text +lambdaNesting n = "let f = x: x; in " <> T.replicate n "f (" <> "0" <> T.replicate n ")" + +-- | Upstream's message, which the CLI prints after its own "error: ". +maxCallDepthMessage :: Text +maxCallDepthMessage = "stack overflow; max-call-depth exceeded" + +-- | A result that must be the max-call-depth error, word for word. +expectMaxCallDepth :: Text -> Either Text NixValue -> TestResult +expectMaxCallDepth label result = case result of + Left err + | err == maxCallDepthMessage -> Pass + | otherwise -> Fail (label <> ": wrong error: " <> err) + Right val -> Fail (label <> ": expected the max-call-depth error but got: " <> T.pack (show val)) + +-- | IO evaluation under an explicit call-depth ceiling. +evalAtCeiling :: Word32 -> Text -> IO (Either Text NixValue) +evalAtCeiling limit source = case parseNix "." testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left (T.pack (show err))) + Right expr -> do + storeDir <- evalNixIOStoreDir + st0 <- newEvalState storeDir "." + let st = st0 {esCallDepth = topLevelCallDepth limit} + runEvalIO st (eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr) + +-- | The function-call nesting ceiling, upstream's max-call-depth (10000). +-- Every boundary here was read off nix-instantiate 2.33.2 and the 2.24.9 +-- source: the count is the frames already active, checked on entry, so +-- 10001 nested lambda calls pass and 10002 fail, and the counter +-- recursion passes at 9999 and fails at 10000, its deepest frame being +-- the @n - 1@ forced inside @f 0@, a builtin call upstream's parser +-- desugars @-@ into. The cases under a ceiling of 10 pin what costs a +-- frame and what does not, each boundary taken from the same upstream. +testCallDepth :: IO [Bool] +testCallDepth = do + putStrLn "eval/call-depth" + sequence + [ failsIO "the issue expression is refused with upstream's words" (counterRecursion 100000), + runTestIO "the counter recursion one under the ceiling evaluates" "." (counterRecursion 9999) (VInt 9999), + failsIO "the counter recursion at the ceiling is refused" (counterRecursion 10000), + runTest "pure evaluation enforces the ceiling too" $ + assertEval "pure-under" (lambdaNesting 10001) (VInt 0), + runTest "pure evaluation refuses past the ceiling with upstream's words" $ + expectMaxCallDepth "pure-over" (evalNix (lambdaNesting 10002)), + -- Under a ceiling of n, n + 1 nested lambda calls pass and n + 2 fail. + passesAt 10 "lambda nesting one past the ceiling passes" (lambdaNesting 11) (VInt 0), + failsAt 10 "lambda nesting two past the ceiling fails" (lambdaNesting 12), + -- The operators upstream desugars into builtin calls cost a frame + -- while their operands are forced; its native operators cost none. + passesAt 10 "a subtraction at the ceiling passes" (wrapped 10 "1 - 1") (VInt 0), + failsAt 10 "a subtraction one past the ceiling fails" (wrapped 11 "1 - 1"), + failsAt 10 "a multiplication one past the ceiling fails" (wrapped 11 "2 * 1"), + failsAt 10 "a division one past the ceiling fails" (wrapped 11 "2 / 1"), + failsAt 10 "a less-than one past the ceiling fails" (wrapped 11 "1 < 2"), + failsAt 10 "a less-or-equal one past the ceiling fails" (wrapped 11 "1 <= 2"), + failsAt 10 "a greater-than one past the ceiling fails" (wrapped 11 "2 > 1"), + failsAt 10 "a greater-or-equal one past the ceiling fails" (wrapped 11 "2 >= 1"), + failsAt 10 "a negation one past the ceiling fails" (wrapped 11 "-1"), + passesAt 10 "an equality one past the ceiling passes" (wrapped 11 "1 == 1") (VBool True), + passesAt 10 "an inequality one past the ceiling passes" (wrapped 11 "1 != 2") (VBool True), + passesAt 10 "a not one past the ceiling passes" (wrapped 11 "!true") (VBool False), + passesAt 10 "an addition one past the ceiling passes" (wrapped 11 "1 + 1") (VInt 2), + passesAt 10 "a list concatenation one past the ceiling passes" (wrapped 11 "([1] ++ [2]) == [1 2]") (VBool True), + passesAt 10 "an attrset update one past the ceiling passes" (wrapped 11 "({ a = 1; } // { b = 2; }) == { a = 1; b = 2; }") (VBool True), + -- A builtin costs a frame even when partially applied. + failsAt 10 "a partially applied builtin one past the ceiling fails" (wrapped 11 "builtins.add 0"), + failsAt 10 "a builtin application one past the ceiling fails" (wrapped 11 "builtins.add 0 0"), + -- A functor costs two frames: its inner call is a callFunction of its own. + passesAt 10 "functor nesting of five passes" (functorNesting 5) (VInt 0), + failsAt 10 "functor nesting of six fails" (functorNesting 6), + -- A __toString coercion is a callFunction. + passesAt 10 "a __toString coercion at the ceiling passes" (wrapped 10 "\"${s}\"") (mkStr "a"), + failsAt 10 "a __toString coercion one past the ceiling fails" (wrapped 11 "\"${s}\""), + -- A higher-order builtin's callback is applied where its result is + -- forced, not inside the builtin's frame: upstream's prim_map returns + -- app values. Forced by ==, which opens no frame, the callback at + -- the ceiling passes; forced by elemAt, a frame deeper, it is + -- elemAt's own call that fails. + passesAt 10 "a map callback forced at the ceiling passes" (wrapped 10 "(builtins.map f [ 0 ]) == [ 0 ]") (VBool True), + failsAt 10 "a map callback forced one past the ceiling fails" (wrapped 11 "(builtins.map f [ 0 ]) == [ 0 ]"), + passesAt 10 "an elemAt over map under the ceiling passes" (wrapped 9 "builtins.elemAt (builtins.map f [ 0 ]) 0") (VInt 0), + failsAt 10 "an elemAt over map at the ceiling fails" (wrapped 10 "builtins.elemAt (builtins.map f [ 0 ]) 0"), + -- mapAttrs and zipAttrsWith apply @f name@ a frame below the value + -- application: upstream builds two nested app values. + passesAt 10 "a mapAttrs callback under the ceiling passes" (wrapped 9 "(builtins.mapAttrs (n: v: v) { a = 0; }).a") (VInt 0), + failsAt 10 "a mapAttrs callback at the ceiling fails" (wrapped 10 "(builtins.mapAttrs (n: v: v) { a = 0; }).a"), + passesAt 10 "a zipAttrsWith callback under the ceiling passes" (wrapped 9 "(builtins.zipAttrsWith (n: vs: 0) [ { a = 1; } ]).a") (VInt 0), + failsAt 10 "a zipAttrsWith callback at the ceiling fails" (wrapped 10 "(builtins.zipAttrsWith (n: vs: 0) [ { a = 1; } ]).a"), + -- A sort by builtins.lessThan itself opens no frame per comparison + -- (upstream's prim_sort bypass); a lambda comparator costs its call + -- and the < inside it. + passesAt 10 "a sort by lessThan at the ceiling passes" (wrapped 10 "builtins.sort builtins.lessThan [ 2 1 ] == [ 1 2 ]") (VBool True), + failsAt 10 "a sort by lessThan one past the ceiling fails" (wrapped 11 "builtins.sort builtins.lessThan [ 2 1 ] == [ 1 2 ]"), + passesAt 10 "a sort by a lambda two under the ceiling passes" (wrapped 8 "builtins.sort (a: b: a < b) [ 2 1 ] == [ 1 2 ]") (VBool True), + failsAt 10 "a sort by a lambda one under the ceiling fails" (wrapped 9 "builtins.sort (a: b: a < b) [ 2 1 ] == [ 1 2 ]"), + passesAt 10 "the counter recursion to 9 passes under a ceiling of 10" (counterRecursion 9) (VInt 9), + failsAt 10 "the counter recursion to 10 fails under a ceiling of 10" (counterRecursion 10), + -- An eval error, not a throw: tryEval does not catch it. + failsAt 10 "tryEval does not catch the ceiling" ("(builtins.tryEval (" <> lambdaNesting 12 <> ")).success"), + -- A ceiling of 0 still admits one frame: the check is against the + -- frames already active when the call is entered. + passesAt 0 "one call passes under a ceiling of 0" "(x: x) 1" (VInt 1), + failsAt 0 "a nested call fails under a ceiling of 0" "(x: x) ((x: x) 1)", + passesAt 0 "a bare subtraction passes under a ceiling of 0" "1 - 1" (VInt 0), + failsAt 0 "a subtraction inside a call fails under a ceiling of 0" "(x: x - 1) 1" + ] + where + failsIO label source = evalNixIO "." source >>= runTest label . expectMaxCallDepth label + passesAt limit label source expected = do + result <- evalAtCeiling limit source + runTest label $ assertRight label result $ assertEqual label expected + failsAt limit label source = evalAtCeiling limit source >>= runTest label . expectMaxCallDepth label + wrapped n inner = scope <> T.replicate n "f (" <> inner <> T.replicate n ")" + functorNesting n = scope <> T.replicate n "g (" <> "0" <> T.replicate n ")" + scope = "let f = x: x; g = { __functor = self: x: x; }; s = { __toString = self: \"a\"; }; in " + +-- --------------------------------------------------------------------------- +-- Tests: Batch D - toFile +-- --------------------------------------------------------------------------- + +testBatchD :: IO [Bool] +testBatchD = do + putStrLn "eval/builtins-batchD" + sequence + [ runTest "toFile pure mode error" $ + assertEvalFail "toFile-pure" "builtins.toFile \"hello\" \"world\"", + runTest "toFile type error arg1" $ + assertEvalFail "toFile-err1" "builtins.toFile 42 \"world\"", + runTest "toFile type error arg2" $ + assertEvalFail "toFile-err2" "builtins.toFile \"hello\" 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch E - scopedImport +-- --------------------------------------------------------------------------- + +testBatchE :: IO [Bool] +testBatchE = do + putStrLn "eval/builtins-batchE" + sequence + [ runTest "scopedImport pure error" $ + assertEvalFail "scopedImport-pure" "builtins.scopedImport { } ./foo.nix", + runTest "scopedImport type error arg1" $ + assertEvalFail "scopedImport-err1" "builtins.scopedImport 42 ./foo.nix", + runTest "scopedImport type error arg2" $ + assertEvalFail "scopedImport-err2" "builtins.scopedImport { } 42" + ] + +testBatchEIO :: IO [Bool] +testBatchEIO = do + putStrLn "eval/builtins-batchE-io" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-batchE" + bracket_ + ( do + createDirectoryIfMissing True testDir + TIO.writeFile (testDir "scoped.nix") "x" + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ runTestIO + "scopedImport injects scope" + testDir + ("builtins.scopedImport { x = 42; } " <> nixQuotedPath (testDir "scoped.nix")) + (VInt 42) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch F - fetchurl, fetchTarball, fetchGit +-- --------------------------------------------------------------------------- + +testBatchF :: IO [Bool] +testBatchF = do + putStrLn "eval/builtins-batchF" + sequence + [ runTest "fetchurl pure error" $ + assertEvalFail "fetchurl-pure" "builtins.fetchurl \"http://example.com\"", + runTest "fetchurl type error" $ + assertEvalFail "fetchurl-err" "builtins.fetchurl 42", + runTest "fetchTarball pure error" $ + assertEvalFail "fetchTarball-pure" "builtins.fetchTarball \"http://example.com\"", + runTest "fetchTarball type error" $ + assertEvalFail "fetchTarball-err" "builtins.fetchTarball 42", + runTest "fetchGit pure error" $ + assertEvalFail "fetchGit-pure" "builtins.fetchGit \"http://example.com\"", + runTest "fetchGit type error" $ + assertEvalFail "fetchGit-err" "builtins.fetchGit 42" + ] + +-- --------------------------------------------------------------------------- +-- Tests: Batch G - ATerm serialization +-- --------------------------------------------------------------------------- + +testBatchG :: IO [Bool] +testBatchG = do + putStrLn "derivation/aterm" + let minimalDrv = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + let drvWithOutput = + minimalDrv + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = StorePath "abc" "hello", + doHashAlgo = "", + doHash = "" + } + ] + } + let drvWithEnv = + minimalDrv + { drvEnv = Map.fromList [("name", "hello"), ("system", "x86_64-linux")] + } + sequence + [ runTest "ATerm minimal" $ + let aterm = toATerm minimalDrv + in if BS.isPrefixOf "Derive(" aterm && BS.isSuffixOf ")" aterm + then Pass + else Fail ("bad ATerm: " <> bytesText aterm), + runTest "ATerm has output" $ + let aterm = toATerm drvWithOutput + in if "\"out\"" `BS.isInfixOf` aterm + then Pass + else Fail ("missing output in ATerm: " <> bytesText aterm), + runTest "ATerm env sorted" $ + let aterm = toATerm drvWithEnv + in -- "name" should come before "system" in sorted order + case (BS.breakSubstring "\"name\"" aterm, BS.breakSubstring "\"system\"" aterm) of + ((before1, _), (before2, _)) -> + if BS.length before1 < BS.length before2 + then Pass + else Fail ("env not sorted in ATerm: " <> bytesText aterm), + runTest "ATerm string escaping" $ + let drv = minimalDrv {drvEnv = Map.fromList [("msg", "hello\nworld")]} + aterm = toATerm drv + in if "\\n" `BS.isInfixOf` aterm + then Pass + else Fail ("missing escaped newline: " <> bytesText aterm), + runTest "ATerm deterministic" $ + assertEqual "deterministic" (toATerm minimalDrv) (toATerm minimalDrv), + -- platformToText + runTest "platformToText linux" $ + assertEqual "linux" "x86_64-linux" (platformToText X86_64_Linux), + runTest "platformToText darwin" $ + assertEqual "darwin" "x86_64-darwin" (platformToText X86_64_Darwin), + runTest "platformToText aarch64-darwin" $ + assertEqual "aarch64" "aarch64-darwin" (platformToText Aarch64_Darwin), + runTest "platformToText windows" $ + assertEqual "windows" "x86_64-windows" (platformToText X86_64_Windows), + runTest "platformToText aarch64-linux" $ + assertEqual "aarch64-linux" "aarch64-linux" (platformToText Aarch64_Linux), + runTest "platformToText i686" $ + assertEqual "i686" ["i686-linux", "i686-windows"] (map platformToText [I686_Linux, I686_Windows]), + runTest "platformToText other" $ + assertEqual "other" "riscv64-freebsd" (platformToText (OtherPlatform "riscv64-freebsd")), + -- The i686 spellings parse to their own constructors, not to + -- OtherPlatform, or extraPlatforms could never name them. + runTest "textToPlatform round-trips every named platform" $ + assertEqual + "round-trip" + namedPlatforms + (map (textToPlatform . platformToText) namedPlatforms), + -- Upstream's default extra-platforms, and nothing more: the x86_64 + -- hosts run their i686 counterpart, every other host runs only itself. + runTest "extraPlatforms is the i686 counterpart on x86_64 hosts only" $ + assertEqual + "extra" + [[I686_Linux], [I686_Windows], [], [], [], [], []] + (map extraPlatforms [X86_64_Linux, X86_64_Windows, X86_64_Darwin, Aarch64_Darwin, Aarch64_Linux, I686_Linux, I686_Windows]) + ] + where + namedPlatforms = [X86_64_Linux, X86_64_Darwin, Aarch64_Darwin, X86_64_Windows, Aarch64_Linux, I686_Linux, I686_Windows] + +-- --------------------------------------------------------------------------- +-- Tests: Batch H - derivation +-- --------------------------------------------------------------------------- + +testBatchH :: IO [Bool] +testBatchH = do + putStrLn "eval/builtins-batchH" + let withTwoOutputs expr = + "let D = derivation { name = \"x\"; system = \"s\"; builder = \"b\"; outputs = [ \"out\" \"dev\" ]; }; in " <> expr + sequence + [ runTest "derivation has type" $ + assertEval + "drv-type" + "let d = derivation { name = \"hello\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d.type" + (mkStr "derivation"), + runTest "derivation has drvPath" $ + assertRight "drv-drvPath" (evalNix "let d = derivation { name = \"hello\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d.drvPath") $ \val -> + case val of + VStr p ctx -> + if "/nix/store/" `BS.isPrefixOf` p && ".drv" `BS.isSuffixOf` p && ctx /= emptyContext + then Pass + else Fail ("bad drvPath: " <> bytesText p) + _ -> Fail ("expected VStr with context, got " <> T.pack (show val)), + runTest "derivation has outPath" $ + assertRight "drv-outPath" (evalNix "let d = derivation { name = \"hello\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d.outPath") $ \val -> + case val of + VStr p ctx -> + if "/nix/store/" `BS.isPrefixOf` p && ctx /= emptyContext + then Pass + else Fail ("bad outPath: " <> bytesText p) + _ -> Fail ("expected VStr with context, got " <> T.pack (show val)), + -- 'derivation' is lazy (matches C++ Nix): the missing-required-attribute + -- error fires when a path is forced (.drvPath), not at construction. + runTest "derivation missing name" $ + assertEvalFail "drv-noname" "(derivation { system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).drvPath", + runTest "derivation missing system" $ + assertEvalFail "drv-nosys" "(derivation { name = \"hello\"; builder = \"/bin/sh\"; }).drvPath", + runTest "derivation missing builder" $ + assertEvalFail "drv-nobuilder" "(derivation { name = \"hello\"; system = \"x86_64-linux\"; }).drvPath", + runTest "derivation type error" $ + assertEvalFail "drv-tyerr" "derivation 42", + runTest "derivation deterministic" $ + assertRight "drv-det" (evalNix "let d1 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; d2 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d1.drvPath == d2.drvPath") $ \val -> + assertEqual "deterministic" (VBool True) val, + -- The result has the shape of upstream's wrapper: every row below + -- was read from nix-instantiate 2.33.2. + runTest "derivation result carries exactly upstream's attributes" $ + assertEval + "drv-attrnames" + (withTwoOutputs "builtins.attrNames D == [ \"all\" \"builder\" \"dev\" \"drvAttrs\" \"drvPath\" \"name\" \"out\" \"outPath\" \"outputName\" \"outputs\" \"system\" \"type\" ]") + (VBool True), + runTest "derivation outputName is the first output" $ + assertEval "drv-outputname" (withTwoOutputs "D.outputName") (mkStr "out"), + runTest "derivation default output is the first listed, not out" $ + assertEval + "drv-first-output" + "(derivation { name = \"x\"; system = \"s\"; builder = \"b\"; outputs = [ \"dev\" \"out\" ]; }).outputName" + (mkStr "dev"), + runTest "every output attribute is a complete derivation set" $ + assertEval "drv-output-set" (withTwoOutputs "builtins.attrNames D.dev == builtins.attrNames D") (VBool True), + runTest "an output set names its own output" $ + assertEval "drv-output-name" (withTwoOutputs "D.dev.outputName") (mkStr "dev"), + runTest "output sets refer back to each other" $ + assertEval "drv-output-cycle" (withTwoOutputs "D.dev.out.outPath == D.outPath && D.dev.dev.out.dev.outputName == \"dev\"") (VBool True), + runTest "derivation all lists every output set in order" $ + assertEval "drv-all" (withTwoOutputs "map (o: o.outputName) D.all == [ \"out\" \"dev\" ]") (VBool True), + runTest "derivation drvAttrs is the argument set" $ + assertEval "drv-drvattrs" (withTwoOutputs "builtins.attrNames D.drvAttrs == [ \"builder\" \"name\" \"outputs\" \"system\" ]") (VBool True), + runTest "derivation leaks no internal attribute" $ + assertEval "drv-no-internal" (withTwoOutputs "D ? _derivation") (VBool False), + -- derivationStrict is reached only through outPath and drvPath, so a + -- derivation forced to WHNF forces none of its inputs. + runTest "forcing a derivation to WHNF forces no input" $ + assertEval + "drv-whnf" + "builtins.seq (derivation { name = \"x\"; system = \"s\"; builder = throw \"forced\"; }) \"whnf-ok\"" + (mkStr "whnf-ok"), + runTest "derivationStrict returns drvPath and one path per output" $ + assertEval + "drvstrict-shape" + "builtins.attrNames (derivationStrict { name = \"x\"; system = \"s\"; builder = \"b\"; outputs = [ \"out\" \"dev\" ]; }) == [ \"dev\" \"drvPath\" \"out\" ]" + (VBool True), + runTest "derivation is a lambda with upstream's formals" $ + assertEval "drv-functionargs" "builtins.functionArgs derivation == { outputs = true; }" (VBool True) + ] + +-- --------------------------------------------------------------------------- +-- Tests: what a program can observe of the derivation wrapper +-- --------------------------------------------------------------------------- + +-- | What a program can observe of @derivation@ beyond the attributes +-- 'testBatchH' reads, each expected value written out: the name the +-- pattern binds, which builtin forces @outputs@ and in what order, how the +-- layers of the result replace each other, and the arguments' own values +-- in the result. The parity job probes the same things against upstream's +-- nix-instantiate (test/data/derivation-probes.txt). +testDerivationWrapper :: IO [Bool] +testDerivationWrapper = do + putStrLn "derivation/wrapper" + tmpBase <- getTemporaryDirectory + let required = "name = \"w\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; " + drv fields = "derivation { " <> required <> fields <> " }" + atWhnf fields = "builtins.seq (" <> drv fields <> ") null" + throwing = drv "outputs = [ \"out\" \"dev\" ]; x = throw \"forced\";" + sequence + [ runTest "toXML shows the name the pattern binds" $ + assertEval + "xml" + "builtins.toXML derivation" + (mkStr "\n\n \n \n \n \n \n\n"), + -- map's error rather than head's: map forces outputs first. + runTest "map forces outputs before head does" $ + assertEvalError "map" (atWhnf "outputs = \"out\";") "builtins.map: expected a list, got a string", + runTest "listToAttrs forces the output names first to last" $ + assertEvalError "first" (atWhnf "outputs = [ (throw \"the first\") \"out\" (throw \"the last\") ];") "the first", + runTest "every output name is forced with the derivation" $ + assertEvalError "last" (atWhnf "outputs = [ \"out\" (throw \"the last\") ];") "the last", + runTest "an argument that throws stays unforced through the result's attributes" $ + assertEval + "spine" + ("let d = " <> throwing <> "; in builtins.toJSON [ (builtins.attrNames d) (map (o: o.outputName) d.all) d.dev.type (builtins.attrNames d.drvAttrs) ]") + (mkStr "[[\"all\",\"builder\",\"dev\",\"drvAttrs\",\"drvPath\",\"name\",\"out\",\"outPath\",\"outputName\",\"outputs\",\"system\",\"type\",\"x\"],[\"out\",\"dev\"],\"derivation\",[\"builder\",\"name\",\"outputs\",\"system\",\"x\"]]"), + -- == forces both sides, then takes one value as equal to itself, so a + -- function is equal only to itself. Under the IO evaluator, which + -- keeps a forced binding's value as upstream's does, where the pure + -- one evaluates args again at each use. + runTestIO + "the arguments' values reach the result unchanged" + tmpBase + ("let args = { " <> required <> "f = y: y; }; d = derivation args; in builtins.intersectAttrs { f = null; } d == builtins.intersectAttrs { f = null; } args") + (VBool True), + runTest "the result's own attributes replace the outputs' and the arguments'" $ + assertEval + "layers" + ("let d = " <> drv "outputs = [ \"out\" \"all\" ]; type = \"t\"; all = 1; out = 6;" <> "; in builtins.toJSON [ d.type (builtins.isList d.all) d.out.outputName d.drvAttrs.type d.drvAttrs.all ]") + (mkStr "[\"derivation\",true,\"out\",\"t\",1]") + ] + +-- --------------------------------------------------------------------------- +-- Tests: StringContext (Phase 3, Batch 1) +-- --------------------------------------------------------------------------- + +testStringContext :: IO [Bool] +testStringContext = do + putStrLn "eval/string-context" + let sp1 = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello" + sp2 = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "world" + sequence + [ runTest "StringContext Eq" $ + let ctx1 = StringContext (Set.singleton (SCPlain sp1)) + ctx2 = StringContext (Set.singleton (SCPlain sp1)) + in assertEqual "ctx-eq" ctx1 ctx2, + runTest "mkStr constructor" $ + let v = mkStr "hello" + in case v of + VStr t ctx -> + if t == "hello" && ctx == emptyContext + then Pass + else Fail "mkStr produced wrong value" + _ -> Fail "mkStr did not produce VStr", + runTest "mergeContexts mempty" $ + let ctx1 = StringContext (Set.singleton (SCPlain sp1)) + merged = ctx1 <> emptyContext + in assertEqual "merge-mempty" ctx1 merged, + runTest "mergeContexts union" $ + let ctx1 = StringContext (Set.singleton (SCPlain sp1)) + ctx2 = StringContext (Set.singleton (SCDrvOutput sp2 "out")) + merged = ctx1 <> ctx2 + expected = StringContext (Set.fromList [SCPlain sp1, SCDrvOutput sp2 "out"]) + in assertEqual "merge-union" expected merged + ] + +-- --------------------------------------------------------------------------- +-- Tests: Context propagation (Phase 3, Batch 3) +-- --------------------------------------------------------------------------- + +testContextPropagation :: IO [Bool] +testContextPropagation = do + putStrLn "eval/context-propagation" + sequence + [ -- String equality ignores context + runTest "string equality ignores context" $ + assertEval "str-eq-ctx" "\"hello\" == \"hello\"" (VBool True), + -- String comparison ignores context + runTest "string comparison ignores context" $ + assertEval "str-cmp-ctx" "\"a\" < \"b\"" (VBool True), + -- Interpolation produces correct text + runTest "interp text correct" $ + assertEval "interp-text" "let x = \"world\"; in \"hello ${x}\"" (mkStr "hello world"), + -- String + merges (tested at value level) + runTest "string + merges text" $ + assertEval "str-plus" "\"a\" + \"b\"" (mkStr "ab"), + -- concatStringsSep merges text + runTest "concatStringsSep result" $ + assertEval "css-text" "builtins.concatStringsSep \"-\" [\"a\" \"b\"]" (mkStr "a-b"), + -- substring preserves text + runTest "substring text" $ + assertEval "substr-text" "builtins.substring 1 2 \"hello\"" (mkStr "el"), + -- unsafeDiscardStringContext strips context + runTest "discardContext strips" $ + assertEval "discard-ctx" "builtins.unsafeDiscardStringContext \"hello\"" (mkStr "hello"), + -- stringLength drops context (returns int) + runTest "stringLength drops context" $ + assertEval "strlen-drop" "builtins.stringLength \"hello\"" (VInt 5), + -- hashString drops context (returns string with no context) + runTest "hashString result type" $ + assertRight "hash-type" (evalNix "builtins.typeOf (builtins.hashString \"sha256\" \"x\")") $ \val -> + assertEqual "hash-typeof" (mkStr "string") val, + -- replaceStrings text result + runTest "replaceStrings text" $ + assertEval "replace-text" "builtins.replaceStrings [\"o\"] [\"0\"] \"foo\"" (mkStr "f00"), + -- baseNameOf preserves text + runTest "baseNameOf text" $ + assertEval "basename-text" "builtins.baseNameOf \"/foo/bar\"" (mkStr "bar"), + -- dirOf preserves text + runTest "dirOf text" $ + assertEval "dirof-text" "builtins.dirOf \"/foo/bar\"" (mkStr "/foo"), + -- toString propagates + runTest "toString on string" $ + assertEval "tostr-str" "builtins.toString \"hello\"" (mkStr "hello"), + -- toString on int (no context) + runTest "toString on int" $ + assertEval "tostr-int" "builtins.toString 42" (mkStr "42") + ] + +-- --------------------------------------------------------------------------- +-- Tests: Context helpers (Phase 3, Batch 2) +-- --------------------------------------------------------------------------- + +testContextHelpers :: IO [Bool] +testContextHelpers = do + putStrLn "eval/context-helpers" + let sp1 = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello" + sp2 = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "world.drv" + sp3 = StorePath "cccccccccccccccccccccccccccccccc" "source.tar.gz" + sequence + [ runTest "plainContext singleton" $ + let ctx = Context.plainContext sp1 + in assertEqual "plain" (StringContext (Set.singleton (SCPlain sp1))) ctx, + runTest "drvOutputContext singleton" $ + let ctx = Context.drvOutputContext sp2 "out" + in assertEqual "drvOut" (StringContext (Set.singleton (SCDrvOutput sp2 "out"))) ctx, + runTest "allOutputsContext singleton" $ + let ctx = Context.allOutputsContext sp2 + in assertEqual "allOut" (StringContext (Set.singleton (SCAllOutputs sp2))) ctx, + runTest "contextIsEmpty on mempty" $ + assertEqual "emptyCtx" True (Context.contextIsEmpty emptyContext), + runTest "contextIsEmpty on non-empty" $ + assertEqual "nonEmptyCtx" False (Context.contextIsEmpty (Context.plainContext sp1)), + runTest "extractInputSrcs" $ + let ctx = Context.plainContext sp1 <> Context.drvOutputContext sp2 "out" + in assertEqual "srcs" [sp1] (Context.extractInputSrcs ctx), + runTest "extractInputDrvs" $ + let ctx = Context.drvOutputContext sp2 "out" <> Context.drvOutputContext sp2 "dev" <> Context.plainContext sp3 + drvs = Context.extractInputDrvs ctx + in case Map.lookup sp2 drvs of + Just outs -> if length outs == 2 then Pass else Fail ("expected 2 outputs, got " <> T.pack (show (length outs))) + Nothing -> Fail "sp2 not found in drvs", + runTest "appendStrings merges" $ + let ctx1 = Context.plainContext sp1 + ctx2 = Context.drvOutputContext sp2 "out" + (txt, ctx) = Context.appendStrings "hello" ctx1 "world" ctx2 + in if txt == "helloworld" && not (Context.contextIsEmpty ctx) then Pass else Fail "bad append", + runTest "concatStrings empty" $ + let (txt, ctx) = Context.concatStrings [] + in if txt == "" && Context.contextIsEmpty ctx then Pass else Fail "bad empty concat", + runTest "concatStrings merges all" $ + let ctx1 = Context.plainContext sp1 + ctx2 = Context.drvOutputContext sp2 "out" + (txt, ctx) = Context.concatStrings [("a", ctx1), ("b", ctx2), ("c", mempty)] + in if txt == "abc" && Set.size (unStringContext ctx) == 2 then Pass else Fail "bad concat" + ] + +-- --------------------------------------------------------------------------- +-- Tests: structured attributes and the JSON they travel as +-- --------------------------------------------------------------------------- + +-- | @__structuredAttrs@ end to end on the evaluation side, and the JSON +-- rules the evaluator and builder share. Every drvPath, rendering and +-- @.attrs.sh@ expected here was read off Nix 2.33.2 (nix-instantiate and +-- a build on aarch64-darwin), whose code for each is 2.24.9's. +testStructuredAttrs :: IO [Bool] +testStructuredAttrs = do + putStrLn "derivation/structured-attrs" + tmpBase <- getTemporaryDirectory + let base = "name = \"sa\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; __structuredAttrs = true; " + structured attrs = "(derivation { " <> base <> attrs <> " })" + withoutContext expr = "builtins.unsafeDiscardStringContext " <> expr + drvPathIs label attrs expected = + runTest label (assertEval label (withoutContext (structured attrs <> ".drvPath")) (mkStr expected)) + dependency = "let d = derivation { name = \"d\"; system = \"x\"; builder = \"b\"; }; in " + envResult <- evalDerivationIO tmpBase (structured "outputs = [ \"out\" \"dev\" \"lib\" ];") + -- A file for the outPath that is a path, copied to the store as upstream + -- copies it: "hello\n" named x is m5zd3qj7...-x there. + let jsonDir = tmpBase "nova-nix-test-json-outpath" + createDirectoryIfMissing True jsonDir + BS.writeFile (jsonDir "x") "hello\n" + copiedOutPath <- evalNixIO jsonDir "builtins.unsafeDiscardStringContext (builtins.toJSON { outPath = ./x; })" + lengthOfPath <- evalNixIO jsonDir "builtins.stringLength ./x" + substringOfPath <- evalNixIO jsonDir "builtins.substring 11 32 ./x" + substringContext <- evalNixIO jsonDir "builtins.hasContext (builtins.substring 11 32 ./x)" + discardedPath <- evalNixIO jsonDir "builtins.unsafeDiscardStringContext ./x" + discardedContext <- evalNixIO jsonDir "builtins.hasContext (builtins.unsafeDiscardStringContext ./x)" + copiedContext <- evalNixIO jsonDir "builtins.attrNames (builtins.getContext (builtins.toJSON { outPath = ./x; })) == [ \"/nix/store/m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg-x\" ]" + -- The IO evaluator, because it is the one with a store to copy into. + uncopiedPath <- evalNixIO jsonDir "builtins.toJSON { __toString = s: ./x; }" + uncopiedNested <- evalNixIO jsonDir "builtins.toJSON { __toString = s: { outPath = ./x; }; }" + removeDirectoryRecursive jsonDir + let jsonDirPath = mkStr ("\"" <> canonPathValue (T.pack (jsonDir "x")) <> "\"") + sequence + [ drvPathIs + "a nested set and a mixed list are one JSON object" + "nested = { a = 1; b = { c = [ \"x\" \"y\" ]; }; \"with space\" = true; }; list = [ \"a\" \"b c\" 1 2.5 null true false ];" + "/nix/store/rkxyljjwm2miccr3ffbkvgm7fzmjqddg-sa.drv", + drvPathIs + "scalars render as nlohmann renders them" + "i = 42; neg = -7; f = 1.0; f2 = 0.1; big = 1.0e20; small = 1.0e-7; b = true; n = null; s = \"str\\n\\t\\\"q\\\"\\\\\";" + "/nix/store/hgzhpjmp6cpjj0r768xp982an303rh2q-sa.drv", + drvPathIs + "member names order by their bytes" + "\"\233\" = 1; \"Z\" = 2; \"a\" = 3; \"_\" = 4; \"1x\" = 5;" + "/nix/store/s2aaxxxqvmdh95wqq3sa75fqal0nv2vf-sa.drv", + drvPathIs "a kept null is a JSON null" "n = null;" "/nix/store/r3880xygjwsqk8a4xiq8zrbhpanlf9a3-sa.drv", + drvPathIs + "__ignoreNulls leaves a null out of the object" + "n = null; __ignoreNulls = true;" + "/nix/store/cms7b67rf9bn7b376f64i05v1cw2chrh-sa.drv", + drvPathIs + "a placeholder stays a placeholder in the object" + "here = builtins.placeholder \"out\";" + "/nix/store/2iqn1i3rl4x9ll8a6j46k1rkk9c3fkd5-sa.drv", + drvPathIs + "a fixed-output derivation keeps its hash fields in the object" + "outputHash = \"sha256-47DEQpj8HBSKTXA6xJbgU1CNMmz7W08F06XOTYP1hmM=\"; outputHashMode = \"flat\"; outputHashAlgo = \"sha256\";" + "/nix/store/dp6sib5psffrm1krca5l9wn9nshspn7f-sa.drv", + drvPathIs + "a set under outputChecks is passed as it is" + "outputChecks.out = { allowedReferences = [ ]; maxSize = 100; };" + "/nix/store/xzkk2dxqm69akjjshlvk45s8yd6y1dbn-sa.drv", + runTest "__structuredAttrs = false keeps one variable per attribute" $ + assertEval + "sa-false" + (withoutContext "(derivation { name = \"sa\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; __structuredAttrs = false; x = [ \"a\" \"b\" ]; }).drvPath") + (mkStr "/nix/store/i9rm0fa7pbzrbrsaakninfa4232wmj7c-sa.drv"), + runTest "every output of a structured derivation gets upstream's path" $ + assertEval + "sa-outputs" + (withoutContext (structured "outputs = [ \"out\" \"dev\" \"lib\" ];" <> ".dev.outPath")) + (mkStr "/nix/store/jfnikb9k7953srg5mlp3mccmqaijvxyy-sa-dev"), + runTest "the environment holds __json and the outputs, nothing else" $ + assertRight "sa-env" envResult $ \drv -> + assertEqual + "sa-env" + [ ("__json", "{\"builder\":\"/bin/sh\",\"name\":\"sa\",\"outputs\":[\"out\",\"dev\",\"lib\"],\"system\":\"x86_64-linux\"}"), + ("dev", "/nix/store/jfnikb9k7953srg5mlp3mccmqaijvxyy-sa-dev"), + ("lib", "/nix/store/zpjd7d2l5jqzynv3377a36nk6rzb5il4-sa-lib"), + ("out", "/nix/store/bs6ppbphi38qlbjfz67pfk86sx7l4vks-sa") + ] + (Map.toList (drvEnv drv)), + -- toJSON's rules for a set, which the object above shares. + runTest "toJSON of a set with outPath converts the outPath value, not its string" $ + assertEval "json-outpath-int" "builtins.toJSON { outPath = 1; }" (mkStr "1") + `andThen` assertEval "json-outpath-set" "builtins.toJSON { outPath = { a = 1; }; }" (mkStr "{\"a\":1}") + `andThen` assertEval "json-outpath-list" "builtins.toJSON { outPath = [ 1 { outPath = 2; } ]; }" (mkStr "[1,2]") + `andThen` assertEval "json-outpath-null" "builtins.toJSON { outPath = null; }" (mkStr "null"), + runTest "toJSON of a set whose outPath is a path copies it to the store, with context" $ + assertRight "json-outpath-path" copiedOutPath (assertEqual "json-outpath-path" (mkStr "\"/nix/store/m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg-x\"")) + `andThen` assertRight "json-outpath-path-context" copiedContext (assertEqual "json-outpath-path-context" (VBool True)), + runTest "a builtin taking a string copies a path to the store first" $ + assertRight "strlen-path" lengthOfPath (assertEqual "strlen-path" (VInt 45)) + `andThen` assertRight "substring-path" substringOfPath (assertEqual "substring-path-text" "m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg" . stringBytes) + `andThen` assertRight "substring-path-context" substringContext (assertEqual "substring-path-context" (VBool True)) + `andThen` assertRight "discard-path" discardedPath (assertEqual "discard-path" (mkStr "/nix/store/m5zd3qj7c4bs4g5d8hqvs5pc5xicclfg-x")) + `andThen` assertRight "discard-path-context" discardedContext (assertEqual "discard-path-context" (VBool False)), + runTest "toJSON of a __toString set returning a path keeps the path's own text, uncopied" $ + assertRight "json-tostring-path" uncopiedPath (assertEqual "json-tostring-path" jsonDirPath) + `andThen` assertRight "json-tostring-nested" uncopiedNested (assertEqual "json-tostring-nested" jsonDirPath), + runTest "toJSON of a __toString set returning a string keeps its context" $ + let json = "(builtins.toJSON { __toString = s: \"${d}\"; })" + in assertEval "json-tostring-string" (dependency <> withoutContext json) (mkStr "\"/nix/store/74ii7m3ms7x609g9mcy8j52jfvpdizcp-d\"") + `andThen` assertEval + "json-tostring-context" + (dependency <> "builtins.getContext " <> json <> " == { \"/nix/store/nzvhjdd45mdh8mkqm4vz4hdqsjrvkm8j-d.drv\" = { outputs = [ \"out\" ]; }; }") + (VBool True), + runTest "toJSON of a __toString set returning an integer is an error, not a coercion" $ + assertEvalFail "json-tostring-int" "builtins.toJSON { __toString = s: 1; }", + drvPathIs + "a structured attribute's outPath and __toString follow toJSON's rules" + "o = { outPath = { inner = 1; }; }; i = { outPath = 1; }; t = { __toString = s: \"str\"; };" + "/nix/store/rz7pfawzsr1a5ig11s1xssbsc2mxys9b-sa.drv", + runTest "toJSON escapes backspace and form feed by name" $ + assertEval + "json-bf" + "builtins.toJSON (builtins.fromJSON \"\\\"\\\\u0008\\\\u000c\\\\u0001\\\"\")" + (mkStr "\"\\b\\f\\u0001\""), + runTest "__structuredAttrs must be a boolean" $ + assertEvalFail "sa-flag" "(derivation { name = \"sa\"; system = \"x\"; builder = \"b\"; __structuredAttrs = \"yes\"; }).drvPath", + runTest "a structured system may not refer to a store path" $ + assertEvalError + "sa-system-ctx" + (dependency <> "(derivation { name = \"sa\"; builder = \"/bin/sh\"; __structuredAttrs = true; system = \"${d}\"; }).drvPath") + "the string '/nix/store/74ii7m3ms7x609g9mcy8j52jfvpdizcp-d' is not allowed to refer to a store path (such as '!out!nzvhjdd45mdh8mkqm4vz4hdqsjrvkm8j-d.drv')", + runTest "a structured output name may not refer to a store path" $ + assertEvalError + "sa-output-ctx" + (dependency <> structured "outputs = [ \"out\" \"${d}\" ];" <> ".drvPath") + "the string '/nix/store/74ii7m3ms7x609g9mcy8j52jfvpdizcp-d' is not allowed to refer to a store path (such as '!out!nzvhjdd45mdh8mkqm4vz4hdqsjrvkm8j-d.drv')", + runTest "a structured builder must be a string, not a value coerced to one" $ + assertEvalError + "sa-builder" + "(derivation { name = \"sa\"; system = \"x\"; __structuredAttrs = true; builder = 1; }).drvPath" + "expected a string but found an integer: 1", + runTest "a structured outputHash must be a string" $ + assertEvalError "sa-outputhash" (structured "outputHash = 1;" <> ".drvPath") "expected a string but found an integer: 1", + runTest "a function cannot become JSON" $ + assertEvalFail "sa-function" (structured "f = x: x;" <> ".drvPath"), + -- The JSON both halves share. + runTest "JSON escapes control characters as nlohmann does" $ + assertEqual + "json-escape" + (TE.encodeUtf8 "\"a\\b\\f\\n\\r\\t\\u0001\\u001f\127/\\\"\\\\\233\"") + (renderJson (JsonString "a\b\f\n\r\t\1\31\127/\"\\\233")), + runTest "JSON numbers render as nlohmann renders them" $ + assertEqual + "json-numbers" + "[1.0,1e+20,1e-07,0.1,null,null,-7,18446744073709551615]" + (renderJson (JsonArray [JsonFloat 1, JsonFloat 1e20, JsonFloat 1e-7, JsonFloat 0.1, JsonFloat (1 / 0), JsonFloat (0 / 0), JsonInt (-7), JsonInt 18446744073709551615])), + runTest "upstream's .attrs.json reads back and renders to the same bytes" $ + assertRight "json-upstream" (decodeStructuredAttrs upstreamAttrsJson) $ \attrs -> + assertEqual "json-upstream" (TE.encodeUtf8 upstreamAttrsJson) (encodeStructuredAttrs attrs), + runTest "the .attrs.sh renderer writes what upstream writes" $ + assertRight "attrs-sh" (decodeStructuredAttrs upstreamAttrsJson) $ \attrs -> + assertEqual "attrs-sh" upstreamAttrsShell (renderAttrsShell attrs), + runTest "outputs become an object of placeholders" $ + assertEqual + "outputs-object" + (StructuredAttrs (Map.fromList [("outputs", JsonObject (Map.fromList [("dev", JsonString (hashPlaceholder "dev")), ("out", JsonString (hashPlaceholder "out"))]))])) + (withOutputPlaceholders ["out", "dev"] (StructuredAttrs (Map.fromList [("outputs", JsonArray [JsonString "out", JsonString "dev"])]))), + runTest "a null __json is an empty object, another non-object an error" $ + assertEqual "decode-shape" (Right (StructuredAttrs Map.empty)) (decodeStructuredAttrs "null") + `andThen` assertLeft "decode-array" (decodeStructuredAttrs "[1]"), + runTest "a list-of-strings attribute is read strictly" $ + let attrs = StructuredAttrs (Map.fromList [("good", JsonArray [JsonString "a", JsonString "b"]), ("mixed", JsonArray [JsonString "a", JsonInt 1]), ("scalar", JsonString "a b")]) + in assertEqual "strings-good" (Right (Just ["a", "b"])) (stringsAttr "good" attrs) + `andThen` assertEqual "strings-absent" (Right Nothing) (stringsAttr "absent" attrs) + `andThen` assertLeft "strings-mixed" (stringsAttr "mixed" attrs) + `andThen` assertLeft "strings-scalar" (stringsAttr "scalar" attrs), + runTest "JSON parsing decodes every escape, surrogate pairs included" $ + assertEqual + "parse-escapes" + (Right (JsonString "\"\\/\b\f\n\r\t\233\128512")) + (parseJson "\"\\\"\\\\\\/\\b\\f\\n\\r\\t\\u00E9\\ud83d\\ude00\""), + runTest "JSON parsing keeps integers apart from floats, as nlohmann's lexer does" $ + assertEqual + "parse-numbers" + (Right (JsonArray [JsonInt 18446744073709551615, JsonFloat 18446744073709551616, JsonInt (-9223372036854775808), JsonFloat (-9223372036854775809), JsonInt 0, JsonFloat 1, JsonFloat 100])) + (parseJson "[18446744073709551615,18446744073709551616,-9223372036854775808,-9223372036854775809,-0,1.0,1E2]"), + runTest "JSON parsing takes the last of a repeated name, whitespace and a byte order mark around" $ + assertEqual + "parse-object" + (Right (JsonObject (Map.fromList [("a", JsonArray [JsonInt 2, JsonNull])]))) + (parseJson "\65279 \n{ \"a\" : 1 , \"a\":[ 2 ,null ] }\r\n"), + runTest "JSON parsing refuses what nlohmann refuses" $ + foldr + (\bad acc -> assertLeft ("parse-refuses " <> bad) (parseJson bad) `andThen` acc) + Pass + ["\"a\tb\"", "01", "[1,]", "1e400", "{\"a\" 1}", "tru", "1 2", "\"\\ud800\"", "\"\\udc00\"", "\"\\x\"", "1.", "-", "\"unterminated", ""], + runTestM "rendered JSON parses back to the value it came from" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll (genJson 3) $ \json -> + (parseJson =<< either (Left . T.pack . show) Right (TE.decodeUtf8' (renderJson json))) QC.=== Right json + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + +-- | A subset of the @.attrs.json@ a Nix 2.33.2 build handed its builder +-- (the members holding no store path), byte for byte. +upstreamAttrsJson :: Text +upstreamAttrsJson = + "{\"1x\":\"skipped\",\"badList\":[\"a\",[\"nested\"]],\"badObj\":{\"k\":{\"nested\":1}},\"big\":1099511627776,\"ctl\":\"a\\b\\f\\u0001\\u001f\127/\\\"\\\\z\",\"emptyList\":[],\"emptyObj\":{},\"f\":1.5,\"fbig\":1e+20,\"fi\":3.0,\"fl\":false,\"fltList\":[1.5],\"fltObj\":{\"a\":1,\"b\":2.5},\"fneg\":-1e+20,\"fneg2\":-2.5,\"fsmall\":0.1,\"ftrunc\":16777217.5,\"huge\":9223372036854775807,\"int\":42,\"list\":[\"a\",\"b c\",1,2.0,true,false,null],\"n\":null,\"neg\":-7,\"obj\":{\"b\":false,\"k\":\"v\",\"key with space\":1,\"q\":\"'\"},\"str\":\"it's a \\\"test\\\"\\n\",\"t\":true,\"uni\":\"\233\8364\128512\",\"with space\":\"skipped\"}" + +-- | The lines of that build's @.attrs.sh@ for the members of +-- 'upstreamAttrsJson'. Missing ones (a non-integral number, a nested +-- array or object, a name bash cannot hold) are upstream's omissions; +-- @fbig@ and @fneg@ are aarch64's saturating float conversion. +upstreamAttrsShell :: Text +upstreamAttrsShell = + "declare big=0\ndeclare ctl='a\8\12\1\31\127/\"\\z'\ndeclare -a emptyList=()\ndeclare -A emptyObj=()\ndeclare fbig=2147483647\ndeclare fi=3\ndeclare fl=\ndeclare fneg=-2147483648\ndeclare ftrunc=16777217\ndeclare huge=-1\ndeclare int=42\ndeclare -a list=('a' 'b c' 1 2 1 '' )\ndeclare n=''\ndeclare neg=-7\ndeclare -A obj=(['b']= ['k']='v' ['key with space']=1 ['q']=''\\''' )\ndeclare str='it'\\''s a \"test\"\n'\ndeclare t=1\ndeclare uni='\233\8364\128512'\n" + +-- | JSON values up to a nesting depth, strings drawn from what the +-- renderer escapes and what it passes through as UTF-8, numbers across +-- both integer types and finite floats. +genJson :: Int -> QC.Gen Json +genJson depth = QC.oneof (scalars <> [nested | depth > 0]) + where + scalars = + [ pure JsonNull, + JsonBool <$> QC.arbitrary, + JsonInt . toInteger <$> (QC.arbitrary :: QC.Gen Int64), + JsonInt . toInteger <$> (QC.arbitrary :: QC.Gen Word64), + JsonFloat <$> (QC.arbitrary `QC.suchThat` (\d -> not (isNaN d || isInfinite d))), + JsonString <$> genJsonText + ] + nested = + QC.oneof + [ JsonArray <$> QC.resize 4 (QC.listOf (genJson (depth - 1))), + JsonObject . Map.fromList <$> QC.resize 4 (QC.listOf ((,) <$> genJsonText <*> genJson (depth - 1))) + ] + +-- | Text mixing the characters JSON escapes with plain and multi-byte ones. +genJsonText :: QC.Gen Text +genJsonText = + T.pack <$> QC.listOf (QC.elements ['"', '\\', '/', '\b', '\f', '\n', '\r', '\t', '\0', '\31', '\127', 'a', ' ', '\233', '\8364', '\128512']) + +-- --------------------------------------------------------------------------- +-- Tests: Derivation context + new builtins (Phase 3, Batch 4) +-- --------------------------------------------------------------------------- + +testDrvContext :: IO [Bool] +testDrvContext = do + putStrLn "eval/drv-context" + sequence + [ -- hasContext: plain string has no context + runTest "hasContext on plain string" $ + assertEval "hasCtx-plain" "builtins.hasContext \"hello\"" (VBool False), + -- hasContext: derivation outPath has context + runTest "hasContext on drv outPath" $ + assertEval + "hasCtx-drv" + "builtins.hasContext (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath" + (VBool True), + -- hasContext: after discardContext, no context + runTest "hasContext after discard" $ + assertEval + "hasCtx-discard" + "builtins.hasContext (builtins.unsafeDiscardStringContext (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath)" + (VBool False), + -- getContext: plain string returns empty attrset + runTest "getContext on plain string" $ + assertRight "getCtx-plain" (evalNix "builtins.getContext \"hello\"") $ \val -> + case val of + VAttrs m -> if attrSetNull m then Pass else Fail "expected empty attrset" + _ -> Fail ("expected VAttrs, got " <> T.pack (show val)), + -- getContext: drv outPath has outputs entry + runTest "getContext on drv outPath" + $ assertRight + "getCtx-drv" + (evalNix "builtins.getContext (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath") + $ \val -> case val of + VAttrs m -> + if attrSetSize m == 1 + then Pass + else Fail ("expected 1 entry, got " <> T.pack (show (attrSetSize m))) + _ -> Fail ("expected VAttrs, got " <> T.pack (show val)), + -- getContext: drvPath has allOutputs + runTest "getContext on drvPath has allOutputs" + $ assertRight + "getCtx-drvPath" + (evalNix "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ctx = builtins.getContext d.drvPath; in builtins.length (builtins.attrNames ctx)") + $ \val -> assertEqual "one-entry" (VInt 1) val, + -- getContext keys are identity: canonical /nix/store spelling on + -- every platform, never the platform file-path mapping. + runTest "getContext key is canonical store path" + $ assertRight + "getCtx-canonical" + (evalNix "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in builtins.elemAt (builtins.attrNames (builtins.getContext d.drvPath)) 0") + $ \val -> case val of + VStr key _ + | "/nix/store/" `BS.isPrefixOf` key && not ("\\" `BS.isInfixOf` key) -> Pass + | otherwise -> Fail ("expected a canonical /nix/store key, got " <> bytesText key) + _ -> Fail ("expected VStr, got " <> T.pack (show val)), + -- appendContext: adds context to plain string + runTest "appendContext adds context" $ + assertEval + "appendCtx-add" + "let ctx = builtins.listToAttrs [{ name = \"/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo\"; value = { path = true; }; }]; in builtins.hasContext (builtins.appendContext \"hello\" ctx)" + (VBool True), + -- appendContext: empty context is no-op + runTest "appendContext empty is no-op" $ + assertEval "appendCtx-empty" "builtins.hasContext (builtins.appendContext \"hello\" {})" (VBool False), + -- unsafeDiscardOutputDependency KEEPS a derivation-output (Built) ref + -- unchanged (upstream), rather than dropping it as it once did. + runTest "discardOutputDep keeps output-dependency context" + $ assertRight + "discardOutDep-keep" + ( evalNix $ + T.concat + [ "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ", + "stripped = builtins.unsafeDiscardOutputDependency d.outPath; ", + "in builtins.hasContext stripped" + ] + ) + $ \val -> assertEqual "keep-ctx" (VBool True) val, + -- ctx3: an all-outputs (DrvDeep) reference on d.drvPath is DOWNGRADED to + -- a plain path reference, not dropped. + runTest "discardOutputDep downgrades drvPath to a plain ref" $ + assertEval + "discardOutDep-downgrade" + "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ctx = builtins.getContext (builtins.unsafeDiscardOutputDependency d.drvPath); key = builtins.elemAt (builtins.attrNames ctx) 0; in ctx.${key} == { path = true; }" + (VBool True), + -- ctx4: getContext renders each path's output names ascending. + runTest "getContext output names are ascending" $ + assertEval + "getctx-ascending" + "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ \"out\" \"dev\" \"lib\" ]; }; s = \"${d.out}${d.lib}${d.dev}\"; ctx = builtins.getContext s; key = builtins.elemAt (builtins.attrNames ctx) 0; in ctx.${key}.outputs == [ \"dev\" \"lib\" \"out\" ]" + (VBool True), + -- ctx5: addDrvOutputDependencies upgrades a plain .drv reference back to + -- an all-outputs reference (the inverse of the ctx3 downgrade). + runTest "addDrvOutputDependencies upgrades a plain drv ref" $ + assertEval + "adddrvout-upgrade" + "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; plain = builtins.unsafeDiscardOutputDependency d.drvPath; ctx = builtins.getContext (builtins.addDrvOutputDependencies plain); key = builtins.elemAt (builtins.attrNames ctx) 0; in ctx.${key} == { allOutputs = true; }" + (VBool True), + runTest "addDrvOutputDependencies rejects a derivation output" $ + assertEvalFail + "adddrvout-built" + "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in builtins.addDrvOutputDependencies d.outPath", + runTest "addDrvOutputDependencies rejects a multi-element context" $ + assertEvalFail + "adddrvout-multi" + "let d = derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in builtins.addDrvOutputDependencies \"${d.drvPath}${d.outPath}\"", + -- drv1: a derivation embedding another's drvPath (an all-outputs ref) + -- needs the referenced .drv's output names, which only the IO evaluator + -- supplies; pure eval fails loudly rather than dropping the reference. + runTest "deep drvPath reference fails loudly in pure eval" $ + assertEvalFail + "drv1-pure-miss" + "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ref = dep.drvPath; }; in main.drvPath", + -- derivation outPath is a string (not path) with context + runTest "drv outPath is VStr" + $ assertRight + "drv-outPath-type" + (evalNix "builtins.typeOf (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath") + $ \val -> assertEqual "string-type" (mkStr "string") val, + -- derivation drvPath is a string (not path) with context + runTest "drv drvPath is VStr" + $ assertRight + "drv-drvPath-type" + (evalNix "builtins.typeOf (derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).drvPath") + $ \val -> assertEqual "string-type" (mkStr "string") val, + -- hasContext error on non-string + runTest "hasContext type error" $ + assertEvalFail "hasCtx-err" "builtins.hasContext 42", + -- getContext error on non-string + runTest "getContext type error" $ + assertEvalFail "getCtx-err" "builtins.getContext 42", + -- appendContext error on non-string first arg + runTest "appendContext type error" $ + assertEvalFail "appendCtx-err" "builtins.appendContext 42 {}", + -- deterministic: same derivation produces same paths + runTest "derivation with context deterministic" + $ assertRight + "drv-det-ctx" + (evalNix "let d1 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; d2 = derivation { name = \"a\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; in d1.outPath == d2.outPath") + $ \val -> assertEqual "deterministic" (VBool True) val + ] + +-- --------------------------------------------------------------------------- +-- Tests: Realise +-- --------------------------------------------------------------------------- + +-- | What the fake store and caches record, in order. +data RealiseEvent + = EvQueried StorePath + | EvFetched [StorePath] + | EvBuilt Text + | EvReported Realise.Realised Text + deriving (Eq, Show) + +-- | A fake store and cache. A cache entry maps a path to its references, a +-- fetch refuses a path whose references are not valid, as the database's +-- unregistered-referent guard does, and a build makes its outputs valid. +-- The cache fails to deliver the broken paths it offers, and cannot be +-- asked about the unreachable ones at all. +data FakeWorld = FakeWorld + { fwValid :: !(Set.Set StorePath), + fwCache :: !(Map.Map StorePath [StorePath]), + fwBroken :: !(Set.Set StorePath), + fwUnreachable :: !(Set.Set StorePath), + fwEvents :: ![RealiseEvent] + } + +-- | A world with the given cache entries and valid paths, and no faults. +fakeWorld :: [(Text, [Text])] -> [Text] -> FakeWorld +fakeWorld cache valid = + FakeWorld + { fwValid = Set.fromList (map fakePath valid), + fwCache = Map.fromList [(fakePath p, map fakePath refs) | (p, refs) <- cache], + fwBroken = Set.empty, + fwUnreachable = Set.empty, + fwEvents = [] + } + +fakeEvent :: RealiseEvent -> State FakeWorld () +fakeEvent event = modify' (\world -> world {fwEvents = event : fwEvents world}) + +-- | What the fake cache says when it cannot be asked about a path. +fakeQueryFailure :: StorePath -> Text +fakeQueryFailure sp = "cannot ask about " <> spName sp + +fakeSubst :: Realise.SubstEffects (State FakeWorld) +fakeSubst = + Realise.SubstEffects + { Realise.seValid = \sp -> gets (Set.member sp . fwValid), + Realise.seReferences = \sp -> do + fakeEvent (EvQueried sp) + unreachable <- gets (Set.member sp . fwUnreachable) + offer <- gets (maybe Realise.NotOffered Realise.Offered . Map.lookup sp . fwCache) + pure (if unreachable then Realise.QueryFailed (fakeQueryFailure sp) else offer), + Realise.seFetch = \paths -> do + valid <- gets fwValid + cache <- gets fwCache + broken <- gets fwBroken + let incoming = Set.fromList paths + landed sp = Set.member sp valid || Set.member sp incoming + refused = not (all (all landed . flip (Map.findWithDefault []) cache) paths) + if refused || any (`Set.member` broken) paths + then pure Realise.FetchFailed + else do + fakeEvent (EvFetched paths) + modify' (\world -> world {fwValid = fwValid world <> incoming}) + pure Realise.Fetched + } + +fakeRealiseEffects :: Set.Set Text -> Realise.RealiseEffects (State FakeWorld) +fakeRealiseEffects failing = + Realise.RealiseEffects + { Realise.reSubst = fakeSubst, + Realise.reAllValid = \drv -> gets (\world -> all (\out -> Set.member (doPath out) (fwValid world)) (drvOutputs drv)), + Realise.reBuild = \drv _ -> do + let name = fakeDrvName drv + if Set.member name failing + then pure (Left ("building " <> name <> " failed")) + else do + fakeEvent (EvBuilt name) + modify' (\world -> world {fwValid = fwValid world <> Set.fromList (map doPath (drvOutputs drv))}) + pure (Right ()), + Realise.reReport = \status drv -> fakeEvent (EvReported status (fakeDrvName drv)) + } + +fakeDrvName :: Derivation -> Text +fakeDrvName drv = case drvOutputs drv of + (out : _) -> spName (doPath out) + [] -> "" + +-- | A store path with a name-derived hash, so a failure reads as names. +fakePath :: Text -> StorePath +fakePath name = StorePath (T.take 32 (T.replicate 32 (T.take 1 name))) name + +-- | A derivation with one output per name, depending on the named nodes. +fakeNode :: Text -> [Text] -> [Text] -> (StorePath, DepGraph.DepNode) +fakeNode name outputs deps = + ( drvPath, + DepGraph.DepNode + { DepGraph.dnDrvPath = drvPath, + DepGraph.dnDerivation = + Derivation + { drvOutputs = [DerivationOutput out (fakePath out) "" "" | out <- outputs], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + }, + DepGraph.dnDeps = map (fakePath . (<> ".drv")) deps + } + ) + where + drvPath = fakePath (name <> ".drv") + +-- | Run 'Realise.realise' from a root over a graph and a cache, returning the +-- result, the events in order, and the final valid set. +runRealise :: + Set.Set Text -> + [(StorePath, DepGraph.DepNode)] -> + [(Text, [Text])] -> + [Text] -> + Text -> + (Either Realise.RealiseFailure (), [RealiseEvent], Set.Set StorePath) +runRealise failing nodes cache valid = runRealiseIn Realise.NoFallback (fakeWorld cache valid) failing nodes + +-- | 'runRealise' in a given world, under a given fallback. +runRealiseIn :: + Realise.Fallback -> + FakeWorld -> + Set.Set Text -> + [(StorePath, DepGraph.DepNode)] -> + Text -> + (Either Realise.RealiseFailure (), [RealiseEvent], Set.Set StorePath) +runRealiseIn fallback world failing nodes root = + let (result, final) = + runState + (Realise.realise fallback (fakeRealiseEffects failing) (DepGraph.DepGraph (Map.fromList nodes)) (fakePath (root <> ".drv"))) + world + in (result, reverse (fwEvents final), fwValid final) + +-- | Only the fetches and builds of a run, the part that costs anything. +realiseWork :: [RealiseEvent] -> [RealiseEvent] +realiseWork = filter isWork + where + isWork (EvFetched _) = True + isWork (EvBuilt _) = True + isWork _ = False + +-- | A random reference graph: each node references only lower nodes, so the +-- graph is acyclic, and some nodes are absent from the cache. +genClosureCase :: QC.Gen (Map.Map Int [Int], [Int]) +genClosureCase = do + size <- QC.chooseInt (1, 12) + references <- traverse (\node -> (,) node <$> QC.sublistOf [0 .. node - 1]) [0 .. size - 1] + absent <- QC.sublistOf [0 .. size - 1] + pure (Map.fromList references, absent) + +testRealise :: IO [Bool] +testRealise = do + putStrLn "realise" + sequence + [ -- hello is on the cache, so nothing it was built from is touched, only + -- what it references at runtime. + runTest "a root on the cache fetches its runtime closure and nothing else" $ + let (result, events, _) = + runRealise + Set.empty + [fakeNode "hello" ["hello-out"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + [("hello-out", ["glibc-out"]), ("glibc-out", []), ("gcc-out", [])] + [] + "hello" + in assertEqual + "realise" + (Right (), [EvFetched [fakePath "glibc-out"], EvFetched [fakePath "hello-out"]], False) + (result, realiseWork events, EvQueried (fakePath "gcc-out") `elem` events), + runTest "a root the cache lacks realises its inputs, then builds" $ + let (result, events, _) = + runRealise + Set.empty + [fakeNode "hello" ["hello-out"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + [("gcc-out", [])] + [] + "hello" + in assertEqual "realise" (Right (), [EvFetched [fakePath "gcc-out"], EvBuilt "hello-out"]) (result, realiseWork events), + runTest "a reference the cache lacks fails the substitution and builds" $ + let (result, events, valid) = + runRealise + Set.empty + [fakeNode "hello" ["hello-out"] []] + [("hello-out", ["gone-out"])] + [] + "hello" + in assertEqual + "realise" + (Right (), [EvBuilt "hello-out"], False) + (result, realiseWork events, Set.member (fakePath "gone-out") valid), + -- Upstream's retrySubstitution: the closure's hole is an input built + -- here, and then the substitute is good, so hello is not built. + runTest "an input that fills the closure's hole lets the substitute through" $ + let (result, events, _) = + runRealise + Set.empty + [fakeNode "hello" ["hello-out"] ["lib"], fakeNode "lib" ["lib-out"] []] + [("hello-out", ["lib-out"])] + [] + "hello" + in assertEqual "realise" (Right (), [EvBuilt "lib-out", EvFetched [fakePath "hello-out"]]) (result, realiseWork events), + runTest "a root with a missing output is not retried when no reference was at fault" $ + let (_, events, _) = + runRealise Set.empty [fakeNode "hello" ["hello-out"] []] [] [] "hello" + in assertEqual "narinfo queries" (1 :: Int) (length [() | EvQueried _ <- events]), + runTest "outputs arrive together, and one referencing another is no hole" $ + let (result, events, _) = + runRealise + Set.empty + [fakeNode "pkg" ["pkg-bin", "pkg-lib"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + [("pkg-bin", ["pkg-lib"]), ("pkg-lib", [])] + [] + "pkg" + in assertEqual "realise" (Right (), [EvFetched [fakePath "pkg-bin", fakePath "pkg-lib"]]) (result, realiseWork events), + runTest "one missing output of two builds rather than half substituting" $ + let (result, events, valid) = + runRealise + Set.empty + [fakeNode "pkg" ["pkg-bin", "pkg-lib"] []] + [("pkg-bin", [])] + [] + "pkg" + in assertEqual + "realise" + (Right (), [EvBuilt "pkg-bin"], True) + (result, realiseWork events, Set.member (fakePath "pkg-lib") valid), + runTest "a self-reference is no hole" $ + let (result, events, _) = + runRealise Set.empty [fakeNode "hello" ["hello-out"] []] [("hello-out", ["hello-out"])] [] "hello" + in assertEqual "realise" (Right (), [EvFetched [fakePath "hello-out"]]) (result, realiseWork events), + -- The cycle ends at the visited set, and the registration it reaches + -- refuses the unregistered referent: a failed substitute. + runTest "a reference cycle a cache declares ends, and fails the substitution" $ + let (result, events, _) = + runRealise + Set.empty + [fakeNode "hello" ["hello-out"] []] + [("hello-out", ["a-out"]), ("a-out", ["b-out"]), ("b-out", ["a-out"])] + [] + "hello" + in assertEqual "realise" (Left (Realise.SubstitutesFailed (fakePath "hello.drv")), []) (result, realiseWork events), + runTest "under fallback a reference cycle a cache declares builds" $ + let (result, events, _) = + runRealiseIn + Realise.BuildFromSource + (fakeWorld [("hello-out", ["a-out"]), ("a-out", ["b-out"]), ("b-out", ["a-out"])] []) + Set.empty + [fakeNode "hello" ["hello-out"] []] + "hello" + in assertEqual "realise" (Right (), [EvBuilt "hello-out"]) (result, realiseWork events), + -- Upstream's DerivationGoal::outputsSubstitutionTried: a substitute + -- that fails is not a substitute the cache lacks. + runTest "a substitute that fails stops the build, naming the derivation" $ + let (result, events, valid) = + runRealiseIn + Realise.NoFallback + (fakeWorld [("hello-out", [])] []) {fwBroken = Set.singleton (fakePath "hello-out")} + Set.empty + [fakeNode "hello" ["hello-out"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + "hello" + in assertEqual + "realise" + (Left (Realise.SubstitutesFailed (fakePath "hello.drv")), [], False, False) + (result, realiseWork events, EvQueried (fakePath "gcc-out") `elem` events, Set.member (fakePath "hello-out") valid), + runTest "under fallback a substitute that fails builds instead, and is not retried" $ + let (result, events, _) = + runRealiseIn + Realise.BuildFromSource + (fakeWorld [("hello-out", []), ("gcc-out", [])] []) {fwBroken = Set.singleton (fakePath "hello-out")} + Set.empty + [fakeNode "hello" ["hello-out"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + "hello" + in assertEqual + "realise" + (Right (), [EvFetched [fakePath "gcc-out"], EvBuilt "hello-out"], 1 :: Int) + (result, realiseWork events, length [() | EvQueried sp <- events, sp == fakePath "hello-out"]), + runTest "a reference whose substitute fails stops the build of what names it" $ + let (result, events, _) = + runRealiseIn + Realise.NoFallback + (fakeWorld [("hello-out", ["lib-out"]), ("lib-out", [])] []) {fwBroken = Set.singleton (fakePath "lib-out")} + Set.empty + [fakeNode "hello" ["hello-out"] []] + "hello" + in assertEqual "realise" (Left (Realise.SubstitutesFailed (fakePath "hello.drv")), []) (result, realiseWork events), + -- Upstream rethrows a failed narinfo query, which ends the build + -- before any other goal is asked anything. + runTest "a cache that cannot be asked stops the build, and nothing after it is asked" $ + let (result, events, _) = + runRealiseIn + Realise.NoFallback + (fakeWorld [("pkg-lib", [])] []) {fwUnreachable = Set.singleton (fakePath "pkg-bin")} + Set.empty + [fakeNode "pkg" ["pkg-bin", "pkg-lib"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + "pkg" + in assertEqual + "realise" + (Left (Realise.CacheQueryFailed (fakeQueryFailure (fakePath "pkg-bin"))), [EvQueried (fakePath "pkg-bin")]) + (result, events), + runTest "a substitution is retried once after the inputs, and not again" $ + let (_, events, _) = + runRealise Set.empty [fakeNode "hello" ["hello-out"] []] [("hello-out", ["gone-out"])] [] "hello" + in assertEqual "narinfo queries" (2 :: Int) (length [() | EvQueried sp <- events, sp == fakePath "hello-out"]), + runTest "a reference that landed before another failed stays valid" $ + let (result, events, valid) = + runRealise + Set.empty + [fakeNode "hello" ["hello-out"] []] + [("hello-out", ["a-out", "z-out"]), ("a-out", [])] + [] + "hello" + in assertEqual + "realise" + (Right (), [EvFetched [fakePath "a-out"], EvBuilt "hello-out"], True) + (result, realiseWork events, Set.member (fakePath "a-out") valid), + runTestM "a closure lands exactly when all of it is cached, and stays closed" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genClosureCase $ \(references, absent) -> + let paths = Map.keys references + root = maximum (0 : paths) + closure seen node + | Set.member node seen = seen + | otherwise = foldl closure (Set.insert node seen) (Map.findWithDefault [] node references) + path = fakePath . ("p" <>) . T.pack . show + cache = Map.fromList [(path node, map path refs) | (node, refs) <- Map.toList references, node `notElem` absent] + (outcome, final) = + runState (Realise.substituteClosure fakeSubst [path root]) (FakeWorld Set.empty cache Set.empty Set.empty []) + valid = fwValid final + closed = all (\sp -> all (`Set.member` valid) (Map.findWithDefault [] sp cache)) valid + wholeOnCache = all (`notElem` absent) (closure Set.empty root) + in (outcome == Realise.ClosureComplete, closed) QC.=== (wholeOnCache, True) + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))), + runTest "valid outputs need no cache at all" $ + let (result, events, _) = + runRealise Set.empty [fakeNode "hello" ["hello-out"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] [] ["hello-out"] "hello" + in assertEqual "realise" (Right (), [EvReported Realise.AlreadyValid "hello-out"]) (result, events), + runTest "a dependency two others share is realised once" $ + let (result, events, _) = + runRealise + Set.empty + [ fakeNode "top" ["top-out"] ["left", "right"], + fakeNode "left" ["left-out"] ["base"], + fakeNode "right" ["right-out"] ["base"], + fakeNode "base" ["base-out"] [] + ] + [] + [] + "top" + in assertEqual + "realise" + (Right (), [EvBuilt "base-out", EvBuilt "left-out", EvBuilt "right-out", EvBuilt "top-out"]) + (result, realiseWork events), + runTest "a failed input stops the build of what depends on it" $ + let (result, events, _) = + runRealise + (Set.singleton "gcc-out") + [fakeNode "hello" ["hello-out"] ["gcc"], fakeNode "gcc" ["gcc-out"] []] + [] + [] + "hello" + in assertEqual "realise" (Left (Realise.BuildFailed "building gcc-out failed"), []) (result, realiseWork events) + ] + +-- --------------------------------------------------------------------------- +-- Tests: DependencyGraph (Phase 3, Batch 5) +-- --------------------------------------------------------------------------- + +-- | 'DepGraph.buildDepGraph' over a pure .drv lookup. +pureDepGraph :: (StorePath -> Either Text Derivation) -> Derivation -> StorePath -> Either Text DepGraph.DepGraph +pureDepGraph readDrv rootDrv rootPath = runIdentity (DepGraph.buildDepGraph (Identity . readDrv) rootDrv rootPath) + +testDepGraph :: IO [Bool] +testDepGraph = do + putStrLn "dep-graph" + let mkSP = StorePath + spA = mkSP "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "a.drv" + spB = mkSP "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "b.drv" + spC = mkSP "cccccccccccccccccccccccccccccccccc" "c.drv" + spD = mkSP "dddddddddddddddddddddddddddddddd" "d.drv" + baseDrv = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + -- Single node: A has no deps + drvA = baseDrv + -- Linear chain: B depends on C + drvB = baseDrv {drvInputDrvs = Map.singleton spC ["out"]} + -- C has no deps + drvC = baseDrv + -- Diamond: D depends on B and C, B depends on C + drvD = baseDrv {drvInputDrvs = Map.fromList [(spB, ["out"]), (spC, ["out"])]} + -- Cycle: A depends on B, B depends on A + drvACycle = baseDrv {drvInputDrvs = Map.singleton spB ["out"]} + drvBCycle = baseDrv {drvInputDrvs = Map.singleton spA ["out"]} + readSingle _ = Left "not found" + readChain sp + | sp == spC = Right drvC + | otherwise = Left ("unknown drv: " <> spName sp) + readDiamond sp + | sp == spB = Right drvB + | sp == spC = Right drvC + | otherwise = Left ("unknown drv: " <> spName sp) + readCycle sp + | sp == spB = Right drvBCycle + | sp == spA = Right drvACycle + | otherwise = Left ("unknown drv: " <> spName sp) + -- Self-loop: A depends on itself + drvSelf = baseDrv {drvInputDrvs = Map.singleton spA ["out"]} + readSelf sp + | sp == spA = Right drvSelf + | otherwise = Left ("unknown drv: " <> spName sp) + sequence + [ -- Single node + runTest "single node graph" $ case pureDepGraph readSingle drvA spA of + Right (DepGraph.DepGraph g) -> assertEqual "single-size" 1 (Map.size g) + Left err -> Fail ("unexpected error: " <> err), + -- Linear chain A to C: topoSort should give [C, A] + runTest "linear chain topo" $ case pureDepGraph readChain drvB spB of + Right graph -> case DepGraph.topoSort graph of + DepGraph.TopoSorted order -> + case order of + [first, _] | first == spC -> Pass + _ -> Fail ("bad order: " <> T.pack (show order)) + DepGraph.TopoCycle cyc -> Fail ("unexpected cycle: " <> T.pack (show cyc)) + Left err -> Fail ("graph build failed: " <> err), + -- Diamond D to B,C; B to C: topoSort should have C first, D last + runTest "diamond topo" $ case pureDepGraph readDiamond drvD spD of + Right graph -> case DepGraph.topoSort graph of + DepGraph.TopoSorted order -> + case order of + [first, _, lastElem] | first == spC, lastElem == spD -> Pass + _ -> Fail ("bad diamond order: " <> T.pack (show order)) + DepGraph.TopoCycle cyc -> Fail ("unexpected cycle: " <> T.pack (show cyc)) + Left err -> Fail ("graph build failed: " <> err), + -- transitiveDeps + runTest "transitiveDeps diamond" $ case pureDepGraph readDiamond drvD spD of + Right graph -> + let deps = DepGraph.transitiveDeps graph spD + in if Set.size deps == 2 && Set.member spB deps && Set.member spC deps + then Pass + else Fail ("bad transitive deps: " <> T.pack (show deps)) + Left err -> Fail ("graph build failed: " <> err), + -- directDeps + runTest "directDeps diamond" $ case pureDepGraph readDiamond drvD spD of + Right graph -> + let deps = DepGraph.directDeps graph spD + in assertEqual "direct-count" 2 (length deps) + Left err -> Fail ("graph build failed: " <> err), + -- Missing .drv causes failure + runTest "missing drv fails" $ case pureDepGraph readSingle drvB spB of + Left _ -> Pass + Right _ -> Fail "expected failure for missing drv", + -- Single node topoSort + runTest "single node topoSort" $ case pureDepGraph readSingle drvA spA of + Right graph -> case DepGraph.topoSort graph of + DepGraph.TopoSorted [x] -> assertEqual "single-topo" spA x + other -> Fail ("unexpected topo result: " <> T.pack (show other)) + Left err -> Fail ("graph build failed: " <> err), + -- buildDepGraph with mock for cycle detection + -- (Cycle detection happens at topoSort level, not buildDepGraph) + runTest "cycle detection" $ case pureDepGraph readCycle drvACycle spA of + Right graph -> case DepGraph.topoSort graph of + DepGraph.TopoCycle _ -> Pass + -- A "sorted" cyclic graph means Kahn's silently dropped the + -- cycle: buildWithDeps would then loop or build with unbuilt + -- inputs. + DepGraph.TopoSorted order -> + Fail ("cyclic graph topo-sorted as " <> T.pack (show (length order)) <> " nodes") + -- A loud rejection at graph-build time also counts as detection. + Left _ -> Pass, + -- A root that depends on itself: the walk marks the root visited + -- on enqueue, so it terminates - and per contract the result + -- excludes the root, leaving nothing. + runTestM "transitiveDeps terminates on a self-loop" $ do + outcome <- + timeout walkWatchdogMicros $ + evaluate $ case pureDepGraph readSelf drvSelf spA of + Left _ -> Nothing + Right graph -> Just $! DepGraph.transitiveDeps graph spA + pure $ case outcome of + Nothing -> Fail "did not terminate on a self-loop" + Just Nothing -> Fail "graph build failed" + Just (Just deps) -> assertEqual "self-loop deps" Set.empty deps, + -- A two-node cycle already terminated; pin that the root stays + -- excluded from its own transitive closure. + runTestM "transitiveDeps two-node cycle excludes the root" $ do + outcome <- + timeout walkWatchdogMicros $ + evaluate $ case pureDepGraph readCycle drvACycle spA of + Left _ -> Nothing + Right graph -> Just $! DepGraph.transitiveDeps graph spA + pure $ case outcome of + Nothing -> Fail "did not terminate on a cycle" + Just Nothing -> Fail "graph build failed" + Just (Just deps) -> assertEqual "cycle deps" (Set.singleton spB) deps + ] + +-- --------------------------------------------------------------------------- +-- Tests: Substituter (Phase 3, Batch 6) +-- --------------------------------------------------------------------------- + +-- | A fake HTTP body reader: yields the given chunks, then empty +-- forever (an HTTP BodyReader is just an IO ByteString). +chunkReader :: [BS.ByteString] -> IO (IO BS.ByteString) +chunkReader chunks = do + ref <- newIORef chunks + pure $ + atomicModifyIORef' ref $ \case + [] -> ([], BS.empty) + (c : cs) -> (cs, c) + +-- | Drain a chunk source to its byte count - the shape of a streaming +-- consumer, for tests that only care whether the pipeline fails. +drainChunkSource :: IO BS.ByteString -> IO (Either Subst.AttemptFailure Int) +drainChunkSource pull = go 0 + where + go n = do + chunk <- pull + if BS.null chunk + then pure (Right n) + else let total = n + BS.length chunk in total `seq` go total + +testSubstituter :: IO [Bool] +testSubstituter = do + putStrLn "substituter" + -- Every tree this group materializes under the temp directory keys + -- sibling names the way a store on that volume would. + tmpSensitivity <- tempCaseSensitivity + sequence + [ -- sortCaches: priority ordering + runTest "sortCaches priority ordering" $ + let c1 = Subst.CacheConfig "https://a.example.com" ["key-a"] 40 + c2 = Subst.CacheConfig "https://b.example.com" ["key-b"] 10 + c3 = Subst.CacheConfig "https://c.example.com" ["key-c"] 30 + sorted = Subst.sortCaches [c1, c2, c3] + in case sorted of + [s1, s2, s3] -> + if Subst.ccPriority s1 == 10 && Subst.ccPriority s2 == 30 && Subst.ccPriority s3 == 40 + then Pass + else Fail ("bad order: " <> T.pack (show (map Subst.ccPriority sorted))) + _ -> Fail "expected 3 caches", + -- sortCaches: empty list + runTest "sortCaches empty" $ + assertEqual "empty-sort" [] (Subst.sortCaches []), + -- readBodyCapped: the client-side body cap (mirror of the server's + -- readBodyLimited). A body reader is just IO ByteString yielding + -- chunks then empty. + runTestM "readBodyCapped concatenates under the cap" $ do + reader <- chunkReader ["abc", "def", "g"] + body <- Subst.readBodyCapped 10 reader + pure (assertEqual "under cap" (Just "abcdefg") body), + runTestM "readBodyCapped allows exactly the cap" $ do + reader <- chunkReader ["abcde", "fghij"] + body <- Subst.readBodyCapped 10 reader + pure (assertEqual "at cap" (Just "abcdefghij") body), + runTestM "readBodyCapped aborts past the cap" $ do + reader <- chunkReader ["abcdef", "ghijkl"] + body <- Subst.readBodyCapped 10 reader + pure (assertEqual "over cap" Nothing body), + -- decompressorFor decides support from the narinfo's declared + -- values alone, so unsupported compression rejects before any + -- NAR download; xz resolves a bounded decompressor. + runTest "decompressorFor xz resolves" $ + case Subst.decompressorFor 1024 "xz" of + Right _ -> Pass + Left err -> Fail ("xz rejected: " <> err), + runTestM "decompressorFor none is identity" $ + case Subst.decompressorFor 5 "none" of + Right decompress -> assertEqual "identity" (Right "bytes") <$> decompress "bytes" + Left err -> pure (Fail ("expected none to be supported, got: " <> err)), + -- verifyNarSize: the declared NarSize is a signed claim that flows + -- into the store DB, so it must equal the downloaded byte count. + runTest "verifyNarSize accepts matching size" $ + assertEqual + "narsize-match" + (Right ()) + (Subst.verifyNarSize ((sampleNarInfo sampleNarHash) {NarInfo.niNarSize = toInteger (BS.length sampleNarBytes)}) sampleNarBytes), + runTest "verifyNarSize rejects mismatched size" $ + case Subst.verifyNarSize ((sampleNarInfo sampleNarHash) {NarInfo.niNarSize = toInteger (BS.length sampleNarBytes) + 1}) sampleNarBytes of + Left err | "size mismatch" `T.isInfixOf` err -> Pass + other -> Fail ("expected size mismatch, got: " <> T.pack (show other)), + -- decompressNar: "none" passes through + runTestM "decompressNar none" $ + let input = "fake nar data" + in assertEqual "decompress-none" (Right input) <$> Subst.decompressNar (toInteger (BS.length input)) "none" input, + -- decompressNar: an empty Compression field means bzip2 upstream + -- (the field's historical default), never identity, so the empty + -- spelling must decode a real bzip2 body exactly as the named + -- one does. + runTestM "decompressNar empty means bzip2" $ + case B64.decode bzip2FixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + out <- Subst.decompressNar xzFixtureSize "" compressed + pure $ case out of + Right decoded -> assertEqual "empty-is-bzip2" xzFixturePayload decoded + Left err -> Fail ("empty Compression failed to decode as bzip2: " <> err), + -- decompressNar: bzip2 decodes under the same declared-NarSize + -- bound as the other codecs; the fixture comes from the bzip2 + -- CLI, so the decoder is checked against the format's own + -- reference encoder rather than its own library. + runTestM "decompressNar bzip2 bounded roundtrip" $ + case B64.decode bzip2FixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + out <- Subst.decompressNar xzFixtureSize "bzip2" compressed + pure $ case out of + Right decoded -> assertEqual "bzip2-roundtrip" xzFixturePayload decoded + Left err -> Fail ("bzip2 roundtrip failed: " <> err), + runTestM "decompressNar bzip2 over-bound rejects" $ + case B64.decode bzip2FixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + out <- Subst.decompressNar (xzFixtureSize - 1) "bzip2" compressed + pure $ case out of + Left err | "NarSize" `T.isInfixOf` err -> Pass + other -> Fail ("expected over-bound rejection, got: " <> T.pack (show other)), + -- decompressNar: xz decodes under the declared-NarSize bound + -- (the fixture is a real 112-byte xz stream of 1792 payload + -- bytes, embedded base64 to keep the source ASCII). + runTestM "decompressNar xz bounded roundtrip" $ + case B64.decode xzFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + out <- Subst.decompressNar xzFixtureSize "xz" compressed + pure $ case out of + Right decoded -> assertEqual "xz-roundtrip" xzFixturePayload decoded + Left err -> Fail ("xz roundtrip failed: " <> err), + -- The output bound is exact: one byte under the real size must + -- refuse, naming the declared NarSize. + runTestM "decompressNar xz over-bound rejects" $ + case B64.decode xzFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + out <- Subst.decompressNar (xzFixtureSize - 1) "xz" compressed + pure $ case out of + Left err | "NarSize" `T.isInfixOf` err -> Pass + other -> Fail ("expected over-bound rejection, got: " <> T.pack (show other)), + -- decompressNar: bytes that are not an xz stream are an error, + -- never silently passed through + runTestM "decompressNar xz garbage rejects" $ do + out <- Subst.decompressNar 64 "xz" "not an xz stream" + pure $ case out of + Left _ -> Pass + Right _ -> Fail "garbage decoded as xz", + -- decompressNar: zstd decodes under the same declared-NarSize + -- bound; the fixture compresses with the sublibrary's own + -- encoder, the same pairing the push path ships. + runTestM "decompressNar zstd bounded roundtrip" $ do + out <- Subst.decompressNar xzFixtureSize "zstd" zstdFixtureCompressed + pure $ case out of + Right decoded -> assertEqual "zstd-roundtrip" xzFixturePayload decoded + Left err -> Fail ("zstd roundtrip failed: " <> err), + runTestM "decompressNar zstd over-bound rejects" $ do + out <- Subst.decompressNar (xzFixtureSize - 1) "zstd" zstdFixtureCompressed + pure $ case out of + Left err | "NarSize" `T.isInfixOf` err -> Pass + other -> Fail ("expected over-bound rejection, got: " <> T.pack (show other)), + -- decompressNar: unknown compression + runTestM "decompressNar unknown" $ do + out <- Subst.decompressNar 4 "brotli" "data" + pure $ case out of + Left _ -> Pass + Right _ -> Fail "expected error for unknown", + -- parseReferences: narinfo references are wire-format basenames + runTest "parseReferences basenames" $ + let refs = ["aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello", "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-dep-2.0"] + expected = + [ StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello", + StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "dep-2.0" + ] + in assertEqual "parse-refs" (Right expected) (Subst.parseReferences refs), + -- parseReferences: a malformed token is a loud error, never dropped + runTest "parseReferences malformed rejected" $ + case Subst.parseReferences ["not-a-store-path"] of + Left _ -> Pass + Right refs -> Fail ("expected rejection, got: " <> T.pack (show refs)), + -- parseDeriver: basename becomes the DB's full path text + runTest "parseDeriver basename" $ + let sp = StorePath "cccccccccccccccccccccccccccccccc" "hello.drv" + expected = Just (T.pack (storePathToFilePath defaultStoreDir sp)) + in assertEqual "parse-deriver" (Right expected) (Subst.parseDeriver defaultStoreDir (Just "cccccccccccccccccccccccccccccccc-hello.drv")), + -- parseDeriver: upstream's unknown-deriver sentinel means no deriver + runTest "parseDeriver unknown sentinel" $ + assertEqual "parse-deriver-unknown" (Right Nothing) (Subst.parseDeriver defaultStoreDir (Just "unknown-deriver")), + -- parseDeriver: absent stays absent, malformed is an error + runTest "parseDeriver absent and malformed" $ + case (Subst.parseDeriver defaultStoreDir Nothing, Subst.parseDeriver defaultStoreDir (Just "bogus")) of + (Right Nothing, Left _) -> Pass + other -> Fail ("unexpected: " <> T.pack (show other)), + -- Recorded production narinfos from cache.nixos.org (paths this + -- codebase did not produce): the parse -> validate -> signature + -- pipeline against real cache data, the production ed25519 + -- signature verified offline with the shipped public key. + runTest "recorded cache.nixos.org narinfo verifies end to end" $ + case NarInfo.parseNarInfo recordedHelloNarInfo of + Left err -> Fail ("parse failed: " <> T.pack err) + Right ni -> + case Subst.validateNarInfoFields ni >> Subst.verifySigs Subst.defaultCacheConfig ni of + Left err -> Fail ("validate/verify failed: " <> err) + Right () -> assertEqual "compression" "xz" (NarInfo.niCompression ni), + -- References of a path built by Hydra, including the self + -- reference, and its Deriver - both produced by upstream Nix. + runTest "recorded narinfo references and deriver parse" $ + case NarInfo.parseNarInfo recordedHelloNarInfo of + Left err -> Fail ("parse failed: " <> T.pack err) + Right ni -> + case (Subst.parseReferences (NarInfo.niReferences ni), Subst.parseDeriver defaultStoreDir (NarInfo.niDeriver ni)) of + (Right refs, Right (Just _)) -> + assertEqual + "reference hashes" + ["dska0s3gxxd8azbsn85pwm6xcqhivldw", "jppkr0h8aap5z7m4xy4vg5yrwlly9h2v"] + (map spHash refs) + other -> Fail ("references/deriver did not parse: " <> T.pack (show other)), + -- The empty References line ("References: " with a trailing + -- space) production caches emit for leaf paths. + runTest "recorded no-reference narinfo verifies" $ + case NarInfo.parseNarInfo recordedHelloDocNarInfo of + Left err -> Fail ("parse failed: " <> T.pack err) + Right ni -> + case Subst.validateNarInfoFields ni >> Subst.verifySigs Subst.defaultCacheConfig ni >> Subst.parseReferences (NarInfo.niReferences ni) of + Right [] -> Pass + other -> Fail ("expected verified empty references, got: " <> T.pack (show other)), + -- The fingerprint covers NarSize: altering the signed claim must + -- break the production signature. + runTest "tampered recorded narinfo fails signature" $ + case NarInfo.parseNarInfo recordedHelloNarInfo of + Left err -> Fail ("parse failed: " <> T.pack err) + Right ni -> + case Subst.verifySigs Subst.defaultCacheConfig (ni {NarInfo.niNarSize = NarInfo.niNarSize ni + 1}) of + Left _ -> Pass + Right () -> Fail "signature verified over an altered NarSize", + -- Streaming pipeline: the chunk-fed download materializes, + -- hashes, and verifies without ever holding the NAR. The tree + -- carries the interesting shapes: nesting, an executable, a + -- symlink, and a sibling pair colliding on folding filesystems - + -- the digest equality proves the materialized tree re-serialises + -- to its NAR on every platform strategy. + -- Every length word, tag, and padding run must survive splitting + -- across Await boundaries, so the whole materialization runs at + -- several chunk sizes including single-byte feeds. + runTestM "streaming unpack materializes and verifies across chunk sizes" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-stream-unpack" + chunkSizes = [1, 7, 8, 11] :: [Int] + runAt n = do + let dest = tmpDir ("out-" <> show n) + source <- chunkReader (streamChunks n streamTestNar) + result <- Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo streamTestNar) streamTestDigest source + onDisk <- ExecBit.serialiseFromPath (volumeCaseHack tmpSensitivity) dest + pure $ case result of + Left err -> + Just ("chunk size " <> T.pack (show n) <> ": " <> Subst.attemptFailureMessage err) + Right narByteCount + | narByteCount == BS.length streamTestNar + && CHash.hashBytes (NAR.serialise onDisk) == streamTestDigest -> + Nothing + | otherwise -> + Just ("chunk size " <> T.pack (show n) <> ": streamed tree diverges from its NAR") + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + outcomes <- mapM runAt chunkSizes + forceRemoveIfExists tmpDir + pure $ case catMaybes outcomes of + [] -> Pass + (msg : _) -> Fail msg, + -- A truncated stream is a loud parse failure, never a short + -- tree - and it retries: truncation and a torn transfer + -- parse-fail the same way. + runTestM "streaming unpack refuses a truncated stream as transient" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-stream-trunc" + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + source <- chunkReader (streamChunks 7 (BS.take (BS.length streamTestNar - 10) streamTestNar)) + result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") (streamTestNarInfo streamTestNar) streamTestDigest source + forceRemoveIfExists tmpDir + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + Left (Subst.FatalFailure err) -> Fail ("truncation classified fatal: " <> err) + Right _ -> Fail "truncated NAR stream was accepted", + -- A digest mismatch reports before the tree is trusted, and it + -- is fatal: the size matched, so the transfer completed. + runTestM "streaming unpack refuses a digest mismatch as fatal" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-stream-digest" + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + source <- chunkReader (streamChunks 7 streamTestNar) + result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") (streamTestNarInfo streamTestNar) (CHash.hashBytes "not the nar") source + forceRemoveIfExists tmpDir + pure $ case result of + Left (Subst.FatalFailure err) | "hash mismatch" `T.isInfixOf` err -> Pass + Left other -> Fail ("expected fatal hash mismatch, got: " <> Subst.attemptFailureMessage other) + Right _ -> Fail "digest mismatch was accepted", + -- A narinfo lying about NarSize in either direction is refused + -- at NarDone - the grammar completed, so the mismatch is the + -- narinfo misdeclaring, and fatal. + runTestM "streaming unpack refuses an overdeclared NarSize" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-stream-oversize" + lying = (streamTestNarInfo streamTestNar) {NarInfo.niNarSize = toInteger (BS.length streamTestNar) + 1} + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + source <- chunkReader (streamChunks 7 streamTestNar) + result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") lying streamTestDigest source + forceRemoveIfExists tmpDir + pure $ case result of + Left (Subst.FatalFailure err) | "size mismatch" `T.isInfixOf` err -> Pass + Left other -> Fail ("expected fatal size mismatch, got: " <> Subst.attemptFailureMessage other) + Right _ -> Fail "overdeclared NarSize was accepted", + runTestM "streaming unpack refuses an underdeclared NarSize" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-stream-undersize" + lying = (streamTestNarInfo streamTestNar) {NarInfo.niNarSize = toInteger (BS.length streamTestNar) - 1} + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + source <- chunkReader (streamChunks 7 streamTestNar) + result <- Subst.consumeNarStream tmpSensitivity (tmpDir "out") lying streamTestDigest source + forceRemoveIfExists tmpDir + pure $ case result of + Left (Subst.FatalFailure err) | "size mismatch" `T.isInfixOf` err -> Pass + Left other -> Fail ("expected fatal size mismatch, got: " <> Subst.attemptFailureMessage other) + Right _ -> Fail "underdeclared NarSize was accepted", + -- cappedBodySource: the streaming mirror of readBodyCapped - + -- a body past the key-trusted declared size aborts mid-stream. + runTestM "cappedBodySource aborts past the cap" $ do + reader <- chunkReader ["abcdef", "ghijkl"] + source <- Subst.cappedBodySource 10 reader + firstChunk <- source + overCap <- try source :: IO (Either SomeException BS.ByteString) + pure $ case (firstChunk, overCap) of + ("abcdef", Left _) -> Pass + other -> Fail ("expected abort past the cap, got: " <> T.pack (show other)), + -- withDecompressedSource: xz chunks decompress under the + -- declared bound; the support decision mirrors decompressorFor. + runTestM "withDecompressedSource xz chunked roundtrip" $ + case B64.decode xzFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 7 compressed) + result <- Subst.withDecompressedSource xzFixtureSize "xz" source $ \pull -> + let go acc = do + chunk <- pull + if BS.null chunk + then pure (Right (BS.concat (reverse acc))) + else go (chunk : acc) + in go [] + pure $ case result of + Right out | out == xzFixturePayload -> Pass + other -> Fail ("xz source roundtrip diverged: " <> T.pack (show (fmap BS.length other))), + runTestM "withDecompressedSource zstd chunked roundtrip" $ do + source <- chunkReader (streamChunks 7 zstdFixtureCompressed) + result <- Subst.withDecompressedSource xzFixtureSize "zstd" source $ \pull -> + let go acc = do + chunk <- pull + if BS.null chunk + then pure (Right (BS.concat (reverse acc))) + else go (chunk : acc) + in go [] + pure $ case result of + Right out | out == xzFixturePayload -> Pass + other -> Fail ("zstd source roundtrip diverged: " <> T.pack (show (fmap BS.length other))), + runTestM "withDecompressedSource xz single-byte chunks" $ + case B64.decode xzFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 1 compressed) + result <- Subst.withDecompressedSource xzFixtureSize "xz" source $ \pull -> + let go acc = do + chunk <- pull + if BS.null chunk + then pure (Right (BS.concat (reverse acc))) + else go (chunk : acc) + in go [] + pure $ case result of + Right out | out == xzFixturePayload -> Pass + other -> Fail ("xz 1-byte roundtrip diverged: " <> T.pack (show (fmap BS.length other))), + -- The LIVE pipeline's defenses, not the strict oracle's: hostile + -- compressed input through withDecompressedSource must land in + -- the Left channel with the right retry class, never escape as + -- an exception. + runTestM "withDecompressedSource xz over-bound is fatal" $ + case B64.decode xzFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 7 compressed) + result <- Subst.withDecompressedSource (xzFixtureSize - 1) "xz" source drainChunkSource + pure $ case result of + Left (Subst.FatalFailure err) | "NarSize" `T.isInfixOf` err -> Pass + other -> Fail ("expected fatal over-bound, got: " <> T.pack (show (void other))), + runTestM "withDecompressedSource xz garbage is transient" $ do + source <- chunkReader ["not an xz stream"] + result <- Subst.withDecompressedSource 64 "xz" source drainChunkSource + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected transient stream error, got: " <> T.pack (show (void other))), + runTestM "withDecompressedSource xz truncated is transient" $ + case B64.decode xzFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 7 (BS.take 40 compressed)) + result <- Subst.withDecompressedSource xzFixtureSize "xz" source drainChunkSource + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected transient truncation, got: " <> T.pack (show (void other))), + -- The failure contract of the post-download pipeline: every + -- failing materialization removes the tree it wrote, and a + -- clean one registers the verified metadata. + runTestM "materialize registers a verified tree" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-materialize-ok" + forceRemoveIfExists tmpStore + createDirectoryIfMissing True tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath sampleHash "stream" + destPath = storePathToFilePath (StoreDir tmpStore) sp + source <- chunkReader (streamChunks 7 streamTestNar) + result <- Subst.materializeNarFromSource store sp (streamTestNarInfo streamTestNar) streamTestDigest [] Nothing source + survived <- doesDirectoryExist destPath + closeStore store + forceRemoveIfExists tmpStore + pure $ case result of + Left err -> Fail ("materialize failed: " <> Subst.attemptFailureMessage err) + Right reg + | not survived -> Fail "verified tree missing after materialize" + | prNarSize reg /= BS.length streamTestNar -> Fail "registration NarSize diverges" + | prNarHash reg /= CHash.formatNixHash streamTestDigest -> Fail "registration NarHash diverges" + | otherwise -> Pass, + runTestM "materialize removes the tree on a digest mismatch" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-materialize-digest" + forceRemoveIfExists tmpStore + createDirectoryIfMissing True tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath sampleHash "stream" + destPath = storePathToFilePath (StoreDir tmpStore) sp + source <- chunkReader (streamChunks 7 streamTestNar) + result <- Subst.materializeNarFromSource store sp (streamTestNarInfo streamTestNar) (CHash.hashBytes "not the nar") [] Nothing source + survived <- doesDirectoryExist destPath + closeStore store + forceRemoveIfExists tmpStore + pure $ case result of + Right _ -> Fail "digest mismatch was accepted" + Left (Subst.TransientFailure err) -> Fail ("mismatch classified transient: " <> err) + Left (Subst.FatalFailure err) + | not ("hash mismatch" `T.isInfixOf` err) -> Fail ("unexpected failure: " <> err) + | survived -> Fail "tree survived a digest mismatch" + | otherwise -> Pass, + runTestM "materialize removes the tree on a truncated stream" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-materialize-trunc" + forceRemoveIfExists tmpStore + createDirectoryIfMissing True tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath sampleHash "stream" + destPath = storePathToFilePath (StoreDir tmpStore) sp + source <- chunkReader (streamChunks 7 (BS.take (BS.length streamTestNar - 10) streamTestNar)) + result <- Subst.materializeNarFromSource store sp (streamTestNarInfo streamTestNar) streamTestDigest [] Nothing source + survived <- doesDirectoryExist destPath + closeStore store + forceRemoveIfExists tmpStore + pure $ case result of + Right _ -> Fail "truncated stream was accepted" + Left (Subst.FatalFailure err) -> Fail ("truncation classified fatal: " <> err) + Left (Subst.TransientFailure _) + | survived -> Fail "tree survived a truncated stream" + | otherwise -> Pass, + -- The download cap derives from the SIGNED NarSize; the unsigned + -- FileSize may only lower it, never raise it. + runTest "downloadCapFor lets FileSize lower but never raise the cap" $ + let base = streamTestNarInfo streamTestNar + narSize = NarInfo.niNarSize base + ceilingCap = Subst.compressedBodyCeiling narSize + absent = Subst.downloadCapFor base {NarInfo.niFileSize = Nothing} + lowered = Subst.downloadCapFor base {NarInfo.niFileSize = Just 100} + inflated = Subst.downloadCapFor base {NarInfo.niFileSize = Just (ceilingCap * 1000)} + in case (absent, lowered, inflated) of + (Right capAbsent, Right capLowered, Right capInflated) + | toInteger capAbsent == ceilingCap + && capLowered == 100 + && toInteger capInflated == ceilingCap -> + Pass + other -> Fail ("unexpected caps: " <> T.pack (show other)), + runTest "compressedBodyCeiling floors small and scales large" $ + let smallCeiling = Subst.compressedBodyCeiling 10 + largeSize = 64 * 1024 * 1024 + largeCeiling = Subst.compressedBodyCeiling largeSize + in if smallCeiling == 10 + 64 * 1024 && largeCeiling == largeSize + largeSize `div` 64 + then Pass + else Fail ("unexpected ceilings: " <> T.pack (show (smallCeiling, largeCeiling))), + -- The zstd mirror of the xz hostile trio: over-bound output is + -- deterministic, while a corrupt frame and a frame cut off + -- mid-way both retry - the codec judges end of input by + -- libzstd's own frame-boundary signal, so truncation refuses + -- here instead of yielding a short output. + runTestM "withDecompressedSource zstd over-bound is fatal" $ do + source <- chunkReader (streamChunks 7 zstdFixtureCompressed) + result <- Subst.withDecompressedSource (xzFixtureSize - 1) "zstd" source drainChunkSource + pure $ case result of + Left (Subst.FatalFailure err) | "NarSize" `T.isInfixOf` err -> Pass + other -> Fail ("expected fatal over-bound, got: " <> T.pack (show (void other))), + runTestM "withDecompressedSource zstd garbage is transient" $ do + source <- chunkReader ["not a zstd frame"] + result <- Subst.withDecompressedSource 64 "zstd" source drainChunkSource + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected transient stream error, got: " <> T.pack (show (void other))), + runTestM "withDecompressedSource zstd truncated is transient" $ do + source <- chunkReader (streamChunks 7 (BS.take (BS.length zstdFixtureCompressed - 8) zstdFixtureCompressed)) + result <- Subst.withDecompressedSource xzFixtureSize "zstd" source drainChunkSource + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected transient truncation, got: " <> T.pack (show (void other))), + -- The codec refuses a truncated frame, and the whole pipeline + -- must carry that refusal into the Left channel as retryable + -- rather than let a short NAR reach the store. + runTestM "zstd truncated body fails the pipeline as transient" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-zstd-trunc" + compressedNar = CZstd.compress CZstd.defaultCompressionLevel streamTestNar + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + source <- chunkReader (streamChunks 7 (BS.take (BS.length compressedNar - 8) compressedNar)) + result <- + Subst.withDecompressedSource (toInteger (BS.length streamTestNar)) "zstd" source $ + Subst.consumeNarStream tmpSensitivity (tmpDir "out") ((streamTestNarInfo streamTestNar) {NarInfo.niCompression = "zstd"}) streamTestDigest + forceRemoveIfExists tmpDir + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + Left (Subst.FatalFailure err) -> Fail ("zstd truncation classified fatal: " <> err) + Right _ -> Fail "truncated zstd body was accepted", + -- The bzip2 mirror of the xz hostile trio, over a fixture the + -- bzip2 CLI produced: over-bound output is deterministic, while + -- garbage and a truncated stream retry. + runTestM "withDecompressedSource bzip2 chunked roundtrip" $ + case B64.decode bzip2FixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 7 compressed) + result <- Subst.withDecompressedSource xzFixtureSize "bzip2" source $ \pull -> + let go acc = do + chunk <- pull + if BS.null chunk + then pure (Right (BS.concat (reverse acc))) + else go (chunk : acc) + in go [] + pure $ case result of + Right out | out == xzFixturePayload -> Pass + other -> Fail ("bzip2 source roundtrip diverged: " <> T.pack (show (fmap BS.length other))), + runTestM "withDecompressedSource bzip2 over-bound is fatal" $ + case B64.decode bzip2FixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 7 compressed) + result <- Subst.withDecompressedSource (xzFixtureSize - 1) "bzip2" source drainChunkSource + pure $ case result of + Left (Subst.FatalFailure err) | "NarSize" `T.isInfixOf` err -> Pass + other -> Fail ("expected fatal over-bound, got: " <> T.pack (show (void other))), + runTestM "withDecompressedSource bzip2 garbage is transient" $ do + source <- chunkReader ["not a bzip2 stream"] + result <- Subst.withDecompressedSource 64 "bzip2" source drainChunkSource + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected transient stream error, got: " <> T.pack (show (void other))), + runTestM "withDecompressedSource bzip2 truncated is transient" $ + case B64.decode bzip2FixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + source <- chunkReader (streamChunks 7 (BS.take (BS.length compressed - 8) compressed)) + result <- Subst.withDecompressedSource xzFixtureSize "bzip2" source drainChunkSource + pure $ case result of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected transient truncation, got: " <> T.pack (show (void other))), + -- A bzip2-compressed NAR through the whole post-download + -- pipeline: the format the historical caches serve decompresses, + -- hashes, parses, and materializes in one bounded pass. + runTestM "bzip2 NAR streams through the pipeline" $ + case B64.decode bzip2NarFixtureB64 of + Left err -> pure (Fail ("fixture base64 does not decode: " <> T.pack err)) + Right compressed -> do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-bzip2-pipeline" + destPath = tmpDir "out" + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + source <- chunkReader (streamChunks 7 compressed) + result <- + Subst.withDecompressedSource (toInteger (BS.length bzip2NarFixture)) "bzip2" source $ + Subst.consumeNarStream + tmpSensitivity + destPath + ((streamTestNarInfo bzip2NarFixture) {NarInfo.niCompression = "bzip2"}) + (CHash.hashBytes bzip2NarFixture) + materialized <- Dir.doesFileExist (destPath "greeting") + forceRemoveIfExists tmpDir + pure $ case result of + Left err -> Fail ("bzip2 pipeline failed: " <> Subst.attemptFailureMessage err) + Right narBytes + | narBytes /= BS.length bzip2NarFixture -> Fail "bzip2 pipeline counted the wrong NAR size" + | not materialized -> Fail "bzip2 pipeline left no tree at the destination" + | otherwise -> Pass, + runTest "streaming compression support matches the strict set" $ + case (Subst.streamingDecompressionSupported "xz", Subst.streamingDecompressionSupported "zstd", Subst.streamingDecompressionSupported "bzip2", Subst.streamingDecompressionSupported "brotli") of + (Right (), Right (), Right (), Left _) -> Pass + other -> Fail ("unexpected support set: " <> T.pack (show other)), + -- The support set is encoded twice - the strict decompressor and + -- the streaming decision - so their agreement is pinned across + -- the codecs either could plausibly grow, not left to comments. + runTest "strict and streaming support sets agree" $ + let agrees compression = + case (Subst.decompressorFor 1 compression, Subst.streamingDecompressionSupported compression) of + (Right _, Right ()) -> True + (Left _, Left _) -> True + _ -> False + in if all agrees ["none", "", "xz", "zstd", "bzip2", "brotli"] + then Pass + else Fail "strict and streaming compression support drifted", + -- The strict path is the streaming path's differential oracle: + -- the same NAR materialized by both must produce the same tree. + runTestM "strict and streaming unpack agree" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-stream-oracle" + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + strictOutcome <- case NAR.deserialise streamTestNar of + Left err -> pure (Left (T.pack err)) + Right entry -> unpackNarEntry tmpSensitivity (tmpDir "strict") entry + source <- chunkReader (streamChunks 11 streamTestNar) + streamOutcome <- Subst.consumeNarStream tmpSensitivity (tmpDir "streamed") (streamTestNarInfo streamTestNar) streamTestDigest source + strictTree <- NAR.serialiseFromPath (tmpDir "strict") + streamedTree <- NAR.serialiseFromPath (tmpDir "streamed") + forceRemoveIfExists tmpDir + pure $ case (strictOutcome, streamOutcome) of + (Right (), Right _) + | NAR.serialise strictTree == NAR.serialise streamedTree -> Pass + | otherwise -> Fail "strict and streaming trees diverge" + other -> Fail ("oracle setup failed: " <> T.pack (show other)), + -- trySubstitute: empty caches returns SubstNotFound + runTestM "trySubstitute no caches" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-subst" + createDirectoryIfMissing True tmpStore + store <- openStore (StoreDir tmpStore) + result <- Subst.trySubstitute store [] (StorePath "test" "hello") + closeStore store + removeDirectoryRecursive tmpStore + pure (assertEqual "no-caches" Subst.SubstNotFound result), + -- defaultCacheConfig has correct URL + runTest "defaultCacheConfig url" $ + assertEqual "default-url" "https://cache.nixos.org" (Subst.ccUrl Subst.defaultCacheConfig), + -- defaultCacheConfig has priority 40 + runTest "defaultCacheConfig priority" $ + assertEqual "default-prio" 40 (Subst.ccPriority Subst.defaultCacheConfig), + -- verifyNarHash: matching NAR hash accepted (HIGH#2 integrity gate); + -- the returned digest is the declared hash, decoded. + runTest "verifyNarHash accepts matching hash" $ + case Subst.verifyNarHash (sampleNarInfo sampleNarHash) sampleNarBytes of + Right declared + | CHash.formatNixHash declared == sampleNarHash -> Pass + | otherwise -> Fail "returned digest does not match the declared hash" + Left err -> Fail ("expected acceptance, got: " <> err), + -- verifyNarHash: mismatched NAR hash rejected + runTest "verifyNarHash rejects mismatched hash" $ + case Subst.verifyNarHash (sampleNarInfo wrongNarHash) sampleNarBytes of + Left _ -> Pass + Right _ -> Fail "expected mismatch rejection", + -- verifyNarHash: malformed NAR hash rejected + runTest "verifyNarHash rejects malformed hash" $ + case Subst.verifyNarHash (sampleNarInfo "not-a-hash") sampleNarBytes of + Left _ -> Pass + Right _ -> Fail "expected malformed-hash rejection", + -- verifyNar: the only constructor of VerifiedNar carries the bytes + -- unchanged and the declared digest decoded, so the unpack sink + -- and the registration read both from the witness. + runTest "verifyNar carries the bytes and the declared digest" $ + case Subst.verifyNar (sampleNarInfo sampleNarHash) sampleNarBytes of + Right verified + | Subst.verifiedNarBytes verified /= sampleNarBytes -> Fail "verified bytes differ from the input" + | CHash.formatNixHash (Subst.verifiedNarDigest verified) /= sampleNarHash -> Fail "carried digest is not the declared hash" + | otherwise -> Pass + Left err -> Fail ("expected acceptance, got: " <> err), + -- verifyNar: either signed claim failing yields no witness at all. + runTest "verifyNar rejects a hash or size mismatch" $ + let wrongHash = Subst.verifyNar (sampleNarInfo wrongNarHash) sampleNarBytes + wrongSize = Subst.verifyNar ((sampleNarInfo sampleNarHash) {NarInfo.niNarSize = toInteger (BS.length sampleNarBytes) + 1}) sampleNarBytes + in case (wrongHash, wrongSize) of + (Left _, Left _) -> Pass + other -> Fail ("expected both rejections, got: " <> T.pack (show other)), + -- narInfoMatchesPath: identity match accepted + runTest "narInfoMatchesPath accepts matching identity" $ + if Subst.narInfoMatchesPath (StorePath sampleHash "hello") (sampleNarInfo sampleNarHash) + then Pass + else Fail "expected identity match", + -- narInfoMatchesPath: identity mismatch rejected + runTest "narInfoMatchesPath rejects mismatched identity" $ + if Subst.narInfoMatchesPath (StorePath (T.replicate 32 "b") "hello") (sampleNarInfo sampleNarHash) + then Fail "expected identity mismatch" + else Pass, + -- tryCachesWith: the first success stops the scan (later caches + -- are never contacted) + runTestM "tryCachesWith success stops scan" $ do + calls <- newIORef (0 :: Int) + withChainLock "nova-nix-test-chain-stop" $ \lock -> do + let hit = PathRegistration (StorePath (T.replicate 32 "d") "hit") "sha256:d" 1 Nothing [] + attempt cache = do + atomicModifyIORef' calls (\n -> (n + 1, ())) + pure $ + if Subst.ccUrl cache == "https://b" + then Subst.SubstSuccess hit lock + else Subst.SubstNotFound + result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b", chainCache "https://c"] + made <- readIORef calls + pure $ + if result == Subst.SubstSuccess hit lock && made == 2 + then Pass + else Fail ("got " <> T.pack (show result) <> " after " <> T.pack (show made) <> " attempts"), + -- tryCachesWith: an already-valid path found mid-scan is terminal + -- like a success - later caches are never contacted + runTestM "tryCachesWith already-valid stops scan" $ do + calls <- newIORef (0 :: Int) + let attempt _ = do + atomicModifyIORef' calls (\n -> (n + 1, ())) + pure Subst.SubstAlreadyValid + result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"] + made <- readIORef calls + pure $ + if result == Subst.SubstAlreadyValid && made == 1 + then Pass + else Fail ("got " <> T.pack (show result) <> " after " <> T.pack (show made) <> " attempts"), + -- tryCachesWith: an erroring cache falls through to a later hit + -- instead of aborting the chain + runTestM "tryCachesWith error falls through to next cache" $ + withChainLock "nova-nix-test-chain-fallthrough" $ \lock -> do + let hit = PathRegistration (StorePath (T.replicate 32 "f") "hit") "sha256:f" 1 Nothing [] + attempt cache + | Subst.ccUrl cache == "https://a" = pure (Subst.SubstError "transient 500") + | otherwise = pure (Subst.SubstSuccess hit lock) + result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"] + pure (assertEqual "fallthrough" (Subst.SubstSuccess hit lock) result), + -- tryCachesWith: all misses stay SubstNotFound + runTestM "tryCachesWith all misses" $ do + result <- Subst.tryCachesWith (\_ -> pure Subst.SubstNotFound) [chainCache "https://a", chainCache "https://b"] + pure (assertEqual "misses" Subst.SubstNotFound result), + -- tryCachesWith: with no hit anywhere, the FIRST error is reported, + -- tagged with the URL of the cache that produced it + runTestM "tryCachesWith reports first error tagged with cache" $ do + let attempt cache + | Subst.ccUrl cache == "https://a" = pure Subst.SubstNotFound + | Subst.ccUrl cache == "https://b" = pure (Subst.SubstError "first") + | otherwise = pure (Subst.SubstError "second") + result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b", chainCache "https://c"] + pure $ case result of + Subst.SubstError err + | "https://b" `T.isPrefixOf` err && "first" `T.isSuffixOf` err -> Pass + other -> Fail ("expected tagged first error, got " <> T.pack (show other)), + -- catchSync (the split every attempt wraps itself in): a + -- synchronous exception folds into SubstError and the scan falls + -- through to the next cache + runTestM "catchSync folds sync exception into SubstError" $ do + let attempt cache = + Subst.catchSync + ( if Subst.ccUrl cache == "https://a" + then throwIO (ErrorCall "disk full") + else pure Subst.SubstNotFound + ) + (pure . Subst.SubstError . T.pack . show) + result <- Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"] + pure $ case result of + Subst.SubstError err + | "disk full" `T.isInfixOf` err -> Pass + other -> Fail ("expected SubstError from sync exception, got " <> T.pack (show other)), + -- catchSync: an asynchronous exception thrown mid-attempt + -- propagates out of the cache scan instead of folding into + -- SubstError - cancellation must abort substitution, never be + -- spent as fallthrough to the next cache or to a local build + runTestM "catchSync propagates async exception out of the scan" $ do + scanned <- newIORef (0 :: Int) + let attempt _ = + Subst.catchSync + ( do + atomicModifyIORef' scanned (\n -> (n + 1, ())) + throwIO (asyncExceptionToException (ErrorCall "cancelled")) + ) + (pure . Subst.SubstError . T.pack . show) + outcome <- try (Subst.tryCachesWith attempt [chainCache "https://a", chainCache "https://b"]) + made <- readIORef scanned + pure $ case (outcome :: Either SomeException Subst.SubstResult) of + Left escaped -> case fromException escaped of + Just (SomeAsyncException _) + | made == 1 -> Pass + | otherwise -> Fail ("scan continued past the interrupt: " <> T.pack (show made) <> " attempts") + Nothing -> Fail ("wrong exception escaped: " <> T.pack (show escaped)) + Right result -> Fail ("async exception folded into " <> T.pack (show result)), + -- clearStaleDestination: removes a read-only leftover tree (the + -- crash-between-unpack-and-register wedge) + runTestM "clearStaleDestination removes read-only leftovers" $ do + tmpBase <- getTemporaryDirectory + let staleRoot = tmpBase "nova-nix-test-stale-dest" + staleFile = staleRoot "bin" "tool" + createDirectoryIfMissing True (staleRoot "bin") + writeFile staleFile "leftover" + perms <- getPermissions staleFile + Dir.setPermissions staleFile (Dir.setOwnerWritable False perms) + Subst.clearStaleDestination staleRoot + gone <- Dir.doesPathExist staleRoot + pure (if gone then Fail "stale tree survived" else Pass), + -- clearStaleDestination: a missing destination is a no-op + runTestM "clearStaleDestination missing path no-op" $ do + tmpBase <- getTemporaryDirectory + outcome <- try (Subst.clearStaleDestination (tmpBase "nova-nix-test-no-such-dir")) + pure $ case (outcome :: Either SomeException ()) of + Right () -> Pass + Left e -> Fail ("threw: " <> T.pack (show e)), + -- unpackNarEntry: what the archive grammar refuses (traversal + -- shapes, a NUL) is refused on every host before anything is + -- written + runTestM "unpackNarEntry rejects unsafe entry names" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-unsafe" + evil name = NAR.NarDirectory [(name, NAR.NarRegular False "x")] + -- Cleared before each: the root is created exclusively, so + -- a leftover from the previous name would refuse for a + -- different reason than the one under test. + unpackFresh name = do + Subst.clearStaleDestination dest + unpackNarEntry tmpSensitivity dest (evil name) + results <- mapM unpackFresh ["..", ".", "", "a/b", "a\NULb"] + Subst.clearStaleDestination dest + pure $ + if all (\case Left err -> "NAR directory entry name" `T.isInfixOf` err; Right () -> False) results + then Pass + else Fail ("accepted an unsafe name: " <> T.pack (show results)), + -- Names upstream's restore writes on POSIX as it finds them + -- (posixOnlyTree, compared against nix-store --restore 2.33.2) + -- materialize byte for byte through both unpack paths there, and + -- the tree re-serialises to the NAR it came from. Windows refuses + -- the first such name before writing any entry. + runTestM "names upstream restores on POSIX materialize as their bytes" $ do + tmpBase <- getTemporaryDirectory + let refusal = "NAR directory entry name 'COM1' is a Windows device name" + outcomes <- unpackedBothWays tmpSensitivity (tmpBase "nova-nix-test-unpack-posix-names") posixOnlyTree + pure $ + if SI.os == "mingw32" + then assertEqual "Windows refusals (strict, streamed)" (Left refusal, Left refusal) outcomes + else assertEqual "trees read back (strict, streamed)" (Right posixOnlyTree, Right posixOnlyTree) outcomes, + -- The same tree substituted into a temp store: the strict pipeline + -- unpacks and seals it, then re-serialises the store path from disk + -- against the narinfo's hash before it registers anything, so a + -- success means the path's bytes reproduce the NAR. Windows + -- refuses it before writing. + runTestM "a store path holding names upstream restores on POSIX substitutes" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-unpack-posix-store" + sp = StorePath (T.replicate 32 "c") "posix-names" + rawNar = NAR.serialise posixOnlyTree + info = (streamTestNarInfo rawNar) {NarInfo.niStorePath = storePathToText defaultStoreDir sp} + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + result <- Subst.unpackAndVerify store sp info rawNar + onDisk <- case result of + Subst.SubstSuccess _ lock -> do + releasePathLock lock + Right <$> NAR.serialiseFromPath (storePathToFilePath (stDir store) sp) + other -> pure (Left (T.pack (show other))) + closeStore store + forceRemoveIfExists tmpStore + pure $ case onDisk of + Left shown + | SI.os == "mingw32" && "is a Windows device name" `T.isInfixOf` shown -> Pass + _ -> assertEqual "store path read back" (Right posixOnlyTree) onDisk, + -- A name and a link target with no UTF-8 reading. Linux holds + -- both as bytes, as upstream restores them; a macOS volume cannot + -- hold the name (APFS refuses it, HFS+ rewrites it) but keeps the + -- target's bytes; Windows holds neither. + runTestM "bytes with no UTF-8 reading materialize where the host holds them" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-raw-bytes" + nameTree = NAR.NarDirectory [("caf\xE9", NAR.NarDirectory [("\xFF", NAR.NarRegular True "x")])] + targetTree = NAR.NarDirectory [("link", NAR.NarSymlink "caf\xE9")] + nameRefusal reason = "NAR directory entry name \"caf\\233\" is not valid UTF-8, " <> reason + targetRefusal = "NAR symlink target \"caf\\233\" is not valid UTF-8, so it has no UTF-16 form for Windows" + both outcome = (outcome, outcome) + named <- unpackedBothWays tmpSensitivity dest nameTree + targeted <- unpackedBothWays tmpSensitivity dest targetTree + pure $ case SI.os of + "mingw32" -> + assertEqual + "Windows refusals" + (both (Left (nameRefusal "so it has no UTF-16 form for Windows")), both (Left targetRefusal)) + (named, targeted) + "darwin" -> + assertEqual + "macOS refuses the name and keeps the target" + (both (Left (nameRefusal "which a macOS filesystem cannot hold")), both (Right targetTree)) + (named, targeted) + _ -> + assertEqual + "Linux keeps both" + (both (Right nameTree), both (Right targetTree)) + (named, targeted), + -- The bytes reach the filesystem without passing through the + -- locale's codec: under an ASCII file-system encoding (a C locale) + -- or a Latin-1 one a UTF-8 name still lands as its UTF-8 bytes. + -- Spelled through 'FilePath', the first cannot encode the name and + -- the second writes other bytes. + runTestM "names land as their bytes whatever the file-system encoding" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-codec" + tree = + NAR.NarDirectory + [ ("caf\xC3\xA9", NAR.NarRegular False "e"), + ("link", NAR.NarSymlink "\xE2\x9C\x93"), + ("\xE2\x9C\x93", NAR.NarRegular False "check") + ] + under encodingName = do + encoding <- mkTextEncoding encodingName + bracket getFileSystemEncoding setFileSystemEncoding $ \_ -> do + setFileSystemEncoding encoding + unpackedBothWays tmpSensitivity dest tree + if SI.os == "mingw32" + then Pass <$ putStrLn " SKIP a Windows path is UTF-16 and no locale codec spells it" + else do + outcomes <- mapM under ["ASCII//ROUNDTRIP", "ISO-8859-1//ROUNDTRIP"] + pure (assertEqual "trees read back under ASCII and Latin-1 (strict, streamed)" (replicate 2 (Right tree, Right tree)) outcomes), + -- unpackNarEntry: a NAR symlink materializes as a REAL link or fails + -- loudly - never as a regular file holding the target text, which + -- would silently diverge from the signed NAR hash + runTestM "unpackNarEntry symlink is real or loud" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-symlink" + tree = + NAR.NarDirectory + [ ("real", NAR.NarRegular False "contents"), + ("link", NAR.NarSymlink "real") + ] + Subst.clearStaleDestination dest + result <- unpackNarEntry tmpSensitivity dest tree + outcome <- case result of + Right () -> do + isLink <- Dir.pathIsSymbolicLink (dest "link") + pure (if isLink then Pass else Fail "symlink materialized as a non-link") + Left _ -> do + leftBehind <- Dir.doesFileExist (dest "link") + pure (if leftBehind then Fail "failed loudly but left a regular file behind" else Pass) + Subst.clearStaleDestination dest + pure outcome, + -- unpackNarEntry: a directory-target symlink that sorts BEFORE its + -- target still gets the directory link flavor (second-pass typing) + runTestM "unpackNarEntry types forward dir symlink" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-dirlink" + tree = + NAR.NarDirectory + [ ("alink", NAR.NarSymlink "zdir"), + ("zdir", NAR.NarDirectory [("f", NAR.NarRegular False "x")]) + ] + Subst.clearStaleDestination dest + result <- unpackNarEntry tmpSensitivity dest tree + outcome <- case result of + Left _ -> pure Pass -- symlinks unavailable here; the loud failure is the contract + Right () -> do + throughLink <- doesDirectoryExist (dest "alink") + pure (if throughLink then Pass else Fail "dir symlink not traversable (wrong flavor)") + Subst.clearStaleDestination dest + pure outcome, + -- Folding sibling names MATERIALIZE on every platform: true names + -- via the NTFS per-directory flag on Windows and on any volume the + -- probe reports sensitive (Linux, case-sensitive APFS), upstream's + -- case-hack renaming on a folding volume. The platform serialiser + -- reverses whichever branch ran, so the tree re-serialises to its + -- original NAR either way. + runTestM "folding sibling names materialize and round-trip" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-fold" + tree = + NAR.NarDirectory + [ ("Foo", NAR.NarRegular False "upper"), + ("foo", NAR.NarRegular False "lower") + ] + Subst.clearStaleDestination dest + result <- unpackNarEntry tmpSensitivity dest tree + outcome <- case result of + Left err -> pure (Fail ("unpack failed: " <> err)) + Right () -> do + onDisk <- NAR.serialiseFromPath dest + if onDisk /= tree + then pure (Fail "materialized tree does not re-serialise to its NAR") + else + if SI.os == "mingw32" || tmpSensitivity == CaseSensitive + then do + -- True names, not the hack: both spellings hold + -- distinct contents. + upper <- BS.readFile (dest "Foo") + lower <- BS.readFile (dest "foo") + pure (assertEqual "true names" ("upper", "lower") (upper, lower)) + else do + -- The hack: the later variant carries the suffix. + lower <- BS.readFile (dest "foo~nix~case~hack~1") + pure (assertEqual "case-hacked name" "lower" lower) + Subst.clearStaleDestination dest + pure outcome, + -- Every unpack creates exclusively, its root included, as + -- upstream's restore does: a destination that already holds an + -- entry is refused with upstream's wording and left as it was, + -- not truncated or written into. Callers clear a stale + -- destination first. Any volume answers this, so it is the + -- exclusive create's check on every platform, Windows' CREATE_NEW + -- included. + runTestM "unpack refuses a destination that already exists" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-taken" + fileTree = NAR.NarRegular False "new" + dirTree = NAR.NarDirectory [("f", NAR.NarRegular False "new")] + fileRefusal = "creating file '" <> quotedAsCxx dest <> "': File exists" + dirOverFile = "creating directory '" <> T.pack dest <> "': File exists" + dirOverDir = "path '" <> T.pack dest <> "' already exists" + streamInto tree = do + let raw = NAR.serialise tree + source <- chunkReader [raw] + outcome <- Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source + pure (either (Left . Subst.attemptFailureMessage) (const (Right ())) outcome) + strictAndStreamed tree = (,) <$> unpackNarEntry tmpSensitivity dest tree <*> streamInto tree + Subst.clearStaleDestination dest + BS.writeFile dest "old" + fileOnFile <- strictAndStreamed fileTree + dirOnFile <- strictAndStreamed dirTree + keptFile <- BS.readFile dest + Subst.clearStaleDestination dest + createDirectoryIfMissing True dest + dirOnDir <- strictAndStreamed dirTree + wroteInto <- Dir.doesPathExist (dest "f") + Subst.clearStaleDestination dest + let verdict + | keptFile /= "old" = Fail "the existing file was written over" + | wroteInto = Fail "the existing directory was written into" + | otherwise = + assertEqual + "refusals, strict and streamed (a file over a file, a directory over a file, a directory over a directory)" + ((Left fileRefusal, Left fileRefusal), (Left dirOverFile, Left dirOverFile), (Left dirOverDir, Left dirOverDir)) + (fileOnFile, dirOnFile, dirOnDir) + pure verdict, + -- std::quoted escapes a double quote and a backslash inside the + -- path, so a name holding both pins upstream's exact text. A + -- Windows name can hold neither. + runTestM "the file refusal quotes its path as std::quoted does" $ do + tmpBase <- getTemporaryDirectory + let plain = tmpBase "nova-nix-test-unpack-q" + dest = plain <> "\"b\\s" + expected = "creating file '\"" <> T.pack plain <> "\\\"b\\\\s\"': File exists" + tree = NAR.NarRegular False "new" + raw = NAR.serialise tree + if SI.os == "mingw32" + then Pass <$ putStrLn " SKIP a Windows name cannot hold a double quote" + else do + Subst.clearStaleDestination dest + BS.writeFile dest "old" + strict <- unpackNarEntry tmpSensitivity dest tree + source <- chunkReader [raw] + streamed <- Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source + Subst.clearStaleDestination dest + pure (assertEqual "refusals (strict, streamed)" (Left expected, Left expected) (strict, either (Left . Subst.attemptFailureMessage) (const (Right ())) streamed)), + -- The exclusive create reaches as far as base's own open on + -- Windows, where a raw CreateFileW stops at MAX_PATH (260 + -- characters) unless the path is spelled in the file namespace. + -- Every component here is short; only the whole path is long. + runTestM "unpack writes a file whose path is past MAX_PATH" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-long" + component = replicate 60 'd' + depth = 5 :: Int + nest inner = NAR.NarDirectory [(TE.encodeUtf8 (T.pack component), inner)] + tree = foldr (const nest) (NAR.NarDirectory [("leaf", NAR.NarRegular False "deep")]) [1 .. depth] + leafPath = foldl' () dest (replicate depth component) "leaf" + raw = NAR.serialise tree + readLeaf = either (pure . Left) (const (Right <$> BS.readFile leafPath)) + Subst.clearStaleDestination dest + strict <- unpackNarEntry tmpSensitivity dest tree >>= readLeaf + Subst.clearStaleDestination dest + source <- chunkReader [raw] + streamed <- + Subst.consumeNarStream tmpSensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source + >>= readLeaf . either (Left . Subst.attemptFailureMessage) (const (Right ())) + Subst.clearStaleDestination dest + pure $ + if length leafPath <= 260 + then Fail "the fixture path is not past MAX_PATH" + else assertEqual "leaf contents (strict, streamed)" (Right "deep", Right "deep") (strict, streamed), + -- The pure case-hack naming is a function of the probed + -- sensitivity, not of the platform: on a folding volume later + -- case variants gain the reversible suffix with a per-name + -- counter, on a sensitive one every name keeps its spelling. + runTest "caseHackDiskNames renames later case variants on a folding volume" $ + assertEqual + "hack naming" + [("Foo", "Foo"), ("foo", "foo~nix~case~hack~1"), ("fOO", "fOO~nix~case~hack~2"), ("bar", "bar")] + (caseHackDiskNames CaseInsensitive ["Foo", "foo", "fOO", "bar"]), + runTest "caseHackDiskNames keeps every name on a sensitive volume" $ + assertEqual + "identity naming" + [("Foo", "Foo"), ("foo", "foo"), ("fOO", "fOO"), ("bar", "bar")] + (caseHackDiskNames CaseSensitive ["Foo", "foo", "fOO", "bar"]), + -- The key behind both: case variants share it exactly on a + -- folding volume. + runTest "onDiskNameKey folds case only on a folding volume" $ + if onDiskNameKey CaseSensitive "Makefile" /= onDiskNameKey CaseSensitive "makefile" + && onDiskNameKey CaseInsensitive "Makefile" == onDiskNameKey CaseInsensitive "makefile" + then Pass + else Fail "the key does not follow the probed sensitivity", + -- A name with no UTF-8 reading has no characters to fold, so it + -- keys as its bytes even on a folding volume. + runTest "onDiskNameKey keys a name with no UTF-8 reading as its bytes" $ + assertEqual + "keys of a Latin-1 and a UTF-8 spelling" + ("caf\xE9", "CAF\xC3\x89") + (onDiskNameKey CaseInsensitive "caf\xE9", onDiskNameKey CaseInsensitive "caf\xC3\xA9"), + -- The probe against the filesystem's own answer: two sibling + -- names differing only by case are two entries on a sensitive + -- volume and one on a folding one. + runTestM "probeCaseSensitivity agrees with the filesystem" $ do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-case-probe" + Subst.clearStaleDestination dir + createDirectoryIfMissing True dir + BS.writeFile (dir "Probe") "upper" + BS.writeFile (dir "probe") "lower" + entries <- Dir.listDirectory dir + probed <- probeCaseSensitivity dir + Subst.clearStaleDestination dir + let observed = if length entries == 2 then CaseSensitive else CaseInsensitive + pure (assertEqual "probe against the filesystem" observed probed), + -- Where the volume's serialiser strips the suffix (a folding + -- volume), an incoming name carrying it must reject (it could + -- not round-trip); on a volume that keeps names apart such a + -- name is legitimate and materializes verbatim. + runTestM "incoming case-hack suffix names reject where the serialiser strips" $ do + tmpBase <- getTemporaryDirectory + let dest = tmpBase "nova-nix-test-unpack-suffix" + tree = NAR.NarDirectory [("x~nix~case~hack~1", NAR.NarRegular False "v")] + Subst.clearStaleDestination dest + result <- unpackNarEntry tmpSensitivity dest tree + outcome <- case (tmpSensitivity, result) of + (CaseInsensitive, Left _) -> pure Pass + (CaseInsensitive, Right ()) -> pure (Fail "suffix-bearing name accepted where the serialiser strips") + (CaseSensitive, Right ()) -> do + kept <- BS.readFile (dest "x~nix~case~hack~1") + pure (assertEqual "verbatim where names stay apart" "v" kept) + (CaseSensitive, Left err) -> pure (Fail ("a volume keeping names apart rejected a legitimate name: " <> err)) + Subst.clearStaleDestination dest + pure outcome, + -- The capability probe itself: NTFS grants the per-directory flag + -- (CI runners and the dev box run NTFS temp dirs); other + -- platforms report unsupported. + runTestM "trySetCaseSensitiveDir reflects platform support" $ do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-csdir" + Subst.clearStaleDestination dir + createDirectoryIfMissing True dir + flagged <- trySetCaseSensitiveDir dir + Subst.clearStaleDestination dir + pure (assertEqual "flag support" (SI.os == "mingw32") flagged), + -- unpackAndVerify re-serialises the materialized tree and checks it + -- against the declared hash before returning a registration: a + -- faithful round-trip passes, and the registration carries the + -- declared hash. + runTestM "unpackAndVerify accepts a tree that reproduces its hash" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-unpack-verify" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath (T.replicate 32 "b") "roundtrip" + tree = + NAR.NarDirectory + [ ("data.txt", NAR.NarRegular False "verified bytes"), + ("sub", NAR.NarDirectory [("inner", NAR.NarRegular False "nested")]) + ] + rawNar = NAR.serialise tree + narHash = CHash.formatNixHash (CHash.hashBytes rawNar) + info = + NarInfo.NarInfo + { NarInfo.niStorePath = storePathToText defaultStoreDir sp, + NarInfo.niUrl = "nar/roundtrip.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = narHash, + NarInfo.niNarSize = fromIntegral (BS.length rawNar), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + result <- Subst.unpackAndVerify store sp info rawNar + onDisk <- BS.readFile (storePathToFilePath (stDir store) sp "data.txt") + -- A success carries the path lock still held; release it before + -- the store teardown (Windows cannot delete a file a handle + -- holds open). + case result of + Subst.SubstSuccess _ lock -> releasePathLock lock + _ -> pure () + closeStore store + forceRemoveIfExists tmpStore + pure $ case result of + Subst.SubstSuccess reg _ -> + if prNarHash reg == narHash && onDisk == "verified bytes" + then Pass + else Fail "registration or on-disk bytes diverge from the declared hash" + other -> Fail ("unpackAndVerify failed: " <> T.pack (show other)), + -- The verify-fails branch of the strict pipeline: bytes that do + -- not match the narinfo's signed NarHash or NarSize never reach + -- the unpack sink, so nothing is written at the store path and + -- the lock is free afterwards. + runTestM "unpackAndVerify writes nothing for a NAR that fails verification" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-unpack-unverified" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath (T.replicate 32 "f") "unverified" + rawNar = NAR.serialise (NAR.NarDirectory [("data.txt", NAR.NarRegular False "untrusted bytes")]) + consistent = + NarInfo.NarInfo + { NarInfo.niStorePath = storePathToText defaultStoreDir sp, + NarInfo.niUrl = "nar/unverified.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes rawNar), + NarInfo.niNarSize = toInteger (BS.length rawNar), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + wrongHash = consistent {NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes "not the nar")} + wrongSize = consistent {NarInfo.niNarSize = toInteger (BS.length rawNar) + 1} + destPath = storePathToFilePath (stDir store) sp + hashResult <- Subst.unpackAndVerify store sp wrongHash rawNar + sizeResult <- Subst.unpackAndVerify store sp wrongSize rawNar + written <- Dir.doesPathExist destPath + reLock <- tryAcquirePathLock (StoreDir tmpStore) sp + mapM_ releasePathLock reLock + closeStore store + forceRemoveIfExists tmpStore + pure $ case (hashResult, sizeResult, reLock) of + (Subst.SubstError hashErr, Subst.SubstError sizeErr, Just _) + | written -> Fail "an unverified NAR reached the store path" + | not ("NAR hash mismatch" `T.isInfixOf` hashErr) -> Fail ("wrong hash error: " <> hashErr) + | not ("NAR size mismatch" `T.isInfixOf` sizeErr) -> Fail ("wrong size error: " <> sizeErr) + | otherwise -> Pass + (_, _, Nothing) -> Fail "lock still held after a refused NAR" + other -> Fail ("expected two SubstError results, got: " <> T.pack (show other)) + ] + where + chainCache url = Subst.CacheConfig url ["unused-key"] 10 + -- A tree unpacked into a fresh destination through the strict and + -- the streaming path, each read back from disk, or the unpack's + -- refusal. The read-back tree carries every name and link target + -- as the bytes on disk, so equal trees serialise to the same NAR. + unpackedBothWays sensitivity dest tree = do + let raw = NAR.serialise tree + streamed = do + source <- chunkReader [raw] + outcome <- Subst.consumeNarStream sensitivity dest (streamTestNarInfo raw) (CHash.hashBytes raw) source + pure (either (Left . Subst.attemptFailureMessage) (const (Right ())) outcome) + readBack unpack = do + Subst.clearStaleDestination dest + result <- unpack + onDisk <- either (pure . Left) (const (Right <$> NAR.serialiseFromPath dest)) result + Subst.clearStaleDestination dest + pure onDisk + strict <- readBack (unpackNarEntry sensitivity dest tree) + viaStream <- readBack streamed + pure (strict, viaStream) + -- A real held lock for tests that construct 'SubstSuccess' by hand: + -- the constructor carries the path's lock, so a fabricated success + -- needs a genuine one, taken in a scratch directory. + withChainLock dirName act = do + tmpBase <- getTemporaryDirectory + let lockRoot = tmpBase (dirName :: FilePath) + forceRemoveIfExists lockRoot + createDirectoryIfMissing True lockRoot + lock <- acquirePathLock (StoreDir lockRoot) (StorePath (T.replicate 32 "d") "hit") + result <- act lock + releasePathLock lock + forceRemoveIfExists lockRoot + pure result + sampleNarBytes = "nova-nix nar sample bytes" :: BS.ByteString + sampleNarHash = CHash.formatNixHash (CHash.hashBytes sampleNarBytes) + wrongNarHash = CHash.formatNixHash (CHash.hashBytes ("different bytes" :: BS.ByteString)) + sampleHash = T.replicate 32 "a" + sampleNarInfo narHash = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/" <> sampleHash <> "-hello", + NarInfo.niUrl = "nar/sample.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Just sampleNarHash, + NarInfo.niFileSize = Just 0, + NarInfo.niNarHash = narHash, + NarInfo.niNarSize = fromIntegral (BS.length sampleNarBytes), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + -- A real xz stream: "nova-nix xz fixture payload\n" 64 times + -- (1792 bytes) compressed with xz -9 to 112 bytes, embedded as + -- base64 so the test source stays ASCII. + xzFixturePayload = BS.concat (replicate 64 "nova-nix xz fixture payload\n") + xzFixtureSize = toInteger (BS.length xzFixturePayload) + xzFixtureB64 = + "/Td6WFoAAATm1rRGAgAhARwAAAAQz1jM4Ab/AC1dADcbyzKSinKbUBue2bMHcUt1zJQMzAec5W6XwPbK3dKJtL3q9K3rfg1KQ/ZOAAAAAAAWUPRD8XwohgABSYAOAAAA2Eg7urHEZ/sCAAAAAARZWg==" :: Text + -- cache.nixos.org narinfos recorded 2026-08-20 (nixos-25.05 + -- channel), verbatim: GNU hello (references including itself, + -- deriver, production signature) and a doc output whose References + -- line is empty. + recordedHelloNarInfo = + T.unlines + [ "StorePath: /nix/store/jppkr0h8aap5z7m4xy4vg5yrwlly9h2v-hello-2.12.1", + "URL: nar/1m1sbal63vqhlvbcxzdj8yr6fhhld7dsyhxbxwip54dgvg56rjnc.nar.xz", + "Compression: xz", + "FileHash: sha256:1m1sbal63vqhlvbcxzdj8yr6fhhld7dsyhxbxwip54dgvg56rjnc", + "FileSize: 52056", + "NarHash: sha256:0s8wi24d3bc4zxyxq3hffj102zi7cjp3wqnpj6nhqrwgjsgqff81", + "NarSize: 249480", + "References: dska0s3gxxd8azbsn85pwm6xcqhivldw-glibc-2.40-66 jppkr0h8aap5z7m4xy4vg5yrwlly9h2v-hello-2.12.1", + "Deriver: a9y211d3lq3yf2mpfvb72f0qvsl0wi3s-hello-2.12.1.drv", + "Sig: cache.nixos.org-1:xV9xUvtPGHTSo6eeFWYYhaNFiH8MYSXKZzmxe0cf+acdDkIYxFPLC/MNc1CjlbsVoaUwGhcigUdr9eW2+W1UAw==" + ] + recordedHelloDocNarInfo = + T.unlines + [ "StorePath: /nix/store/4xrqj3kcd89bsg5crbpnx1ppg7nxw9xp-hello-1.0.0.2-doc", + "URL: nar/1r86zzj3g8jhzyvi17vchsj3frrqk5l329viq2i24iish53x922l.nar.xz", + "Compression: xz", + "FileHash: sha256:1r86zzj3g8jhzyvi17vchsj3frrqk5l329viq2i24iish53x922l", + "FileSize: 892", + "NarHash: sha256:0amizmj17fgj5sz1gvr743kncrzwvq747lml3zhd374f14hzgd7a", + "NarSize: 2072", + "References: ", + "Deriver: 5knzybx32a3iq53jjw6xd6fn4awn2l3h-hello-1.0.0.2.drv", + "Sig: cache.nixos.org-1:jUFHex7R7zPonZZqjVy/OOTguUZZE/sityC0zvu3sb35Az8zBTROeFhUC/J/UFx8Ui8UflA7uHyLJm5Z+Ca6Bw==" + ] + -- A NAR with the shapes streaming unpack must materialize: + -- nesting, an executable, a symlink, a zero-byte file, an empty + -- directory, and a sibling pair that collides on folding + -- filesystems. Entries in NAR name order. + -- Both survive a round trip through disk on every platform. The + -- executable bit does on Windows because the store keeps it in an + -- alternate data stream (#35); the nested symlink target does because + -- nova-cache 0.11.1.1 normalises a Windows reparse point's separators + -- back to the POSIX spelling at the NAR boundary (#112). + streamTestLinkTarget = "bin/tool" + streamTestNar = + NAR.serialise + ( NAR.NarDirectory + [ ("Makefile", NAR.NarRegular False "all:\n"), + ("bin", NAR.NarDirectory [("tool", NAR.NarRegular True "#!/bin/sh\n")]), + ("empty", NAR.NarRegular False ""), + ("emptydir", NAR.NarDirectory []), + ("link", NAR.NarSymlink streamTestLinkTarget), + ("makefile", NAR.NarRegular False "lower\n") + ] + ) + streamTestDigest = CHash.hashBytes streamTestNar + streamTestNarInfo rawNar = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/" <> sampleHash <> "-stream", + NarInfo.niUrl = "nar/stream.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes rawNar), + NarInfo.niNarSize = fromIntegral (BS.length rawNar), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + streamChunks chunkLen bytes + | BS.null bytes = [] + | otherwise = BS.take chunkLen bytes : streamChunks chunkLen (BS.drop chunkLen bytes) + -- The xz fixture's payload, compressed by nova-cache:zstandard's + -- own encoder - the exact pairing the push path ships. + zstdFixtureCompressed = CZstd.compress CZstd.defaultCompressionLevel xzFixturePayload + -- The same payload compressed by the bzip2 CLI (bzip2 -9), + -- embedded base64 so the test source stays ASCII. The reference + -- encoder is deliberately the format's own tool and not the + -- decoder's library: nova-cache:bzip2 decodes only, so a + -- self-produced fixture could not catch the two disagreeing. + bzip2FixtureB64 = + "QlpoOTFBWSZTWTop7coAAf/RgAAQQAInJddwIACQKZMTIMjAqqBkDaJtTgCQKgZA5AyBAFwNwMAeAYAgCQLgXA+AoBUCQIAkCAJAUAgCgH4u5IpwoSB0U9uU" :: Text + -- A NAR every platform materializes identically (no executable + -- bit, no separator-bearing symlink target), and the bzip2 CLI's + -- compression of exactly these bytes. + bzip2NarFixture = + NAR.serialise + (NAR.NarDirectory [("greeting", NAR.NarRegular False "nova-nix bzip2 fixture\n")]) + bzip2NarFixtureB64 = + "QlpoOTFBWSZTWa3VDM4AAFJ5gG7yAIBAYjAAP+ffcCAAlIaTJM1PUnqD1DJpoHo01BkkA9I0AAAAtARwcfWQAq1WLMjpmBpVKUAJM6EA8IDQEABOzcRgdDpvigJ6ZZa760fpxZtj+ts6GDiuqt/B6UuthWIrabWmZTkFlI46C8MmbMoVmMYwEYRUCYQW/F3JFOFCQrdUMzg=" :: Text + +-- --------------------------------------------------------------------------- +-- Tests: per-store-path locks (the substitution race) +-- --------------------------------------------------------------------------- + +-- | Watchdog for the concurrent-substitution race: generous, because a +-- lock-protocol regression shows up as a hang, never as a fast wrong +-- answer. +raceWatchdogMicros :: Int +raceWatchdogMicros = 30 * 1000000 + +-- | How long a delete gets to (wrongly) finish while the path lock is +-- held elsewhere: long enough that an unlocked delete of one tiny tree +-- always completes inside it, while a correctly blocked delete waits +-- until the release that follows the probe. +deleteLockProbeMicros :: Int +deleteLockProbeMicros = 500 * 1000 + +-- | The executable bit's own representation, independent of any store. +-- +-- Every assertion here is platform-agnostic on purpose: the module's whole +-- point is that a caller asks 'ExecBit' rather than the filesystem, so the +-- same questions must have the same answers on Windows and on Unix even +-- though the bit is kept in different places. +testExecBit :: IO [Bool] +testExecBit = do + putStrLn "store/exec-bit" + sequence + [ -- The round-trip the representation exists for: what was marked + -- reads back marked, and an unmarked sibling stays unmarked. + runTestM "exec mark round-trips through isExecutable" $ do + dir <- freshExecBitDir "roundtrip" + let marked = dir "tool" + plain = dir "data" + BS.writeFile marked "#!x" + BS.writeFile plain "hello" + ExecBit.markExecutable marked + isMarked <- ExecBit.isExecutable marked + isPlain <- ExecBit.isExecutable plain + forceRemoveIfExists dir + pure $ case (isMarked, isPlain) of + (True, False) -> Pass + (False, _) -> Fail "a marked file did not read back executable" + (_, True) -> Fail "an unmarked file read back executable", + -- copyExecMark out of a sealed store path. setReadOnly is what + -- placeInStore does, and on Windows copyFile propagates that + -- attribute to the copy, where a mark cannot be written until it is + -- cleared again. The source must also survive read-only. + runTestM "exec mark survives a copy out of a read-only source" $ do + dir <- freshExecBitDir "copy" + let src = dir "tool" + dest = dir "tool-copy" + BS.writeFile src "#!x" + ExecBit.markExecutable src + setReadOnly src + Dir.copyFile src dest + ExecBit.copyExecMark src dest + copied <- ExecBit.isExecutable dest + srcStillExec <- ExecBit.isExecutable src + -- Unseal before cleanup: a read-only file resists removal on + -- Windows the same way it resists a stream write. + Dir.getPermissions src >>= Dir.setPermissions src . Dir.setOwnerWritable True + forceRemoveIfExists dir + pure $ case (copied, srcStillExec) of + (True, True) -> Pass + (False, _) -> Fail "the copy lost its exec mark" + (_, False) -> Fail "sealing the source dropped its exec mark", + -- The serialiser reads the mark, not the file's permissions: this is + -- the flag a NAR carries, and on Windows getPermissions would answer + -- from the extension instead. + runTestM "serialiseFromPath reports the marked flag" $ do + dir <- freshExecBitDir "serialise" + let marked = dir "tool" + BS.writeFile marked "#!x" + BS.writeFile (dir "data") "hello" + ExecBit.markExecutable marked + entry <- ExecBit.serialiseFromPath processCaseHack dir + forceRemoveIfExists dir + pure $ case entry of + NAR.NarDirectory entries -> + assertEqual + "flags of (data, tool)" + [("data", False), ("tool", True)] + [(n, e) | (n, NAR.NarRegular e _) <- entries] + other -> Fail ("expected a directory entry, got: " <> T.pack (show other)), + -- The sink and the verifier must read one source of truth. A + -- substituted tree is written through markExecutable and its hash + -- rechecked on disk, so if narHashOfPath consulted the filesystem's + -- own idea of executability instead, every path holding a marked + -- file would be downloaded, rejected and deleted. + runTestM "narHashOfPath agrees with the serialiser it verifies" $ do + dir <- freshExecBitDir "hash" + let marked = dir "tool" + BS.writeFile marked "#!x" + BS.writeFile (dir "data") "hello" + ExecBit.markExecutable marked + streamed <- ExecBit.narHashOfPath processCaseHack dir + fromEntry <- NAR.narHash <$> ExecBit.serialiseFromPath processCaseHack dir + -- A control on the same axis: an unmarked tree must hash + -- differently, or agreement above would prove nothing. + unmarkedDir <- freshExecBitDir "hash-plain" + BS.writeFile (unmarkedDir "tool") "#!x" + BS.writeFile (unmarkedDir "data") "hello" + unmarked <- ExecBit.narHashOfPath processCaseHack unmarkedDir + forceRemoveIfExists dir + forceRemoveIfExists unmarkedDir + pure $ + if streamed /= fromEntry + then Fail "the verifier's hash disagrees with the serialiser's" + else + if streamed == unmarked + then Fail "the exec mark did not reach the hash at all" + else Pass, + -- correct/ recurses by name, and a non-ASCII name must survive that + -- recursion: decoding it a byte at a time names a file that is not + -- there and the mark silently reads as absent. + runTestM "a non-ASCII directory name keeps its child's mark" $ do + dir <- freshExecBitDir "utf8" + let sub = dir "\955-dir" + marked = sub "\955-tool" + createDirectoryIfMissing True sub + BS.writeFile marked "#!x" + ExecBit.markExecutable marked + entry <- ExecBit.serialiseFromPath processCaseHack dir + forceRemoveIfExists dir + pure $ case entry of + NAR.NarDirectory [(_, NAR.NarDirectory [(_, NAR.NarRegular True _)])] -> Pass + other -> Fail ("expected one marked child, got: " <> T.pack (show other)) + ] + +-- | An empty scratch directory for one 'testExecBit' case. +freshExecBitDir :: String -> IO FilePath +freshExecBitDir name = do + tmpBase <- getTemporaryDirectory + let dir = tmpBase ("nova-nix-test-execbit-" ++ name) + forceRemoveIfExists dir + createDirectoryIfMissing True dir + pure dir + +testPathLocks :: IO [Bool] +testPathLocks = do + putStrLn "store/path-locks" + sequence + [ -- Two independent handles on one path lock exclude each other - + -- the guarantee flock and LockFileEx share, and exactly the shape + -- of two processes contending for one store path. + runTestM "path lock excludes a second handle" $ do + tmpBase <- getTemporaryDirectory + let lockRoot = tmpBase "nova-nix-test-lock-excl" + forceRemoveIfExists lockRoot + createDirectoryIfMissing True lockRoot + let dir = StoreDir lockRoot + sp = StorePath (T.replicate 32 "a") "lockee" + held <- acquirePathLock dir sp + second <- tryAcquirePathLock dir sp + releasePathLock held + third <- tryAcquirePathLock dir sp + mapM_ releasePathLock second + mapM_ releasePathLock third + forceRemoveIfExists lockRoot + pure $ case (second, third) of + (Nothing, Just _) -> Pass + (Just _, _) -> Fail "a second handle acquired a held lock" + (Nothing, Nothing) -> Fail "release did not free the lock", + -- The already-valid short-circuit: a registered path substitutes + -- as SubstAlreadyValid with no network and no disk writes - the + -- configured cache is unreachable, so any contact would surface + -- as an error result. + runTestM "trySubstitute adopts an already-valid path untouched" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-lock-valid" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath (T.replicate 32 "c") "validpath" + destPath = storePathToFilePath (StoreDir tmpStore) sp + createDirectoryIfMissing True destPath + BS.writeFile (destPath "payload") "registered bytes" + reg <- registrationFor store sp Nothing [] + registerPath (stDB store) reg + result <- Subst.trySubstitute store [unreachableCache] sp + survivor <- BS.readFile (destPath "payload") + -- The short-circuit released the lock, so the path must be + -- lockable again at once. + reLock <- tryAcquirePathLock (StoreDir tmpStore) sp + mapM_ releasePathLock reLock + closeStore store + forceRemoveIfExists tmpStore + pure $ case (result, reLock) of + (Subst.SubstAlreadyValid, Just _) + | survivor == "registered bytes" -> Pass + | otherwise -> Fail "tree touched during already-valid adoption" + (Subst.SubstAlreadyValid, Nothing) -> Fail "lock still held after already-valid return" + (other, _) -> Fail ("expected SubstAlreadyValid, got: " <> T.pack (show other)), + -- The strict pipeline honors the same short-circuit: fed a + -- DIFFERENT (self-consistent) NAR for an already-valid path, it + -- must adopt the registered tree rather than overwrite it. + runTestM "unpackAndVerify adopts an already-valid path untouched" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-lock-valid-strict" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath (T.replicate 32 "d") "strictvalid" + destPath = storePathToFilePath (StoreDir tmpStore) sp + createDirectoryIfMissing True destPath + BS.writeFile (destPath "payload") "registered bytes" + reg <- registrationFor store sp Nothing [] + registerPath (stDB store) reg + let differentNar = NAR.serialise (NAR.NarDirectory [("other", NAR.NarRegular False "different bytes")]) + result <- Subst.unpackAndVerify store sp (lockTestNarInfo sp differentNar) differentNar + survivor <- BS.readFile (destPath "payload") + closeStore store + forceRemoveIfExists tmpStore + pure $ case result of + Subst.SubstAlreadyValid + | survivor == "registered bytes" -> Pass + | otherwise -> Fail "tree touched during already-valid adoption" + other -> Fail ("expected SubstAlreadyValid, got: " <> T.pack (show other)), + -- The race the locks exist for: two concurrent substitutions of + -- one path, independent lock handles. Exactly one materializes; + -- the other waits at the lock and adopts the winner's registered + -- path; the surviving tree is intact and registered once. + runTestM "concurrent substitutions: one materializes, one adopts" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-lock-race" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath (T.replicate 32 "e") "racepath" + destPath = storePathToFilePath (StoreDir tmpStore) sp + rawNar = NAR.serialise (NAR.NarDirectory [("data", NAR.NarRegular False "race payload")]) + -- The caller's contract per attempt: register under the + -- still-held lock, then release it. + attempt = do + result <- Subst.unpackAndVerify store sp (lockTestNarInfo sp rawNar) rawNar + case result of + Subst.SubstSuccess winnerReg lock -> do + registerPath (stDB store) winnerReg + releasePathLock lock + _ -> pure () + pure result + firstDone <- newEmptyMVar + secondDone <- newEmptyMVar + _ <- forkIO ((try attempt :: IO (Either SomeException Subst.SubstResult)) >>= putMVar firstDone) + _ <- forkIO ((try attempt :: IO (Either SomeException Subst.SubstResult)) >>= putMVar secondDone) + outcomeA <- timeout raceWatchdogMicros (takeMVar firstDone) + outcomeB <- timeout raceWatchdogMicros (takeMVar secondDone) + rowCount <- length <$> queryAllValidPaths (stDB store) + onDisk <- NAR.serialiseFromPath destPath + closeStore store + forceRemoveIfExists tmpStore + pure $ case (outcomeA, outcomeB) of + (Just (Right resultA), Just (Right resultB)) -> + let outcomes = [resultA, resultB] + materialized = length [() | Subst.SubstSuccess _ _ <- outcomes] + adopted = length [() | Subst.SubstAlreadyValid <- outcomes] + in if materialized == 1 && adopted == 1 && rowCount == 1 && NAR.serialise onDisk == rawNar + then Pass + else + Fail + ( "unexpected race outcome: " + <> T.pack (show outcomes) + <> ", registered rows: " + <> T.pack (show rowCount) + ) + other -> Fail ("a race attempt hung or threw: " <> T.pack (show other)) + ] + where + -- Never contacted when the already-valid short-circuit holds; a + -- regression that reaches for the network fails loudly here. + unreachableCache = Subst.CacheConfig "http://127.0.0.1:9" ["unused-key"] 10 + lockTestNarInfo sp rawNar = + NarInfo.NarInfo + { NarInfo.niStorePath = storePathToText defaultStoreDir sp, + NarInfo.niUrl = "nar/lock-test.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes rawNar), + NarInfo.niNarSize = fromIntegral (BS.length rawNar), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + +-- --------------------------------------------------------------------------- +-- Tests: Build orchestrator (Phase 3, Batch 7) +-- --------------------------------------------------------------------------- + +testBuildOrchestrator :: IO [Bool] +testBuildOrchestrator = do + putStrLn "build/orchestrator" + sequence + [ -- BuildConfig has caches field + runTest "defaultBuildConfig has empty caches" $ + assertEqual "empty-caches" [] (bcCaches (defaultBuildConfig defaultStoreDir)), + -- Upstream's shape is a product token with the version; the comment + -- after it is ours. What bot mitigation keys on is that there is one. + runTest "the User-Agent is a nova-nix product token with a version" $ + assertEqual "ua" True ("nova-nix/" `BS.isPrefixOf` userAgent && BS.length userAgent > BS.length "nova-nix/ (+https://github.com/Novavero-AI/nova-nix)"), + runTestM "withUserAgent sets exactly one User-Agent, replacing any present" $ do + request0 <- HTTP.parseRequest "http://127.0.0.1/narinfo-hashes" + let stale = request0 {HTTP.requestHeaders = [("User-Agent", "curl/0"), ("Accept", "*/*")]} + pure (assertEqual "headers" [("User-Agent", userAgent), ("Accept", "*/*")] (HTTP.requestHeaders (withUserAgent stale))), + -- The build PATH must never open with the build working directory: + -- a bare-name builder has no directory to derive. + runTest "bare-name builder derives no PATH entry" $ + let entries = T.splitOn (if SI.os == "mingw32" then ";" else ":") (buildPath "bash") + in assertEqual "no-dot" False (any (\e -> e == "." || T.isPrefixOf "./" e || T.isPrefixOf ".\\" e) entries), + runTest "dot-relative builder derives no PATH entry" $ + let entries = T.splitOn (if SI.os == "mingw32" then ";" else ":") (buildPath "./bash") + in assertEqual "no-dot-rel" False (any (\e -> e == "." || T.isPrefixOf "./" e || T.isPrefixOf ".\\" e) entries), + runTest "absolute builder opens PATH with its own directory" $ + let path = buildPath ("/store/aaa-bootstrap/bin" "bash") + in assertEqual "builder-dir-first" (Just "/store/aaa-bootstrap/bin") (listToMaybe (T.splitOn (if SI.os == "mingw32" then ";" else ":") path)), + -- unionEnvs: earlier maps win; on Windows displacement is + -- case-insensitive and keeps the winner's spelling. + runTest "unionEnvs left map wins" $ + assertEqual + "left-bias" + (Just "build") + (Map.lookup "A" (unionEnvs [Map.fromList [("A", "build")], Map.fromList [("A", "host")]])), + runTest "unionEnvs displaces a case variant on Windows" $ + let merged = unionEnvs [Map.fromList [("PATH", "build")], Map.fromList [("Path", "host")]] + in if SI.os == "mingw32" + then assertEqual "displaced" (Map.fromList [("PATH", "build")]) merged + else assertEqual "distinct" (Map.fromList [("PATH", "build"), ("Path", "host")]) merged, + -- scrubAmbient: nothing ambient survives on Unix; on Windows only + -- the allowlist passes (keeping its ambient spelling), COMSPEC is + -- synthesized from SystemRoot, and PATHEXT is pinned. + runTest "scrubAmbient drops undeclared ambient variables" $ + let ambient = + Map.fromList + [ ("SystemRoot", "C:\\WINDOWS"), + ("APPDATA", "C:\\Users\\host\\AppData\\Roaming"), + ("LANG", "en_US.UTF-8"), + ("Path", "C:\\host\\bin") + ] + scrubbed = scrubAmbient ambient + in if SI.os == "mingw32" + then + assertEqual + "allowlist-only" + ( Map.fromList + [ ("SystemRoot", "C:\\WINDOWS"), + ("COMSPEC", "C:\\WINDOWS\\System32\\cmd.exe"), + ("PATHEXT", ".COM;.EXE;.BAT;.CMD") + ] + ) + scrubbed + else assertEqual "empty" Map.empty scrubbed, + runTest "scrubAmbient pins PATHEXT even without SystemRoot" $ + let scrubbed = scrubAmbient Map.empty + in if SI.os == "mingw32" + then assertEqual "pinned" (Map.fromList [("PATHEXT", ".COM;.EXE;.BAT;.CMD")]) scrubbed + else assertEqual "empty" Map.empty scrubbed, + -- Build-time placeholder substitution. Upstream rewrites the whole + -- @name=value@ string (local-derivation-goal.cc:2004), so a sentinel in + -- a dynamic attribute name is substituted along with the values. + runTest "rewritePlaceholders substitutes an output sentinel" $ + assertEqual + "substituted" + "/store/aaa-p/lib" + (rewritePlaceholders [("out", "/store/aaa-p")] (hashPlaceholder "out" <> "/lib")), + runTest "rewritePlaceholders leaves a foreign output's sentinel alone" $ + assertEqual + "untouched" + (hashPlaceholder "dev") + (rewritePlaceholders [("out", "/store/aaa-p")] (hashPlaceholder "dev")), + runTest "rewriteEnv rewrites names as well as values" $ + let rewrite = rewritePlaceholders [("out", "/store/aaa-p")] + env = Map.fromList [(hashPlaceholder "out" <> "-flag", hashPlaceholder "out" <> "/lib")] + in assertEqual + "name-and-value" + (Map.fromList [("/store/aaa-p-flag", "/store/aaa-p/lib")]) + (rewriteEnv rewrite env), + -- BuildConfig with caches + runTest "BuildConfig accepts caches" $ + let cache = Subst.CacheConfig "https://cache.example.com" ["key"] 10 + config = (defaultBuildConfig defaultStoreDir) {bcCaches = [cache]} + in assertEqual "one-cache" 1 (length (bcCaches config)), + -- buildWithDeps on a simple derivation (no deps, builder fails but graph resolves) + runTestM "buildWithDeps single drv" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-orch" + createDirectoryIfMissing True tmpStore + store <- openStore (StoreDir tmpStore) + let drv = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = StorePath "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" "test-out", + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = "/nonexistent-builder", + drvArgs = [], + drvEnv = Map.singleton "name" "test" + } + drvSP = StorePath "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy" "test.drv" + -- Write .drv to store so buildWithDeps can read it + writeDrv store drv drvSP + let config = (defaultBuildConfig (StoreDir tmpStore)) {bcTmpDir = tmpBase "nova-nix-test-orch-tmp"} + result <- buildWithDeps config store drv drvSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + -- Builder will fail (nonexistent) but the graph should resolve + -- correctly: the failure must come from SPAWNING THE BUILDER, not + -- from graph resolution or drv reading upstream of it. + pure $ case result of + BuildFailure msg _ + | "nonexistent-builder" `T.isInfixOf` msg -> Pass + | otherwise -> Fail ("failed before reaching the builder: " <> msg) + BuildSuccess _ -> Fail "expected build failure for nonexistent builder", + -- buildWithDeps with cycle detection (mocked through malformed graph) + runTest "cycle detection returns failure" $ + let spA = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "a.drv" + spB = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "b.drv" + drvACyc = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.singleton spB ["out"], + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + drvBCyc = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.singleton spA ["out"], + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + readFn sp + | sp == spB = Right drvBCyc + | sp == spA = Right drvACyc + | otherwise = Left "unknown" + in case pureDepGraph readFn drvACyc spA of + Right graph -> case DepGraph.topoSort graph of + DepGraph.TopoCycle _ -> Pass + DepGraph.TopoSorted order -> Fail ("expected cycle, got sorted: " <> T.pack (show order)) + Left err -> Fail ("expected graph to build, got: " <> err), + -- missing .drv causes failure in dep graph + runTest "missing drv in dep graph" $ + let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "missing.drv" + drv = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.singleton sp ["out"], + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + readFn _ = Left "not found" + in case pureDepGraph readFn drv (StorePath "rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr" "root.drv") of + Left _ -> Pass + Right _ -> Fail "expected failure for missing .drv", + -- derivation with context creates populated inputDrvs. Hashing a + -- dependent derivation reads input modulo hashes from the drv-hash + -- cache, which only the IO evaluator maintains, so this runs under + -- evalNixIO (an in-session dependency hits the cache bottom-up). + runTestM "derivation context populates inputDrvs" $ do + tmpBase <- getTemporaryDirectory + result <- + evalDerivationIO tmpBase $ + T.concat + [ "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ", + "main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; src = dep.outPath; }; ", + "in main" + ] + pure $ assertRight "drv-ctx-inputs" result $ \drv -> + if Map.null (drvInputDrvs drv) + then Fail "expected non-empty drvInputDrvs" + else Pass, + -- drv3: a dependent derivation's drvPath is stable across evaluations + -- (the input modulo substitution is deterministic). + runTestM "dependent derivation drvPath is deterministic (IO eval)" $ do + tmpBase <- getTemporaryDirectory + let expr = + T.concat + [ "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; ", + "main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; src = dep.outPath; }; ", + "in main.drvPath" + ] + r1 <- evalNixIO tmpBase expr + r2 <- evalNixIO tmpBase expr + pure $ case (r1, r2) of + (Right (VStr a _), Right (VStr b _)) + | a == b -> Pass + | otherwise -> Fail ("drvPath not deterministic: " <> bytesText a <> " vs " <> bytesText b) + _ -> Fail "expected main.drvPath to evaluate to a string under IO eval", + -- drv1: embedding another derivation's drvPath (an all-outputs ref) adds + -- it to inputDrvs carrying the referenced derivation's FULL + -- output-name set; the IO evaluator recovers the names in-session. + runTestM "derivation embedding a drvPath lists all its outputs in inputDrvs (IO eval)" $ do + tmpBase <- getTemporaryDirectory + let depSrc = "derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ \"out\" \"dev\" ]; }" + depPathR <- evalNixIO tmpBase ("(" <> depSrc <> ").drvPath") + result <- + evalDerivationIO tmpBase $ + T.concat + [ "let dep = ", + depSrc, + "; main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ref = dep.drvPath; }; ", + "in main" + ] + pure $ case (depPathR, result) of + (Right (VStr depPathBytes _), Right drv) -> + case parseStorePath defaultStoreDir (bytesText depPathBytes) of + Nothing -> Fail ("unparseable dep drvPath: " <> bytesText depPathBytes) + Just depSP -> case Map.lookup depSP (drvInputDrvs drv) of + Just outs + | Set.fromList outs == Set.fromList ["dev", "out"] -> Pass + | otherwise -> Fail ("expected the full output set [dev, out], got " <> T.pack (show outs)) + Nothing -> Fail "dep .drv missing from inputDrvs despite the deep drvPath ref" + other -> Fail ("expected dep drvPath and main's derivation, got " <> T.pack (show other)) + ] + +-- | @passAsFile@ on the value a build writes and spawns from, upstream's +-- @initTmpDir@ (local-derivation-goal.cc at 2.24.9). The file name for +-- @foo@ is the one upstream's own test pins +-- (@tests\/functional\/pass-as-file.sh@ at 2.24.9). +testPassAsFile :: IO [Bool] +testPassAsFile = do + putStrLn "builder/passAsFile" + sequence + [ runTest "an attribute passAsFile names becomes upstream's file and a Path variable" $ + assertRight "delivery" (deliver [("foo", "xyzzy"), ("passAsFile", "foo")]) $ \delivery -> + assertEqual "files" [(fooFile, "xyzzy")] (adFiles delivery) + `andThen` assertEqual "fooPath" (Just (T.pack fooFile)) (Map.lookup "fooPath" (adEnv delivery)) + `andThen` assertEqual "foo" Nothing (Map.lookup "foo" (adEnv delivery)) + `andThen` assertEqual "passAsFile" (Just "foo") (Map.lookup "passAsFile" (adEnv delivery)), + -- Upstream's tokenizer splits at space, tab, newline and carriage + -- return only, so the vertical tab leaves one name, "e\vf", that no + -- attribute has. + runTest "passAsFile splits at upstream's separators and skips absent names" $ + let attrs = [(name, "v") | name <- ["a", "b", "c", "d", "e", "f"]] + in assertRight "delivery" (deliver (("passAsFile", "a\tb\nc\rd e\vf missing") : attrs)) $ \delivery -> + assertEqual "path variables" ["aPath", "bPath", "cPath", "dPath"] (filter ("Path" `T.isSuffixOf`) (Map.keys (adEnv delivery))) + `andThen` assertEqual "files" 4 (length (adFiles delivery)) + `andThen` assertEqual "kept" [Just "v", Just "v"] (map (`Map.lookup` adEnv delivery) ["e", "f"]), + runTest "an attribute called Path keeps its own value" $ + assertRight "delivery" (deliver [("foo", "x"), ("fooPath", "literal"), ("passAsFile", "foo")]) $ \delivery -> + assertEqual "fooPath" (Just "literal") (Map.lookup "fooPath" (adEnv delivery)) + `andThen` assertEqual "files" [(fooFile, "x")] (adFiles delivery), + -- The derivation's out is the final path; the build writes elsewhere + -- when that path is already valid, and the file says where. + runTest "an output passed as a file leaves the environment for the path it is written to" $ + assertRight "delivery" (deliver [("out", "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-p"), ("passAsFile", "out")]) $ \delivery -> + assertEqual "out" Nothing (Map.lookup "out" (adEnv delivery)) + `andThen` case Map.lookup "outPath" (adEnv delivery) of + Just path -> assertEqual "files" [(T.unpack path, TE.encodeUtf8 (T.pack scratchOut))] (adFiles delivery) + Nothing -> Fail "no outPath variable", + runTest "a value passed as a file stays bytes" $ + assertRight "as a file" (deliver [("foo", "\xff\xfe"), ("passAsFile", "foo")]) (assertEqual "files" [(fooFile, "\xff\xfe")] . adFiles) + `andThen` assertLeft "as a variable" (deliver [("foo", "\xff\xfe")]), + runTest "structured attributes ignore passAsFile" $ + let json = "{\"foo\":\"xyzzy\",\"passAsFile\":[\"foo\"]}" + in assertRight "delivery" (deliver [("__json", json), ("foo", "xyzzy"), ("passAsFile", "foo")]) $ \delivery -> + assertEqual "files" [buildDir ".attrs.json", buildDir ".attrs.sh"] (map fst (adFiles delivery)) + `andThen` assertEqual "variables" ["NIX_ATTRS_JSON_FILE", "NIX_ATTRS_SH_FILE"] (Map.keys (adEnv delivery)), + -- The law passAsFile exists for: moving an attribute from the + -- environment to a file changes where the builder reads it, not what + -- it reads. The store directories include one ending in /nix/store, + -- which a rewrite applied twice would mangle. + runTestM "an attribute's file holds the bytes its variable would have held" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll ((,) <$> QC.elements storeDirs <*> genRewritable) $ \(dir, value) -> + let config = defaultBuildConfig (StoreDir dir) + bytes = TE.encodeUtf8 value + in case (deliverWith config [("foo", bytes)], deliverWith config [("foo", bytes), ("passAsFile", "foo")]) of + (Right variable, Right file) -> + let found = lookup fooFile (adFiles file) + in QC.counterexample "no file" (isJust found) + QC..&&. ((TE.encodeUtf8 <$> Map.lookup "foo" (adEnv variable)) QC.=== found) + _ -> QC.counterexample "delivery failed" False + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + where + buildDir = "/build" + fooFile = buildDir ".attr-1bp7cri8hplaz6hbz0v4f0nl44rl84q1sg25kgwqzipzd1mv89ic" + scratchOut = "/scratch/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-p" + outputDirs = [("out", scratchOut), ("dev", "/scratch/cccccccccccccccccccccccccccccccc-p-dev")] + deliverWith config env = + attrsDelivery config (mkTestBuildDrv "sh" (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "p") "") {drvEnv = Map.fromList env} buildDir outputDirs + deliver = deliverWith (defaultBuildConfig defaultStoreDir) + storeDirs = ["/nix/store", "/home/user/nix/store", "C:\\nix\\store"] + genRewritable = + T.concat + <$> QC.listOf + ( QC.elements + [ "/nix/store/", + "/nix/store/dddddddddddddddddddddddddddddddd-dep", + hashPlaceholder "out", + hashPlaceholder "dev", + hashPlaceholder "lib", + "/", + " ", + "\\", + "a", + "\233", + "\128512" + ] + ) + +-- --------------------------------------------------------------------------- +-- Tests: Store.DB (Phase 2, Batch 1) +-- --------------------------------------------------------------------------- + +-- | Helper: run a test with a temporary store DB, cleaning up after. +withTempStoreDB :: (StoreDir -> IO [Bool]) -> IO [Bool] +withTempStoreDB action = do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-store-db" + removeIfExists tmpStore + createDirectoryIfMissing True tmpStore + results <- action (StoreDir tmpStore) + removeIfExists tmpStore + pure results + +removeIfExists :: FilePath -> IO () +removeIfExists path = do + exists <- doesDirectoryExist path + when exists (removeDirectoryRecursive path) + +-- | Names a directory on a case-sensitive volume for +-- 'testCaseSensitiveVolumeIO'. A Linux temp directory qualifies on +-- its own; on macOS a "Case-sensitive APFS" image attached with +-- hdiutil does, and the default volume does not. +caseSensitiveDirVar :: String +caseSensitiveDirVar = "NOVA_NIX_TEST_CASE_SENSITIVE_DIR" + +-- | True-name materialization on a volume that does not fold: a store +-- opened there probes sensitive, and a NAR carrying @Makefile@ and +-- @makefile@ unpacks to two files under their own names through the +-- strict and the streaming substituter paths alike. A directory named +-- by 'caseSensitiveDirVar' is held to the claim: one that is missing +-- or probes folding FAILS, since the variable is how a run asserts a +-- volume (macOS CI attaches an image for it) and a typo must not read +-- as "no volume available". With the variable unset the temp +-- directory is tried, and skips where it folds. +testCaseSensitiveVolumeIO :: IO [Bool] +testCaseSensitiveVolumeIO = do + putStrLn "store/case-sensitive-volume" + named <- lookupEnv caseSensitiveDirVar + case named of + Just base -> do + verdict <- namedDirVerdict base + case verdict of + Right () -> testCaseSensitiveVolumeBody base + Left reason -> + (: []) <$> runTest (T.pack caseSensitiveDirVar <> " names a case-sensitive directory") (Fail reason) + Nothing -> do + tmpBase <- getTemporaryDirectory + sensitivity <- probeCaseSensitivity tmpBase + case sensitivity of + CaseInsensitive -> do + putStrLn (" SKIP needs a case-sensitive volume (" ++ caseSensitiveDirVar ++ " names a directory on one)") + pure [] + CaseSensitive -> testCaseSensitiveVolumeBody tmpBase + where + namedDirVerdict base = do + present <- doesDirectoryExist base + if not present + then pure (Left (T.pack base <> " does not exist")) + else do + sensitivity <- probeCaseSensitivity base + pure $ case sensitivity of + CaseSensitive -> Right () + CaseInsensitive -> Left (T.pack base <> " probes " <> T.pack (show CaseInsensitive)) + +testCaseSensitiveVolumeBody :: FilePath -> IO [Bool] +testCaseSensitiveVolumeBody base = do + let storeRoot = base "nova-nix-test-cs-store" + storeDir = StoreDir storeRoot + tree = + NAR.NarDirectory + [ ("Makefile", NAR.NarRegular False "upper"), + ("makefile", NAR.NarRegular False "lower") + ] + rawNar = NAR.serialise tree + digest = CHash.hashBytes rawNar + narInfoOf nar sp = + NarInfo.NarInfo + { NarInfo.niStorePath = storePathToText defaultStoreDir sp, + NarInfo.niUrl = "nar/case.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes nar), + NarInfo.niNarSize = fromIntegral (BS.length nar), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + narInfoFor = narInfoOf rawNar + -- A name carrying the case-hack suffix beside the name it would + -- strip to: read with the suffix stripped, the two collide. + suffixTree = + NAR.NarDirectory + [ ("Makefile", NAR.NarRegular False "upper"), + ("Makefile~nix~case~hack~1", NAR.NarRegular False "literal") + ] + suffixNar = NAR.serialise suffixTree + suffixNames sp = do + names <- sort <$> Dir.listDirectory (storePathToFilePath storeDir sp) + pure (assertEqual "on-disk names" ["Makefile", "Makefile~nix~case~hack~1"] names) + -- Both spellings present with their own contents, and nothing + -- carrying the case-hack suffix. + trueNames sp = do + let dest = storePathToFilePath storeDir sp + names <- Dir.listDirectory dest + upper <- BS.readFile (dest "Makefile") + lower <- BS.readFile (dest "makefile") + pure $ + if sort names == ["Makefile", "makefile"] && upper == "upper" && lower == "lower" + then Pass + else Fail ("on disk: " <> T.pack (show names)) + forceRemoveIfExists storeRoot + store <- openStore storeDir + results <- + sequence + [ runTest "the store probes its volume as case-sensitive" $ + assertEqual "stCaseSensitivity" CaseSensitive (stCaseSensitivity store), + runTestM "strict substitution materializes true names" $ do + let sp = StorePath (T.replicate 32 "c") "case-strict" + result <- Subst.unpackAndVerify store sp (narInfoFor sp) rawNar + case result of + Subst.SubstSuccess _ lock -> do + releasePathLock lock + trueNames sp + other -> pure (Fail ("substitution failed: " <> T.pack (show other))), + runTestM "streaming substitution materializes true names" $ do + let sp = StorePath (T.replicate 32 "d") "case-stream" + source <- chunkReader [rawNar] + result <- Subst.materializeNarFromSource store sp (narInfoFor sp) digest [] Nothing source + case result of + Right _ -> trueNames sp + Left err -> pure (Fail ("streaming substitution failed: " <> Subst.attemptFailureMessage err)), + -- Nothing on a volume that keeps names apart is ever hacked, so + -- a name carrying the suffix is a name like any other: both + -- pipelines accept it, and their on-disk rechecks read it back + -- as spelled (#236). + runTestM "a name carrying the case-hack suffix substitutes verbatim, strict" $ do + let sp = StorePath (T.replicate 32 "e") "suffix-strict" + result <- Subst.unpackAndVerify store sp (narInfoOf suffixNar sp) suffixNar + case result of + Subst.SubstSuccess _ lock -> do + releasePathLock lock + suffixNames sp + other -> pure (Fail ("substitution failed: " <> T.pack (show other))), + runTestM "a name carrying the case-hack suffix substitutes verbatim, streaming" $ do + let sp = StorePath (T.replicate 32 "f") "suffix-stream" + source <- chunkReader [suffixNar] + result <- Subst.materializeNarFromSource store sp (narInfoOf suffixNar sp) (CHash.hashBytes suffixNar) [] Nothing source + case result of + Right _ -> suffixNames sp + Left err -> pure (Fail ("streaming substitution failed: " <> Subst.attemptFailureMessage err)), + -- A store path already on this volume is read back as spelled + -- too: an evaluation write holding the name reproduces its + -- address and registers the NAR upstream dumps for it with + -- use-case-hack off ('suffixPairNarHash'). + runTestM "a store path naming a file with the case-hack suffix registers under that name" $ + case makeFixedOutputPath "suffix-write" "sha256" "recursive" (sha256Digest suffixNar) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let dest = storePathToFilePath storeDir sp + createDirectoryIfMissing True dest + BS.writeFile (dest "Makefile") "upper" + BS.writeFile (dest "Makefile~nix~case~hack~1") "literal" + materializeEvalStoreWrites store (Map.singleton (storePathToText defaultStoreDir sp) ([], WriteRecursive)) + info <- queryPathInfo (stDB store) sp + pure $ case info of + Just row -> assertEqual "registered NAR hash" suffixPairNarHash (piNarHash row) + Nothing -> Fail "not registered", + -- Evaluation reads a store path as the store does: copying one + -- holding the name hashes it as spelled, where a source read + -- would follow the process and, on macOS, strip it. + runTestM "builtins.path reads a store path under its volume's case-hack mode" $ do + let held = StorePath (T.replicate 32 "g") "suffix-read" + heldPath = storePathToFilePath storeDir held + createDirectoryIfMissing True heldPath + BS.writeFile (heldPath "Makefile") "upper" + BS.writeFile (heldPath "Makefile~nix~case~hack~1") "literal" + copied <- + evalNixIOStore + storeDir + "." + ("builtins.path { path = " <> storePathToText defaultStoreDir held <> "; name = \"suffix-copy\"; }") + let expected = storePathToText defaultStoreDir <$> makeFixedOutputPath "suffix-copy" "sha256" "recursive" (sha256Digest suffixNar) + case (copied, expected) of + (Right (VStr pathBytes _), Right expectedPath) + | bytesText pathBytes /= expectedPath -> pure (Fail ("copied to " <> bytesText pathBytes <> ", expected " <> expectedPath)) + | otherwise -> maybe (pure (Fail "unparseable store path")) suffixNames (parseStorePath defaultStoreDir expectedPath) + (Left err, _) -> pure (Fail ("eval failed: " <> err)) + other -> pure (Fail ("unexpected result: " <> T.pack (show other))), + -- A source tree copied off this volume into one that folds the + -- sharp-s pair: the two names are distinct here and one name + -- there, so the copy refuses the second at the write rather + -- than landing it on the first (#234). + runTestM "a copy into a volume that folds a pair refuses the later name" $ do + probed <- tempFoldsSharpS + case probed of + Left reason -> Pass <$ putStrLn (" SKIP " ++ reason) + Right tmpBase -> do + let src = base "nova-nix-test-cs-copy-src" + dest = tmpBase "nova-nix-test-cs-copy-dest" + contents = Map.fromList [(T.unpack sharpSUpper, "upper"), (T.unpack sharpSLower, "lower")] + forceRemoveIfExists src + Subst.clearStaleDestination dest + createDirectoryIfMissing True src + mapM_ (\(name, bytes) -> BS.writeFile (src name) bytes) (Map.toList contents) + -- The copy walks the listing's order, which the volume + -- chooses, so the refused name is whichever comes second. + listed <- Dir.listDirectory src + outcome <- try (copyPathInto src dest) + landed <- traverse (\name -> (,) name <$> BS.readFile (dest name)) (take 1 listed) + forceRemoveIfExists src + Subst.clearStaleDestination dest + pure $ case (listed, outcome) of + ([earlier, later], Left (e :: IOException)) + | T.pack (ioeGetErrorString e) /= "creating file '" <> quotedAsCxx (dest later) <> "': File exists" -> + Fail ("unexpected refusal: " <> T.pack (show e)) + | landed /= [(earlier, Map.findWithDefault "" earlier contents)] -> + Fail ("the earlier entry was overwritten: " <> T.pack (show landed)) + | otherwise -> Pass + (_, Right ()) -> Fail ("the copy succeeded; on disk: " <> T.pack (show landed)) + other -> Fail ("unexpected listing or outcome: " <> T.pack (show other)), + -- A source holding a case-only pair, built against a store + -- whose volume folds: evaluation names the two-file tree, and + -- the store holds it as upstream's restore does, the later + -- name case-hacked, registered under that address (#235). + runTestM "a coerced source's case-only pair is stored case-hacked on a folding store" $ + caseOnlyPairBuild base canonPathValue, + runTestM "builtins.path stores a case-only pair case-hacked on a folding store" $ + caseOnlyPairBuild base (\srcPath -> "builtins.path { path = " <> canonPathValue srcPath <> "; }") + ] + closeStore store + forceRemoveIfExists storeRoot + pure results + +-- | What upstream records for 'caseOnlyPairBuild''s source on a +-- folding volume: nix-instantiate 2.33.2 with +-- @--store 'local?root=...'@ adds it at this path, @nix-store +-- --query --hash@ and @--size@ report this NAR hash and size, and the +-- tree holds @Makefile@ and @makefile~nix~case~hack~1@. +caseOnlyPairPath :: StorePath +caseOnlyPairPath = StorePath "1rn1vqr2y9f65qg5vflbfr5gkwllmp22" "src" + +caseOnlyPairNarHash :: Text +caseOnlyPairNarHash = "sha256:04z1mpa501269w2aqjr3kq5k4y85hjzbisvfc3jgmw3dnd7va9hl" + +caseOnlyPairNarSize :: Int +caseOnlyPairNarSize = 480 + +-- | Build a derivation whose @src@ is the given expression over a +-- source directory named @src@ holding @Makefile@ and @makefile@, on a +-- case-sensitive base, against a store in the temp directory, and +-- hold the result to what upstream stores ('caseOnlyPairPath'). Skips +-- where the temp directory's volume does not fold. +caseOnlyPairBuild :: FilePath -> (Text -> Text) -> IO TestResult +caseOnlyPairBuild base srcExpr = do + tmpBase <- getTemporaryDirectory + sensitivity <- probeCaseSensitivity tmpBase + case sensitivity of + CaseSensitive -> Pass <$ putStrLn " SKIP the temp directory's volume does not fold case" + CaseInsensitive -> do + shell <- findTestShell + let srcRoot = base "nova-nix-test-cs-pair" + srcDir = srcRoot "src" + tmpStore = tmpBase "nova-nix-test-cs-pair-store" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + source = + T.concat + [ "derivation { name = \"pair\"; system = builtins.currentSystem; ", + "builder = \"" <> nixEscape shell <> "\"; ", + "args = [\"-c\" \"cd $src && for f in *; do echo \\\"$f\\\"; done > $out\"]; ", + "src = " <> srcExpr (T.pack srcDir) <> "; }" + ] + forceRemoveIfExists srcRoot + forceRemoveIfExists tmpStore + createDirectoryIfMissing True srcDir + BS.writeFile (srcDir "Makefile") "upper\n" + BS.writeFile (srcDir "makefile") "lower\n" + built <- evalAndBuild (StoreDir tmpStore) source + verdict <- case built of + Left err -> pure (Fail err) + Right (BuildFailure msg _, store) -> Fail msg <$ closeStore store + Right (BuildSuccess outSP, store) -> do + let stored = storePathToFilePath (stDir store) caseOnlyPairPath + names <- sort <$> Dir.listDirectory stored + contents <- traverse (BS.readFile . (stored )) names + info <- queryPathInfo (stDB store) caseOnlyPairPath + seen <- BS.readFile (storePathToFilePath (stDir store) outSP) + closeStore store + let hacked = ["Makefile", "makefile~nix~case~hack~1"] + pure $ case info of + Nothing -> Fail "the source path is not registered" + Just row + | names /= hacked || contents /= ["upper\n", "lower\n"] -> + Fail ("stored as " <> T.pack (show (zip names contents))) + | piNarHash row /= caseOnlyPairNarHash || piNarSize row /= caseOnlyPairNarSize -> + Fail ("registered " <> piNarHash row <> " / " <> T.pack (show (piNarSize row))) + | seen /= "Makefile\nmakefile~nix~case~hack~1\n" -> + Fail ("the builder saw " <> T.pack (show seen)) + | otherwise -> Pass + forceRemoveIfExists srcRoot + forceRemoveIfExists tmpStore + pure verdict + +-- | The NAR hash of a directory holding @Makefile@ (@upper@) and +-- @Makefile~nix~case~hack~1@ (@literal@): @nix-store --option +-- use-case-hack false --dump@ 2.33.2 piped to @nix-hash --flat@. With +-- the setting at its macOS default the dump strips the suffix and +-- fails on the collision. +suffixPairNarHash :: Text +suffixPairNarHash = "sha256:1x31cqjvkihkh3wbzq00z8xplwbf7i0bpk3g9vqs403lh3f5b4gs" + +-- | A path as upstream's formatter streams a @std::filesystem::path@: +-- through @std::quoted@, in double quotes with a double quote or a +-- backslash inside escaped by a backslash. +quotedAsCxx :: FilePath -> Text +quotedAsCxx path = "\"" <> T.replace "\"" "\\\"" (T.replace "\\" "\\\\" (T.pack path)) <> "\"" + +-- | U+1E9E (capital sharp s) and U+00DF (small sharp s): a pair APFS +-- folds to one name and 'onDiskNameKey' keeps apart, since 'toUpper' +-- leaves U+00DF as it is (#234). Escaped, as the source is ASCII. +sharpSUpper, sharpSLower :: Text +sharpSUpper = "STRA\x1E9E\&E" +sharpSLower = "stra\xDF\&e" + +-- | Whether the volume holding a directory folds the sharp-s pair, +-- answered by the volume itself: one spelling is created and the other +-- looked up. The store's probe says whether a volume folds case at +-- all, not which pairs its table folds. +sharpSFolds :: FilePath -> IO Bool +sharpSFolds dir = do + let probeDir = dir "nova-nix-test-sharp-s-probe" + Subst.clearStaleDestination probeDir + createDirectoryIfMissing True probeDir + BS.writeFile (probeDir T.unpack sharpSUpper) "probe" + folds <- Dir.doesFileExist (probeDir T.unpack sharpSLower) + Subst.clearStaleDestination probeDir + pure folds + +-- | Whether the suite's temp directory folds the sharp-s pair: the +-- store's own probe first, then the volume for the pair itself. +tempFoldsSharpS :: IO (Either String FilePath) +tempFoldsSharpS = do + tmpBase <- getTemporaryDirectory + sensitivity <- probeCaseSensitivity tmpBase + case sensitivity of + CaseSensitive -> pure (Left "the temp directory's volume does not fold case") + CaseInsensitive -> do + folds <- sharpSFolds tmpBase + pure $ + if folds + then Right tmpBase + else Left "the temp directory's volume folds case but keeps U+1E9E and U+00DF apart" + +-- | A sibling pair the volume folds but 'onDiskNameKey' keeps apart +-- (#234). The exclusive create refuses the later entry at the write, +-- in upstream's wording and naming it, through both unpack paths, and +-- the earlier entry keeps its own content: nothing lands on it, and +-- two directories do not merge. A link needed no new exclusivity +-- (link creation never replaces a name); its refusal is pinned +-- alongside. Skips with the reason where the temp directory's volume +-- does not fold the pair. +testFoldingVolumeIO :: IO [Bool] +testFoldingVolumeIO = do + putStrLn "store/folding-volume" + probed <- tempFoldsSharpS + case probed of + Left reason -> do + putStrLn (" SKIP " ++ reason) + pure [] + Right tmpBase -> testFoldingVolumeBody (tmpBase "nova-nix-test-folding") + +testFoldingVolumeBody :: FilePath -> IO [Bool] +testFoldingVolumeBody root = do + let upperName = T.unpack sharpSUpper + lowerName = T.unpack sharpSLower + pair earlier later = + NAR.NarDirectory [(TE.encodeUtf8 sharpSUpper, earlier), (TE.encodeUtf8 sharpSLower, later)] + filePair = pair (NAR.NarRegular False "upper") (NAR.NarRegular False "lower") + linkPair = pair (NAR.NarRegular False "upper") (NAR.NarSymlink "a") + dirPair = + pair + (NAR.NarDirectory [("a", NAR.NarRegular False "upper")]) + (NAR.NarDirectory [("b", NAR.NarRegular False "lower")]) + dirOverFilePair = pair (NAR.NarRegular False "upper") (NAR.NarDirectory [("b", NAR.NarRegular False "lower")]) + fileRefusal dest = "creating file '" <> quotedAsCxx (dest lowerName) <> "': File exists" + dirRefusal dest = "path '" <> T.pack (dest lowerName) <> "' already exists" + dirOverFileRefusal dest = "creating directory '" <> T.pack (dest lowerName) <> "': File exists" + linkRefusal dest = "creating symlink from '" <> T.pack (dest lowerName) <> "' -> 'a': File exists" + upperFileKept dest = (== "upper") <$> BS.readFile (dest upperName) + upperDirKept dest = (== ["a"]) <$> Dir.listDirectory (dest upperName) + narInfoOf raw = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/" <> T.replicate 32 "f" <> "-folding", + NarInfo.niUrl = "nar/folding.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes raw), + NarInfo.niNarSize = fromIntegral (BS.length raw), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + strictly = unpackNarEntry CaseInsensitive + streamed dest tree = do + let raw = NAR.serialise tree + source <- chunkReader [raw] + outcome <- Subst.consumeNarStream CaseInsensitive dest (narInfoOf raw) (CHash.hashBytes raw) source + pure (either (Left . Subst.attemptFailureMessage) (const (Right ())) outcome) + refusedAtWrite label unpack tree refusal kept = runTestM label $ do + let dest = root "out" + Subst.clearStaleDestination dest + result <- unpack dest tree + earlierKept <- kept dest + Subst.clearStaleDestination dest + pure $ + if earlierKept + then assertEqual "unpack outcome" (Left (refusal dest)) result + else Fail ("the earlier entry was overwritten or merged into; unpack returned " <> T.pack (show result)) + forceRemoveIfExists root + createDirectoryIfMissing True root + results <- + sequence + [ refusedAtWrite "strict unpack refuses the later file of a folded pair" strictly filePair fileRefusal upperFileKept, + refusedAtWrite "streaming unpack refuses the later file of a folded pair" streamed filePair fileRefusal upperFileKept, + refusedAtWrite "strict unpack refuses the later directory of a folded pair" strictly dirPair dirRefusal upperDirKept, + refusedAtWrite "streaming unpack refuses the later directory of a folded pair" streamed dirPair dirRefusal upperDirKept, + refusedAtWrite "strict unpack refuses a directory folding onto a file" strictly dirOverFilePair dirOverFileRefusal upperFileKept, + refusedAtWrite "streaming unpack refuses a directory folding onto a file" streamed dirOverFilePair dirOverFileRefusal upperFileKept, + refusedAtWrite "a link folding onto an earlier file is refused at the link" strictly linkPair linkRefusal upperFileKept + ] + forceRemoveIfExists root + pure results + +testStoreDB :: IO [Bool] +testStoreDB = do + putStrLn "store/db" + withTempStoreDB $ \storeDir -> + sequence + [ -- open and close without error + runTestM "db open/close" $ do + db <- openStoreDB storeDir + closeStoreDB db + pure Pass, + -- isValidPath returns False for unknown path + runTestM "db isValidPath false for unknown" $ do + db <- openStoreDB storeDir + result <- isValidPath db (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa1" "unknown") + closeStoreDB db + pure (assertEqual "unknown" False result), + -- register + isValidPath returns True + runTestM "db register + isValid" $ do + db <- openStoreDB storeDir + let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa2" "hello" + reg = PathRegistration sp "sha256:abc" 100 Nothing [] + registerPath db reg + result <- isValidPath db sp + closeStoreDB db + pure (assertEqual "registered" True result), + -- A peer's held write transaction must be waited out, not died + -- on: SQLite's default busy timeout is zero, and registration + -- used to crash with an uncaught ErrorBusy SQLError while a + -- second process was mid-commit. Upstream waits + -- (sqlite3_busy_timeout, one hour); this pins that we do too. + runTestM "db registration waits out a busy peer" $ do + db <- openStoreDB storeDir + let dbPath = unStoreDir storeDir metaDirName dbFileName + peer <- SQL.open dbPath + SQL.execute_ peer "BEGIN IMMEDIATE" + released <- newEmptyMVar + _ <- forkIO $ do + threadDelay 300000 + SQL.execute_ peer "COMMIT" + SQL.close peer + putMVar released () + let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa3" "busywait" + registerPath db (PathRegistration sp "sha256:busy" 10 Nothing []) + takeMVar released + result <- isValidPath db sp + closeStoreDB db + pure (assertEqual "registered after the peer released" True result), + -- register with refs + query + runTestM "db register with refs + query" $ do + db <- openStoreDB storeDir + let ref1 = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "dep1" + ref2 = StorePath "cccccccccccccccccccccccccccccccc" "dep2" + mainSp = StorePath "dddddddddddddddddddddddddddddddd" "mainpkg" + registerPath db (PathRegistration ref1 "sha256:r1" 50 Nothing []) + registerPath db (PathRegistration ref2 "sha256:r2" 60 Nothing []) + registerPath db (PathRegistration mainSp "sha256:m1" 200 Nothing [ref1, ref2]) + refs <- queryReferences db mainSp + closeStoreDB db + let ref1Path = T.pack (storePathToFilePath storeDir ref1) + ref2Path = T.pack (storePathToFilePath storeDir ref2) + hasRef1 = ref1Path `elem` refs + hasRef2 = ref2Path `elem` refs + pure $ + if hasRef1 && hasRef2 + then Pass + else Fail ("expected refs to contain both deps, got: " <> T.pack (show refs)), + -- Re-registration replaces the edge set: the refresh contract + -- covers references too, and a union would over-report into + -- pushed narinfos. + runTestM "db re-register replaces refs" $ do + db <- openStoreDB storeDir + let refA = StorePath "gggggggggggggggggggggggggggggggg" "refresh-a" + refB = StorePath "hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh" "refresh-b" + sp = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" "refresh-main" + registerPaths + db + [ PathRegistration refA "sha256:ra" 10 Nothing [], + PathRegistration refB "sha256:rb" 11 Nothing [], + PathRegistration sp "sha256:rm" 12 Nothing [refA, refB] + ] + registerPath db (PathRegistration sp "sha256:rm" 12 Nothing [refA]) + refs <- queryReferences db sp + closeStoreDB db + let refAPath = T.pack (storePathToFilePath storeDir refA) + refBPath = T.pack (storePathToFilePath storeDir refB) + pure $ + if refAPath `elem` refs && refBPath `notElem` refs + then Pass + else Fail ("expected only refresh-a after re-register, got: " <> T.pack (show refs)), + -- A reference to an unregistered path is a loud error: a silently + -- dropped edge under-reports narinfos and hands a future GC + -- permission to delete a live dependency. The refusal is + -- upstream's queryValidPathId message, naming the reference under + -- /nix/store though this store is kept elsewhere, and the batch + -- records nothing. + runTestM "db register with an unregistered ref is refused in upstream's words" $ do + db <- openStoreDB storeDir + let ghost = StorePath "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj" "ghost" + sp = StorePath "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk" "orphan-edge" + outcome <- try (registerPath db (PathRegistration sp "sha256:oe" 13 Nothing [ghost])) + recorded <- isValidPath db sp + closeStoreDB db + pure $ case outcome of + Left (err :: IOException) -> + assertEqual + "refusal" + ("path '/nix/store/jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj-ghost' is not valid", False) + (ioeGetErrorString err, recorded) + Right () -> Fail "expected registration to throw on an unregistered reference", + -- Of several unregistered references the refusal names the one + -- upstream's does: the batch in path order, then each path's + -- references in path order. The list order would name ghost-a, + -- and so would the least unregistered path overall. + runTestM "db refusal names the first unregistered ref in upstream's order" $ do + db <- openStoreDB storeDir + let ghostA = StorePath "22222222222222222222222222222222" "ghost-a" + ghostB = StorePath "33333333333333333333333333333333" "ghost-b" + ghostC = StorePath "44444444444444444444444444444444" "ghost-c" + early = StorePath "mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm" "early" + late = StorePath "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" "late" + outcome <- + try + ( registerPaths + db + [ PathRegistration late "sha256:lt" 14 Nothing [ghostA], + PathRegistration early "sha256:er" 15 Nothing [ghostC, ghostB] + ] + ) + closeStoreDB db + pure $ case outcome of + Left (err :: IOException) -> + assertEqual + "refusal" + "path '/nix/store/33333333333333333333333333333333-ghost-b' is not valid" + (ioeGetErrorString err) + Right () -> Fail "expected registration to throw on an unregistered reference", + -- queryDeriver nothing + runTestM "db queryDeriver nothing" $ do + db <- openStoreDB storeDir + let sp = StorePath "cccccccccccccccccccccccccccccccc" "noderiver" + registerPath db (PathRegistration sp "sha256:nd" 80 Nothing []) + result <- queryDeriver db sp + closeStoreDB db + pure (assertEqual "no deriver" Nothing result), + -- queryDeriver just + runTestM "db queryDeriver just" $ do + db <- openStoreDB storeDir + let sp = StorePath "ffffffffffffffffffffffffffffffff" "hasdrv" + registerPath db (PathRegistration sp "sha256:hd" 90 (Just "/nix/store/xxx.drv") []) + result <- queryDeriver db sp + closeStoreDB db + pure (assertEqual "has deriver" (Just "/nix/store/xxx.drv") result), + -- queryPathInfo + runTestM "db queryPathInfo" $ do + db <- openStoreDB storeDir + let sp = StorePath "gggggggggggggggggggggggggggggggg" "infotest" + registerPath db (PathRegistration sp "sha256:info" 150 (Just "/drv") []) + minfo <- queryPathInfo db sp + closeStoreDB db + pure $ case minfo of + Nothing -> Fail "expected PathInfo but got Nothing" + Just info -> + if piNarHash info == "sha256:info" + && piNarSize info == 150 + && piDeriver info == Just "/drv" + then Pass + else Fail ("bad PathInfo: " <> T.pack (show info)), + -- queryPathInfo for unknown returns Nothing + runTestM "db queryPathInfo unknown" $ do + db <- openStoreDB storeDir + minfo <- queryPathInfo db (StorePath "hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh" "nope") + closeStoreDB db + pure (assertEqual "no info" Nothing minfo), + -- double register is idempotent + runTestM "db double register idempotent" $ do + db <- openStoreDB storeDir + let sp = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" "double" + reg = PathRegistration sp "sha256:dup" 120 Nothing [] + registerPath db reg + registerPath db reg + result <- isValidPath db sp + closeStoreDB db + pure (assertEqual "still valid" True result), + -- multi-path reference graph + runTestM "db multi-path reference graph" $ do + db <- openStoreDB storeDir + let spA = StorePath "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj" "a" + spB = StorePath "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk" "b" + spC = StorePath "llllllllllllllllllllllllllllllll" "c" + registerPath db (PathRegistration spA "sha256:a" 10 Nothing []) + registerPath db (PathRegistration spB "sha256:b" 20 Nothing [spA]) + registerPath db (PathRegistration spC "sha256:c" 30 Nothing [spA, spB]) + refsC <- queryReferences db spC + refsA <- queryReferences db spA + closeStoreDB db + let aPath = T.pack (storePathToFilePath storeDir spA) + bPath = T.pack (storePathToFilePath storeDir spB) + pure $ + if length refsC == 2 && aPath `elem` refsC && bPath `elem` refsC && null refsA + then Pass + else Fail ("bad ref graph: c refs=" <> T.pack (show refsC) <> " a refs=" <> T.pack (show refsA)) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Store Operations + parseStorePath (Phase 2, Batch 2) +-- --------------------------------------------------------------------------- + +testParseStorePath :: IO [Bool] +testParseStorePath = do + putStrLn "store/parseStorePath" + let sd = defaultStoreDir + sequence + [ runTest "parse valid store path" $ + assertEqual + "valid" + (Just (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello-2.12")) + (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-2.12"), + runTest "parse missing prefix" $ + assertEqual "no prefix" Nothing (parseStorePath sd "/tmp/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello"), + runTest "parse too short hash" $ + assertEqual "short hash" Nothing (parseStorePath sd "/nix/store/aaa-hello"), + runTest "parse missing dash after hash" $ + assertEqual "no dash" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaahello"), + runTest "parse empty name" $ + assertEqual "empty name" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-"), + runTest "parse windows store path" $ + assertEqual + "windows" + (Just (StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "pkg")) + (parseStorePath windowsStoreDir "C:\\nix\\store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-pkg"), + -- The backslash separator is the form storePathToFilePath actually + -- produces on Windows (what %out% and DB rows look like there). + runTest "parse windows store path with backslash separator" $ + assertEqual + "windows-backslash" + (Just (StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "pkg")) + (parseStorePath windowsStoreDir "C:\\nix\\store\\bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-pkg"), + -- Charset gates (upstream's parse-boundary checks): the hash slot + -- accepts only nix-base32 (no e o u t), and the name only + -- [A-Za-z0-9+._?=-] - parsed text can come from a cache, and an + -- unchecked component would later become a filesystem path. + runTest "parse rejects non-base32 hash" $ + assertEqual "e-hash" Nothing (parseStorePath sd ("/nix/store/" <> T.replicate 32 "e" <> "-hello")), + runTest "parse rejects traversal text in hash slot" $ + assertEqual "traversal-hash" Nothing (parseStorePath sd ("/nix/store/" <> T.replicate 16 ".\\" <> "-x")), + runTest "parse rejects separator in name" $ + assertEqual "sep-name" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-he/llo"), + runTest "parse rejects dot-dot name" $ + assertEqual "dotdot-name" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-.."), + runTest "parse rejects overlong name" $ + assertEqual "overlong-name" Nothing (parseStorePath sd ("/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-" <> T.replicate 212 "x")), + runTest "parse accepts the full name charset" $ + assertEqual + "name-specials" + (Just (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "gcc-13.2.0_pre+x?=")) + (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-gcc-13.2.0_pre+x?="), + -- The first dash-separated component of a name may not be . or .. + -- (upstream checkName): the traversal names' .- / ..- prefixed forms + -- are rejected while other dot-leading names stay valid. + runTest "parse rejects a .- first component" $ + assertEqual "dot-dash" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-.-cfg"), + runTest "parse rejects a ..- first component" $ + assertEqual "dotdot-dash" Nothing (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-..-cfg"), + runTest "parse accepts a dot-leading name" $ + assertEqual + "dot-leading" + (Just (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ".config-1.0")) + (parseStorePath sd "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-.config-1.0") + ] + +-- --------------------------------------------------------------------------- +-- Tests: Push (pure narinfo construction + closure computation) +-- --------------------------------------------------------------------------- + +testPushPure :: IO [Bool] +testPushPure = do + putStrLn "push/narinfo" + let hashA = T.replicate 32 "a" + hashB = T.replicate 32 "b" + spA = StorePath hashA "hello-1.0" + spB = StorePath hashB "dep-2.0" + narHash = "sha256:0123abcdef" + narBytes = BS.replicate 1234 0x6e + artifactNone = mkPushArtifact PushNone narHash narBytes + artifactZstd = mkPushArtifact PushZstd narHash narBytes + -- References deliberately unsorted; deriver present. + ni = mkNarInfo artifactNone spA [spB, spA] (Just spB) + niZstd = mkNarInfo artifactZstd spA [spB, spA] (Just spB) + sequence + [ runTest "narinfo StorePath is canonical /nix/store" $ + assertEqual "StorePath" ("/nix/store/" <> hashA <> "-hello-1.0") (NarInfo.niStorePath ni), + runTest "narinfo URL is nar/.nar" $ + assertEqual "URL" "nar/0123abcdef.nar" (NarInfo.niUrl ni), + runTest "compression none mirrors NAR fields into file fields" $ + assertEqual + "file fields" + ("none", Just (NarInfo.niNarHash ni), Just (NarInfo.niNarSize ni)) + (NarInfo.niCompression ni, NarInfo.niFileHash ni, NarInfo.niFileSize ni), + runTest "narinfo sizes carry through" $ + assertEqual "NarSize" 1234 (NarInfo.niNarSize ni), + -- The zstd artifact: file fields describe the compressed object, + -- named by its own file hash, while the NAR fields stay the + -- archive's - and the substituter's strict decoder round-trips + -- the bytes under the declared NarSize bound. + runTest "zstd artifact declares the compressed object" $ + assertEqual + "zstd fields" + ("zstd", Just (paFileHash artifactZstd), Just (fromIntegral (paFileSize artifactZstd)), 1234) + (NarInfo.niCompression niZstd, NarInfo.niFileHash niZstd, NarInfo.niFileSize niZstd, NarInfo.niNarSize niZstd), + -- Ground truth, not field copying: the file fields must equal + -- independent computation over the artifact's actual bytes, and + -- must NOT collapse into the NAR fields (the copy-paste hazard + -- for a compressible input like this one). + runTest "zstd file fields are computed from the compressed bytes" $ + let independentHash = CHash.formatNixHash (CHash.hashBytes (paBytes artifactZstd)) + in if paFileHash artifactZstd == independentHash + && paFileSize artifactZstd == BS.length (paBytes artifactZstd) + && paFileHash artifactZstd /= narHash + && paFileSize artifactZstd /= BS.length narBytes + then Pass + else Fail "zstd file fields do not match the compressed bytes", + runTest "none artifact IS the NAR" $ + if paBytes artifactNone == narBytes + && paFileHash artifactNone == narHash + && paFileSize artifactNone == BS.length narBytes + then Pass + else Fail "none artifact diverges from its NAR", + runTest "zstd object is named by its independently computed file hash" $ + assertEqual + "zstd URL" + ("nar/" <> stripHashPrefix (CHash.formatNixHash (CHash.hashBytes (paBytes artifactZstd))) <> ".nar.zst") + (NarInfo.niUrl niZstd), + -- mkNarInfo cannot be handed NAR fields that disagree with the + -- artifact: they now come from the artifact itself. + runTest "narinfo NAR fields come from the artifact" $ + assertEqual + "NAR fields" + (narHash, toInteger (BS.length narBytes)) + (NarInfo.niNarHash niZstd, NarInfo.niNarSize niZstd), + runTestM "zstd artifact round-trips through the substituter decoder" $ do + out <- Subst.decompressNar 1234 "zstd" (paBytes artifactZstd) + pure (assertEqual "push-substitute roundtrip" (Right narBytes) out), + -- The CLI vocabulary is the wire vocabulary, parsed in one place. + runTest "parsePushCompression accepts the register and rejects by name" $ + case (parsePushCompression "none", parsePushCompression "zstd", parsePushCompression "brotli") of + (Right PushNone, Right PushZstd, Left err) + | "none, zstd" `T.isInfixOf` err -> Pass + other -> Fail ("unexpected parse outcomes: " <> T.pack (show other)), + runTest "references are sorted basenames" $ + assertEqual + "References" + [hashA <> "-hello-1.0", hashB <> "-dep-2.0"] + (NarInfo.niReferences ni), + runTest "deriver renders as a basename" $ + assertEqual "Deriver" (Just (hashB <> "-dep-2.0")) (NarInfo.niDeriver ni), + runTest "no client-side signatures" $ + assertEqual "Sigs" ([] :: [Text]) (NarInfo.niSigs ni), + -- The first main run of the cache job pushed a store's first valid + -- path alphabetically, a .drv, and the cache refused its narinfo: + -- a store registers recipes as valid paths, a cache serves outputs. + runTest "outputPathsOnly drops derivations and keeps everything else" $ + assertEqual + "outputs" + ["hello", "hello.drv.tar", "src"] + (map spName (outputPathsOnly [StorePath (T.replicate 32 "a") "hello", StorePath (T.replicate 32 "b") "hello.drv", StorePath (T.replicate 32 "c") "hello.drv.tar", StorePath (T.replicate 32 "d") "src"])), + runTest "isDerivationPath is the .drv suffix on the name, not the hash" $ + assertEqual "drv" [True, False, False] (map isDerivationPath [StorePath (T.replicate 32 "a") "x.drv", StorePath (T.replicate 32 "b") "x", StorePath (T.replicate 32 "c") "drv"]), + runTest "planMissing keeps only uncached paths" $ + assertEqual + "missing" + [hashB] + (map spHash (planMissing (Set.singleton hashA) [spA, spB])), + runTest "stripHashPrefix drops the algo tag" $ + assertEqual "tagged" "deadbeef" (stripHashPrefix "sha256:deadbeef"), + runTest "stripHashPrefix tolerates a bare digest" $ + assertEqual "bare" "deadbeef" (stripHashPrefix "deadbeef"), + runTest "storePathBasename joins hash and name" $ + assertEqual "basename" (hashA <> "-hello-1.0") (storePathBasename spA), + runTest "narFileName appends .nar" $ + assertEqual "file" "0123abcdef.nar" (narFileName narHash), + -- checkRecordedNarHash: the pre-upload integrity gate + runTest "push gate accepts a registered matching path" $ + assertEqual + "gate ok" + (Right ()) + (checkRecordedNarHash (Just (pathInfoFor narHash)) narHash spA), + runTest "push gate refuses an unregistered path" $ + case checkRecordedNarHash Nothing narHash spA of + Left err + | "not registered" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right () -> Fail "unregistered path must not be publishable", + runTest "push gate refuses a changed-on-disk path" $ + case checkRecordedNarHash (Just (pathInfoFor "sha256:other")) narHash spA of + Left err + | "DB recorded" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right () -> Fail "hash mismatch must not be publishable", + -- narHashMatches decodes both spellings before comparing. Today + -- parseNixHash reads only the sha256:nix-base32 spelling, so a + -- base16-recorded digest (both literals spell the empty-string + -- sha256) falls back to text equality and refuses - the safe + -- direction. When the parser learns more spellings (foreign + -- caches), this pin flips and the gate widens with it. + runTest "push gate pins the accepted hash spellings" $ + if narHashMatches + "sha256:e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" + then Fail "base16 spelling unexpectedly matched - widen this pin" + else Pass, + runTest "push gate still refuses different digests" $ + if narHashMatches + "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" + (Hash.formatNixHash (Hash.hashBytes "different")) + then Fail "distinct digests must not match" + else Pass + ] + where + pathInfoFor recordedHash = + PathInfo + { piPath = "/nix/store/" <> T.replicate 32 "a" <> "-hello-1.0", + piNarHash = recordedHash, + piNarSize = 1234, + piDeriver = Nothing, + piRegTime = 0 + } + +-- | Closure computation against a real (temp) store database. +testPushClosureIO :: IO [Bool] +testPushClosureIO = do + putStrLn "push/closure" + withTempStore $ \store -> do + let spTop = StorePath (T.replicate 32 "1") "top" + spMid = StorePath (T.replicate 32 "2") "mid" + spLeaf = StorePath (T.replicate 32 "3") "leaf" + regFor sp refs = + PathRegistration + { prPath = sp, + prNarHash = "sha256:" <> T.replicate 52 "0", + prNarSize = 1, + prDeriver = Nothing, + prReferences = refs + } + registerPaths (stDB store) [regFor spTop [spMid], regFor spMid [spLeaf], regFor spLeaf []] + fromTop <- computeClosure store [spTop] + fromBoth <- computeClosure store [spTop, spLeaf] + sequence + [ runTest "closure walks transitive references" $ + assertRight "fromTop" fromTop $ \closure -> + assertEqual + "hashes" + (Set.fromList (map spHash [spTop, spMid, spLeaf])) + (Set.fromList (map spHash closure)), + runTest "closure deduplicates across roots" $ + assertRight "fromBoth" fromBoth $ \closure -> + assertEqual "count" (3 :: Int) (length closure), + -- loadApiKeyFile: keys copied through Windows editors arrive with + -- a BOM and CRLF; skipping the normalization turns every push + -- into an auth rejection with no visible cause. + runTestM "loadApiKeyFile strips BOM and CRLF" $ do + tmpBase <- getTemporaryDirectory + let keyFile = tmpBase "nova-nix-test-api-key" + BS.writeFile keyFile (BS.pack [0xEF, 0xBB, 0xBF] <> "the-secret-key\r\n") + loaded <- loadApiKeyFile keyFile + Dir.removeFile keyFile + pure (assertEqual "normalized key" (Right "the-secret-key") loaded), + runTestM "loadApiKeyFile rejects an effectively-empty key file" $ do + tmpBase <- getTemporaryDirectory + let keyFile = tmpBase "nova-nix-test-api-key-empty" + BS.writeFile keyFile (BS.pack [0xEF, 0xBB, 0xBF] <> " \r\n") + loaded <- loadApiKeyFile keyFile + Dir.removeFile keyFile + pure $ case loaded of + Left err | "empty" `T.isInfixOf` err -> Pass + other -> Fail ("expected empty-key rejection, got: " <> T.pack (show other)), + runTestM "loadApiKeyFile reports a missing file" $ do + tmpBase <- getTemporaryDirectory + loaded <- loadApiKeyFile (tmpBase "nova-nix-test-no-such-key-file") + pure $ case loaded of + Left err | "cannot read key file" `T.isInfixOf` err -> Pass + other -> Fail ("expected read error, got: " <> T.pack (show other)) + ] + +-- | The case sensitivity of the suite's temp directory, so a test +-- materializing a NAR there keys sibling names the way a store on that +-- volume would. +tempCaseSensitivity :: IO CaseSensitivity +tempCaseSensitivity = getTemporaryDirectory >>= probeCaseSensitivity + +-- | Helper: create a fresh temp store for IO tests. +withTempStore :: (Store -> IO [Bool]) -> IO [Bool] +withTempStore action = do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-store-ops" + forceRemoveIfExists tmpStore + createDirectoryIfMissing True tmpStore + store <- openStore (StoreDir tmpStore) + results <- action store + closeStore store + forceRemoveIfExists tmpStore + pure results + +-- | Recursively restore writable permissions then remove. +-- Needed because addToStore/setReadOnly makes paths read-only. +forceRemoveIfExists :: FilePath -> IO () +forceRemoveIfExists path = do + exists <- doesDirectoryExist path + when exists $ do + restoreWritable path + removeDirectoryRecursive path + +restoreWritable :: FilePath -> IO () +restoreWritable path = do + isDir <- doesDirectoryExist path + when isDir $ do + perms <- getPermissions path + Dir.setPermissions path (Dir.setOwnerWritable True perms) + entries <- Dir.listDirectory path + mapM_ (restoreWritable . (path )) entries + isFile <- Dir.doesFileExist path + when isFile $ do + perms <- getPermissions path + Dir.setPermissions path (Dir.setOwnerWritable True perms) + +-- | Step 1 of the Windows-stdenv ladder: prove the Builder can run a +-- trivial derivation end-to-end natively - a recipe that writes to @$out@, +-- with the output landing in the store. No stdenv, no dependencies: just +-- the raw build path (process spawn, output capture, addToStore), +-- exercised on the host platform (@cmd.exe@ on Windows, @\/bin\/sh@ elsewhere). +testTrivialBuildIO :: IO [Bool] +testTrivialBuildIO = do + putStrLn "builder/trivial-native-build" + withTempStore $ \store -> do + let storeDir = stDir store + outPath = StorePath (T.replicate 31 "0" <> "1") "trivial" + (builder, args) + | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo hi>%out%"]) + | otherwise = ("/bin/sh", ["-c", "echo hi > $out"]) + drv = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = outPath, + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = builder, + drvArgs = args, + drvEnv = Map.empty + } + buildTmp <- ( "nova-nix-test-trivial-build-tmp") <$> getTemporaryDirectory + forceRemoveIfExists buildTmp + createDirectoryIfMissing True buildTmp + let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} + result <- buildDerivation config store drv testDrvPath + forceRemoveIfExists buildTmp + case result of + BuildSuccess sp -> do + let outFile = storePathToFilePath storeDir sp + landed <- Dir.doesFileExist outFile + content <- if landed then TIO.readFile outFile else pure "" + narInfo <- queryPathInfo (stDB store) sp + let realNarHash = case narInfo of + Just info -> + piNarSize info > 0 + && T.isPrefixOf "sha256:" (piNarHash info) + && T.any (/= '0') (T.drop 7 (piNarHash info)) + Nothing -> False + sequence + [ runTest "trivial build succeeds" Pass, + runTest "trivial build output landed in store" $ + if landed then Pass else Fail ("missing output file: " <> T.pack outFile), + runTest "trivial build actually ran the command" $ + if "hi" `T.isInfixOf` content + then Pass + else Fail ("unexpected output content: " <> T.pack (show content)), + runTest "trivial build records a real NAR hash + size" $ + if realNarHash + then Pass + else Fail ("NAR hash/size not real: " <> T.pack (show narInfo)) + ] + BuildFailure msg code -> + sequence + [ runTest "trivial build succeeds" $ + Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + +-- | A builder's standard output and standard error reach the build log +-- together, a line at a time, as upstream's do: one channel for both +-- (local-derivation-goal.cc and child.cc at 2.24.9) and upstream's line +-- discipline over it (@DerivationGoal::handleChildOutput@, +-- derivation-goal.cc). +testBuildLogIO :: IO [Bool] +testBuildLogIO = do + putStrLn "builder/build-log" + shell <- findTestShell + tmpBase <- getTemporaryDirectory + let outPath = StorePath (T.replicate 31 "0" <> "2") "build-log" + tmpStore = tmpBase "nova-nix-test-build-log-store" + buildTmp = tmpBase "nova-nix-test-build-log-tmp" + logFile = tmpBase "nova-nix-test-build-log.txt" + daemonPidFile = tmpBase "nova-nix-test-build-log-daemon.pid" + -- Build in a fresh store with the log a file opened in the given + -- mode, and return the result with the file's bytes. + buildLogged mode drv = do + forceRemoveIfExists tmpStore + forceRemoveIfExists buildTmp + BS.writeFile logFile "" + ( do + result <- + bracket (openStore (StoreDir tmpStore)) closeStore $ \store -> + withBinaryFile logFile mode $ \logHandle -> + buildDerivation (defaultBuildConfig (stDir store)) {bcTmpDir = buildTmp, bcBuildLog = logHandle} store drv testDrvPath + logged <- BS.readFile logFile + pure (result, logged) + ) + `finally` (forceRemoveIfExists tmpStore *> forceRemoveIfExists buildTmp *> Dir.removePathForcibly logFile) + -- Whether or not the build waited for it. + stopDaemon = do + recorded <- Dir.doesFileExist daemonPidFile + when recorded $ do + pid <- BS.readFile daemonPidFile + void (Proc.readProcessWithExitCode "kill" [BS8.unpack (BS8.strip pid)] "") + Dir.removeFile daemonPidFile + -- The host's own shell, so on Windows the lines come from a native + -- program, which ends each one in CRLF. + (nativeBuilder, nativeArgs) + | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo one&echo two>&2&echo three&echo done>%out%"]) + | otherwise = ("/bin/sh", ["-c", "echo one; echo two >&2; echo three; echo done > $out"]) + nativeDrv = (mkTestBuildDrv shell outPath "") {drvBuilder = nativeBuilder, drvArgs = nativeArgs} + failingDrv = + mkTestBuildDrv + shell + outPath + "printf 'out-line\\n'; printf 'err-line\\r\\n' >&2; printf '10%%\\r20%%\\n'; printf 'tail'; exit 3" + -- Records the daemon's PID, so the test can stop it. + daemonDrv = + mkTestBuildDrv + shell + outPath + ( "sleep " + <> T.pack (show daemonLifetimeSeconds) + <> " >/dev/null 2>&1 & echo $! > '" + <> T.pack daemonPidFile + <> "'; mkdir -p $out" + ) + -- Colour, a tab, a screen clear and a bell. + escapesDrv = + mkTestBuildDrv + shell + outPath + "printf 'a\\033[31mred\\033[0m\\tb\\033[2Jc\\a\\n'; mkdir -p $out" + sequence + [ runTest "a line feed ends a build-log line" $ + assertEqual "lines" ["one", "", "two"] (logLinesOf ["one\n\ntwo\n"]), + runTest "a CRLF ends a build-log line without its CR" $ + assertEqual "lines" ["one", "two"] (logLinesOf ["one\r\ntwo\r\n"]), + runTest "a carriage return redraws the build-log line from its start" $ + assertEqual "lines" ["30%", "xycdef"] (logLinesOf ["10%\r20%\r30%\n", "abcdef\rxy\n"]), + runTest "an unterminated last build-log line is flushed when output ends" $ + assertEqual "lines" ["done now"] (logLinesOf ["done", " now"]), + runTest "output ending in a bare carriage return adds no build-log line" $ + assertEqual "lines" [] (logLinesOf ["\r"]), + runTestM "build-log lines are upstream's, however the output is split into reads" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genLogChunks $ \chunks -> + map BS.unpack (logLinesOf chunks) QC.=== upstreamLogLines (concatMap BS.unpack chunks) + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))), + runTest "a terminal's build log keeps colour escapes and drops the rest" $ + assertEqual "line" "\ESC[1;31mred\ESC[0mx0;t" (filterLogLine KeepColour "\ESC[1;31mred\ESC[0m\ESC[2J\ESC[Hx\ESC]0;t\a"), + runTest "a build log that is not a terminal drops every escape" $ + assertEqual "line" "redx0;t" (filterLogLine DropEscapes "\ESC[1;31mred\ESC[0m\ESC[2J\ESC[Hx\ESC]0;t\a"), + runTest "a tab in a build-log line expands to the next tab stop, a UTF-8 character one column" $ + assertEqual + "line" + ("a" <> BS8.replicate 7 ' ' <> "b" <> BS8.replicate 15 ' ' <> "c\xc3\xa9" <> BS8.replicate 6 ' ' <> "d") + (filterLogLine DropEscapes "a\tb\t\tc\xc3\xa9\td"), + runTestM "build-log lines are filtered as upstream's logger filters them" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genEscapeFilter $ \escapes -> + QC.forAll (QC.listOf genEscapeByte) $ \bytes -> + BS.unpack (filterLogLine escapes (BS.pack bytes)) QC.=== upstreamFilterEscapes escapes bytes + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))), + runTestM "a builder's escapes reach a build log that is not a terminal filtered" $ do + (result, logged) <- buildLogged WriteMode escapesDrv + pure $ case result of + BuildSuccess _ -> assertEqual "log" "ared bc\n" logged + BuildFailure msg code -> Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg), + runTestM "a builder's stdout and stderr reach the build log in the order written" $ do + (result, logged) <- buildLogged WriteMode nativeDrv + pure $ case result of + BuildSuccess _ -> assertEqual "log" "one\ntwo\nthree\n" logged + BuildFailure msg code -> Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg), + runTestM "a failed builder's output is in the build log, not its failure" $ do + (result, logged) <- buildLogged WriteMode failingDrv + pure $ case result of + BuildFailure msg code -> + assertEqual "failure and log" ("builder failed", 3, "out-line\nerr-line\n20%\ntail\n") (msg, code, logged) + BuildSuccess _ -> Fail "expected the builder's exit 3 to fail the build", + -- A handle open only for reading refuses every write, as a standard + -- error whose reader has gone does. + runTestM "a build log that refuses its lines does not fail the build" $ do + (result, _) <- buildLogged ReadMode nativeDrv + pure $ case result of + BuildSuccess _ -> Pass + BuildFailure msg code -> Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg), + -- The daemon outlives the deadline, so the build times out if it + -- waits for the daemon, which it would if the builder inherited the + -- pipe beside its standard output and standard error. + runTestM "a daemon that closes stdout and stderr lets the build finish" $ + if SI.os == "mingw32" + then Pass <$ putStrLn " SKIP a Windows build waits for its whole job, a daemon included" + else do + outcome <- timeout daemonDeadlineMicros (buildLogged WriteMode daemonDrv) `finally` stopDaemon + pure $ case outcome of + Nothing -> Fail "the build waited for the daemon to exit" + Just (BuildSuccess _, _) -> Pass + Just (BuildFailure msg code, _) -> Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + where + daemonLifetimeSeconds = 60 :: Int + daemonDeadlineMicros = 10 * 1000 * 1000 + genLogChunks = QC.listOf (BS.pack <$> QC.listOf genLogByte) + genLogByte = QC.frequency [(3, QC.elements [logLineFeed, logCarriageReturn]), (5, QC.elements [0x61, 0x62, 0x63]), (1, QC.arbitrary)] + genEscapeFilter = QC.elements [KeepColour, DropEscapes] + -- Weighted to the bytes escape sequences, tabs and UTF-8 are read by. + genEscapeByte = + QC.frequency + [ (4, QC.elements [logEscape, logCsi, logSgrFinal, 0x3B, 0x31, 0x4A, 0x5D, 0x20, 0x2F]), + (2, QC.elements [logTab, logBell, logCarriageReturn]), + (2, QC.elements [0xC3, 0xE2, 0xF0, 0x80, 0xA9, 0xFF]), + (3, QC.elements [0x61, 0x62]), + (1, QC.arbitrary) + ] + +-- | The lines a builder's output makes when it is read in the chunks +-- given. +logLinesOf :: [BS.ByteString] -> [BS.ByteString] +logLinesOf chunks = + let (pending, completed) = mapAccumL (\partial chunk -> swap (feedBuildLog partial chunk)) emptyPendingLine chunks + in concat completed <> maybeToList (endBuildLog pending) + +-- | Upstream's build-log line discipline, transcribed byte for byte from +-- @DerivationGoal::handleChildOutput@ and @handleEOF@ (derivation-goal.cc +-- at 2.24.9): the oracle the builder's line splitting is held to. +upstreamLogLines :: [Word8] -> [[Word8]] +upstreamLogLines = go [] 0 + where + go line _ [] = [line | not (null line)] + go line pos (byte : rest) + | byte == logCarriageReturn = go line 0 rest + | byte == logLineFeed = line : go [] 0 rest + | otherwise = go (take pos line <> [byte] <> drop (pos + 1) line) (pos + 1) rest + +-- | Upstream's terminal filter, transcribed from @filterANSIEscapes@ +-- (terminal.cc at 2.24.9) at the unlimited width its logger passes: the +-- oracle the build log's filter is held to. +upstreamFilterEscapes :: EscapeFilter -> [Word8] -> [Word8] +upstreamFilterEscapes escapes = go 0 + where + filterAll = escapes == DropEscapes + go :: Int -> [Word8] -> [Word8] + go _ [] = [] + go w (byte : rest) + | byte == logEscape = + let (escapeBytes, final, after) = escape rest + in (if not filterAll && final == Just logSgrFinal then byte : escapeBytes else []) <> go w after + | byte == logTab = + let spaces = 1 + (8 - (w + 1) `mod` 8) `mod` 8 + in replicate spaces 0x20 <> go (w + spaces) rest + | byte == logCarriageReturn || byte == logBell = go w rest + | otherwise = + let (character, after) = utf8Character byte rest + in character <> go (w + 1) after + escape (next : rest) + | next == logCsi = + let (parameters, afterParameters) = span (\b -> b >= 0x30 && b <= 0x3F) rest + (intermediates, afterIntermediates) = span (\b -> b >= 0x20 && b <= 0x2F) afterParameters + in case afterIntermediates of + final : after + | final >= 0x40 && final <= 0x7E -> (next : parameters <> intermediates <> [final], Just final, after) + _ -> (next : parameters <> intermediates, Nothing, afterIntermediates) + | next >= 0x40 && next <= 0x5F = ([next], Nothing, rest) + escape rest = ([], Nothing, rest) + utf8Character lead rest + | lead .&. 0xE0 == 0xC0 = continued 1 + | lead .&. 0xF0 == 0xE0 = continued 2 + | lead .&. 0xF8 == 0xF0 = continued 3 + | otherwise = ([lead], rest) + where + continued count = + let taken = takeWhile (\b -> b .&. 0xC0 == 0x80) (take count rest) + in (lead : taken, drop (length taken) rest) + +-- | The control bytes the build-log tests write and read: line feed, +-- carriage return, escape, tab, bell, and the @[@ and @m@ a colour +-- sequence opens and ends with. +logLineFeed, logCarriageReturn, logEscape, logTab, logBell, logCsi, logSgrFinal :: Word8 +logLineFeed = 0x0A +logCarriageReturn = 0x0D +logEscape = 0x1B +logTab = 0x09 +logBell = 0x07 +logCsi = 0x5B +logSgrFinal = 0x6D + +-- | The builder hands every build a fixed SOURCE_DATE_EPOCH (1980-01-01), +-- the reproducible-builds.org convention that determinism-aware tools +-- (ld's PE timestamp, gcc's __DATE__) honor. Proven behaviorally: a build +-- that echoes the variable into $out must see the pinned value. +testSourceDateEpochIO :: IO [Bool] +testSourceDateEpochIO = do + putStrLn "builder/source-date-epoch" + withTempStore $ \store -> do + let storeDir = stDir store + outPath = StorePath (T.replicate 31 "0" <> "5") "sde-probe" + (builder, args) + | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo %SOURCE_DATE_EPOCH%>%out%"]) + | otherwise = ("/bin/sh", ["-c", "echo $SOURCE_DATE_EPOCH > $out"]) + drv = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = outPath, + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = builder, + drvArgs = args, + drvEnv = Map.empty + } + buildTmp <- ( "nova-nix-test-sde-build-tmp") <$> getTemporaryDirectory + forceRemoveIfExists buildTmp + createDirectoryIfMissing True buildTmp + let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} + result <- buildDerivation config store drv testDrvPath + forceRemoveIfExists buildTmp + case result of + BuildFailure msg code -> + sequence + [ runTest "SOURCE_DATE_EPOCH build succeeds" $ + Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + BuildSuccess sp -> do + content <- TIO.readFile (storePathToFilePath storeDir sp) + sequence + [ runTest "builder pins SOURCE_DATE_EPOCH to 1980-01-01" $ + if "315532800" `T.isInfixOf` content + then Pass + else Fail ("unexpected content: " <> T.pack (show content)) + ] + +-- | The child's environment is the build environment plus the ambient +-- allowlist, nothing else. Proven behaviorally at both ends: an ambient +-- canary set in the test process must not reach a build, and the four +-- temp-directory names must all point at the same build-owned directory. +testScrubbedBuildEnvIO :: IO [Bool] +testScrubbedBuildEnvIO = do + putStrLn "builder/scrubbed-env" + withTempStore $ \store -> do + let storeDir = stDir store + probeDrv name suffix (builder, args) = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = StorePath (T.replicate 31 "0" <> suffix) name, + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = builder, + drvArgs = args, + drvEnv = Map.empty + } + canaryDrv = + probeDrv "env-canary" "6" $ + if SI.os == "mingw32" + then ("cmd.exe", ["/c", "echo %NOVA_NIX_TEST_CANARY%>%out%"]) + else ("/bin/sh", ["-c", "echo \"${NOVA_NIX_TEST_CANARY-scrubbed}\" > $out"]) + quartetDrv = + probeDrv "temp-quartet" "7" $ + if SI.os == "mingw32" + then ("cmd.exe", ["/c", "if \"%TMPDIR%\"==\"%TEMPDIR%\" if \"%TMPDIR%\"==\"%TMP%\" if \"%TMPDIR%\"==\"%TEMP%\" if not \"%TMPDIR%\"==\"\" echo quartet-ok>%out%"]) + else ("/bin/sh", ["-c", "[ -n \"$TMPDIR\" ] && [ \"$TMPDIR\" = \"$TEMPDIR\" ] && [ \"$TMPDIR\" = \"$TMP\" ] && [ \"$TMPDIR\" = \"$TEMP\" ] && echo quartet-ok > $out"]) + buildTmp <- ( "nova-nix-test-scrub-build-tmp") <$> getTemporaryDirectory + forceRemoveIfExists buildTmp + createDirectoryIfMissing True buildTmp + let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} + setEnv "NOVA_NIX_TEST_CANARY" "ambient-leak" + canaryResult <- buildDerivation config store canaryDrv testDrvPath + unsetEnv "NOVA_NIX_TEST_CANARY" + quartetResult <- buildDerivation config store quartetDrv testDrvPath + forceRemoveIfExists buildTmp + sequence + [ runTestM "an undeclared ambient variable does not reach a build" $ + case canaryResult of + BuildFailure msg code -> pure (Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg)) + BuildSuccess sp -> do + content <- TIO.readFile (storePathToFilePath storeDir sp) + pure $ + if "ambient-leak" `T.isInfixOf` content + then Fail ("ambient canary leaked into the build: " <> T.pack (show content)) + else Pass, + runTestM "all four temp names point at the build directory" $ + case quartetResult of + BuildFailure msg code -> pure (Fail ("quartet disagreed or build failed (exit " <> T.pack (show code) <> "): " <> msg)) + BuildSuccess sp -> do + content <- TIO.readFile (storePathToFilePath storeDir sp) + pure $ + if "quartet-ok" `T.isInfixOf` content + then Pass + else Fail ("unexpected content: " <> T.pack (show content)) + ] + +-- | Zstd compression level for test archives (zstd's own default). +testZstdCompressionLevel :: Int +testZstdCompressionLevel = 3 + +-- | Build a @.tar.zst@ archive from tar entries, MSYS2-package style. +compressArchive :: [TarEntry.Entry] -> BL.ByteString +compressArchive = ZstdL.compress testZstdCompressionLevel . Tar.write + +-- | Test-setup helpers: the paths and link targets below are short literals, +-- so encoding them cannot fail; 'error' marks setup bugs, not test failures. +tarPathOrDie :: Bool -> FilePath -> TarEntry.TarPath +tarPathOrDie isDir p = + either (error . ("test tar path: " ++)) id (TarEntry.toTarPath isDir p) + +linkOrDie :: FilePath -> TarEntry.LinkTarget +linkOrDie t = + fromMaybe (error ("test link target: " ++ t)) (TarEntry.toLinkTarget t) + +tarDir :: FilePath -> TarEntry.Entry +tarDir p = TarEntry.directoryEntry (tarPathOrDie True p) + +tarFile :: FilePath -> BL.ByteString -> TarEntry.Entry +tarFile p = TarEntry.fileEntry (tarPathOrDie False p) + +tarExecFile :: FilePath -> BL.ByteString -> TarEntry.Entry +tarExecFile p content = (tarFile p content) {TarEntry.entryPermissions = 0o755} + +tarHardLink :: FilePath -> FilePath -> TarEntry.Entry +tarHardLink p target = + TarEntry.simpleEntry (tarPathOrDie False p) (Tar.HardLink (linkOrDie target)) + +tarSymLink :: FilePath -> FilePath -> TarEntry.Entry +tarSymLink p target = + TarEntry.simpleEntry (tarPathOrDie False p) (Tar.SymbolicLink (linkOrDie target)) + +-- | A pax global header (type @g@) holding @records@, the entry +-- @git archive@ opens GitHub's archives with to carry the commit id. +tarPaxGlobalHeader :: BL.ByteString -> TarEntry.Entry +tarPaxGlobalHeader records = + TarEntry.simpleEntry (tarPathOrDie False "pax_global_header") (Tar.OtherEntryType 'g' records (BL.length records)) + +-- | Step 3 of the ladder: @builtin:unpack@, the stage-0 seed extractor. +-- Two zstd-compressed tar archives sharing a top-level prefix (the MSYS2 +-- @mingw64\/@ shape) are extracted into ONE output: regular files, an +-- executable, a hardlink and a relative symlink (both materialized as +-- copies), with pacman metadata (@.PKGINFO@\/@.MTREE@) skipped. A second +-- build proves cross-archive file collisions fail loudly, and further builds +-- that a parent-climbing (..) entry and drive-rooted file, symlink, and +-- hardlink paths are all rejected. +testUnpackBuildIO :: IO [Bool] +testUnpackBuildIO = do + putStrLn "builder/unpack-seed-archives" + tmpBase0 <- getTemporaryDirectory + if ' ' `elem` tmpBase0 + then do + -- The srcs env is space-separated by the derivation contract (store + -- paths never contain spaces), but these test archives live under + -- TEMP: a spaced TEMP would fragment the paths and fail spuriously. + putStrLn " SKIP unpack archive tests need a space-free TEMP dir" + pure [] + else withTempStore $ \store -> do + let storeDir = stDir store + -- Archives live in the temp store under store-path names: the srcs + -- env is store paths by contract, and runBuiltinUnpack insists on + -- that now (#101) - each entry is parsed and rendered through the + -- build's store dir, which for these builds is the temp store. + let archiveFile name = storePathToFilePath storeDir (StorePath (T.replicate 32 "0") name) + archiveTools = archiveFile "pkg-tools.tar.zst" + archiveData = archiveFile "pkg-data.tar.zst" + archiveCollide = archiveFile "pkg-collide.tar.zst" + archiveEscape = archiveFile "pkg-escape.tar.zst" + archiveRootFile = archiveFile "pkg-root-file.tar.zst" + archiveEscapeSymlink = archiveFile "pkg-escape-symlink.tar.zst" + archiveEscapeHardlink = archiveFile "pkg-escape-hardlink.tar.zst" + archiveDirLink = archiveFile "pkg-dirlink.tar.zst" + archiveDirLinkBase = archiveFile "pkg-dirlink-base.tar.zst" + archiveDirLinkCollide = archiveFile "pkg-dirlink-collide.tar.zst" + archiveHardLinkCollide = archiveFile "pkg-hardlink-collide.tar.zst" + archiveManyEntries = archiveFile "pkg-many-entries.tar.zst" + archiveBigFile = archiveFile "pkg-big-file.tar.zst" + archiveAmplify = archiveFile "pkg-amplify.tar.zst" + archiveGitHub = archiveFile "repo-0123456.tar.gz" + BL.writeFile archiveTools $ + compressArchive + [ tarDir "pkg", + tarDir "pkg/bin", + tarExecFile "pkg/bin/tool.exe" "tool-payload", + tarHardLink "pkg/bin/tool-link.exe" "pkg/bin/tool.exe", + tarSymLink "pkg/bin/sh.exe" "tool.exe", + tarFile ".PKGINFO" "pkgname = tools" + ] + BL.writeFile archiveData $ + compressArchive + [ tarDir "pkg", + tarDir "pkg/share", + tarFile "pkg/share/data.txt" "shared-data", + tarFile ".MTREE" "mtree-bytes" + ] + BL.writeFile archiveCollide $ + compressArchive [tarFile "pkg/bin/tool.exe" "conflicting"] + BL.writeFile archiveEscape $ + compressArchive [tarFile "../evil.txt" "escape"] + -- A leading '/' entry: rooted at the current drive. tar stores paths with + -- '/', so this is the on-disk form even of a Windows-native "\..." name. + BL.writeFile archiveRootFile $ + compressArchive [tarFile "/planted-abs.txt" "rooted-file"] + -- Escaping link targets: '..' climbs above the archive root. Unlike a + -- rooted ('/') target, this builds portably - tar's toLinkTarget accepts a + -- relative path on every host - so the real unpacker is exercised end to end. + BL.writeFile archiveEscapeSymlink $ + compressArchive [tarSymLink "sneaky-link.txt" "../escape-link-target.txt"] + BL.writeFile archiveEscapeHardlink $ + compressArchive [tarHardLink "sneaky-hardlink.txt" "../escape-hardlink-target.txt"] + -- A directory symlink entry with a fresh destination: materialized + -- by copying its target tree. + BL.writeFile archiveDirLink $ + compressArchive + [ tarDir "realdir", + tarFile "realdir/g.txt" "dir-link-payload", + tarSymLink "dirlink" "realdir" + ] + -- Collisions: the first archive already provides pkg/, and a later + -- archive's directory symlink/hardlink also lands at pkg. The + -- tree copy must hit the same collision guard as a regular entry, + -- not silently merge - the merged result would depend on entry + -- order. + BL.writeFile archiveDirLinkBase $ + compressArchive [tarDir "pkg", tarFile "pkg/original.txt" "original"] + BL.writeFile archiveDirLinkCollide $ + compressArchive + [ tarDir "smuggle", + tarFile "smuggle/extra.txt" "smuggled", + tarSymLink "pkg" "smuggle" + ] + BL.writeFile archiveHardLinkCollide $ + compressArchive + [ tarDir "smuggle", + tarFile "smuggle/extra.txt" "smuggled", + tarHardLink "pkg" "smuggle" + ] + -- Budget probes, built against tiny caps injected via BuildConfig. + BL.writeFile archiveManyEntries $ + compressArchive [tarFile ("e" <> show i <> ".txt") "x" | i <- [1 :: Int .. 6]] + BL.writeFile archiveBigFile $ + compressArchive [tarFile "big.bin" (BL.replicate 100 55)] + -- Two directory symlinks each re-copy the 40-byte payload: the + -- copies must charge the budget like first-class content. + BL.writeFile archiveAmplify $ + compressArchive + [ tarDir "base", + tarFile "base/blob.bin" (BL.replicate 40 55), + tarSymLink "dup1" "base", + tarSymLink "dup2" "base" + ] + -- GitHub's archive of a commit: gzip over a tar that opens with a pax + -- global header naming the commit, then one directory named for the + -- repository and the commit. + BL.writeFile archiveGitHub . GZip.compress . Tar.write $ + [ tarPaxGlobalHeader "52 comment=0123456789abcdef0123456789abcdef01234567\n", + tarDir "repo-0123456", + tarDir "repo-0123456/src", + tarFile "repo-0123456/src/main.c" "int main;" + ] + let -- srcs carries the canonical /nix/store spelling, as eval writes + -- it; the physical archives live under the temp store dir. + canonicalSrc file = case parseStorePath storeDir (T.pack file) of + Just sp -> storePathToText defaultStoreDir sp + Nothing -> T.pack file + mkUnpackDrv outP srcFiles = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = outP, + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = builtinUnpackBuilder, + drvArgs = [], + drvEnv = + Map.fromList + [(envSrcs, TE.encodeUtf8 (T.intercalate " " (map canonicalSrc srcFiles)))] + } + seedOut = StorePath (T.replicate 31 "0" <> "2") "unpack-seed" + collideOut = StorePath (T.replicate 31 "0" <> "3") "unpack-collide" + escapeOut = StorePath (T.replicate 31 "0" <> "4") "unpack-escape" + rootFileOut = StorePath (T.replicate 31 "0" <> "5") "unpack-root-file" + escapeSymlinkOut = StorePath (T.replicate 31 "0" <> "6") "unpack-escape-symlink" + escapeHardlinkOut = StorePath (T.replicate 31 "0" <> "7") "unpack-escape-hardlink" + dirLinkOut = StorePath (T.replicate 31 "0" <> "8") "unpack-dirlink" + dirLinkCollideOut = StorePath (T.replicate 31 "0" <> "9") "unpack-dirlink-collide" + hardLinkCollideOut = StorePath (T.replicate 30 "0" <> "10") "unpack-hardlink-collide" + manyEntriesOut = StorePath (T.replicate 30 "0" <> "11") "unpack-entry-budget" + bigFileOut = StorePath (T.replicate 30 "0" <> "12") "unpack-size-budget" + amplifyOut = StorePath (T.replicate 30 "0" <> "13") "unpack-amplify-budget" + gitHubOut = StorePath (T.replicate 30 "0" <> "14") "unpack-github-archive" + buildTmp <- ( "nova-nix-test-unpack-build-tmp") <$> getTemporaryDirectory + forceRemoveIfExists buildTmp + createDirectoryIfMissing True buildTmp + let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} + seedResult <- buildDerivation config store (mkUnpackDrv seedOut [archiveTools, archiveData]) testDrvPath + collideResult <- buildDerivation config store (mkUnpackDrv collideOut [archiveTools, archiveCollide]) testDrvPath + escapeResult <- buildDerivation config store (mkUnpackDrv escapeOut [archiveEscape]) testDrvPath + rootFileResult <- buildDerivation config store (mkUnpackDrv rootFileOut [archiveRootFile]) testDrvPath + escapeSymlinkResult <- buildDerivation config store (mkUnpackDrv escapeSymlinkOut [archiveEscapeSymlink]) testDrvPath + escapeHardlinkResult <- buildDerivation config store (mkUnpackDrv escapeHardlinkOut [archiveEscapeHardlink]) testDrvPath + dirLinkResult <- buildDerivation config store (mkUnpackDrv dirLinkOut [archiveDirLink]) testDrvPath + dirLinkCollideResult <- buildDerivation config store (mkUnpackDrv dirLinkCollideOut [archiveDirLinkBase, archiveDirLinkCollide]) testDrvPath + hardLinkCollideResult <- buildDerivation config store (mkUnpackDrv hardLinkCollideOut [archiveDirLinkBase, archiveHardLinkCollide]) testDrvPath + let tinyBudget bytes entries = + config {bcUnpackLimits = UnpackLimits {ulMaxBytes = bytes, ulMaxEntries = entries}} + manyEntriesResult <- buildDerivation (tinyBudget 1000000 4) store (mkUnpackDrv manyEntriesOut [archiveManyEntries]) testDrvPath + bigFileResult <- buildDerivation (tinyBudget 64 1000) store (mkUnpackDrv bigFileOut [archiveBigFile]) testDrvPath + amplifyResult <- buildDerivation (tinyBudget 100 1000) store (mkUnpackDrv amplifyOut [archiveAmplify]) testDrvPath + gitHubResult <- buildDerivation config store (mkUnpackDrv gitHubOut [archiveGitHub]) testDrvPath + forceRemoveIfExists buildTmp + seedChecks <- case seedResult of + BuildFailure msg code -> + sequence + [ runTest "unpack seed build succeeds" $ + Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + BuildSuccess sp -> do + let outRoot = storePathToFilePath storeDir sp + readOut rel = do + let path = outRoot rel + exists <- Dir.doesFileExist path + if exists then Just <$> TIO.readFile path else pure Nothing + tool <- readOut ("pkg" "bin" "tool.exe") + toolLink <- readOut ("pkg" "bin" "tool-link.exe") + shLink <- readOut ("pkg" "bin" "sh.exe") + dataFile <- readOut ("pkg" "share" "data.txt") + pkgInfo <- Dir.doesFileExist (outRoot ".PKGINFO") + mtree <- Dir.doesFileExist (outRoot ".MTREE") + execBitOk <- + if SI.os == "mingw32" + then pure True -- NTFS has no exec bit; PATHEXT decides + else Dir.executable <$> getPermissions (outRoot "pkg" "bin" "tool.exe") + narInfo <- queryPathInfo (stDB store) sp + let realNarHash = case narInfo of + Just info -> + piNarSize info > 0 && T.isPrefixOf "sha256:" (piNarHash info) + Nothing -> False + sequence + [ runTest "unpack seed build succeeds" Pass, + runTest "unpack: file extracted with content" $ + assertEqual "tool.exe" (Just "tool-payload") tool, + runTest "unpack: hardlink materialized as copy" $ + assertEqual "tool-link.exe" (Just "tool-payload") toolLink, + runTest "unpack: relative symlink materialized as copy" $ + assertEqual "sh.exe" (Just "tool-payload") shLink, + runTest "unpack: second archive merged into shared prefix" $ + assertEqual "data.txt" (Just "shared-data") dataFile, + runTest "unpack: pacman metadata skipped" $ + if pkgInfo || mtree + then Fail ".PKGINFO/.MTREE leaked into the output" + else Pass, + runTest "unpack: executable bit materialized (unix)" $ + if execBitOk then Pass else Fail "tool.exe not executable", + runTest "unpack: real NAR hash registered" $ + if realNarHash then Pass else Fail (T.pack (show narInfo)) + ] + collideChecks <- + sequence + [ runTest "unpack: cross-archive file collision fails loudly" $ + case collideResult of + BuildFailure msg _ + | "file collision" `T.isInfixOf` msg -> Pass + | otherwise -> Fail ("wrong failure: " <> msg) + BuildSuccess _ -> Fail "collision build unexpectedly succeeded" + ] + escapeChecks <- + sequence + [ runTest "unpack: path traversal rejected" $ + case escapeResult of + BuildFailure msg _ + | "escapes archive root" `T.isInfixOf` msg -> Pass + | otherwise -> Fail ("wrong failure: " <> msg) + BuildSuccess _ -> Fail "escape build unexpectedly succeeded" + ] + let rejectedWith needle res = case res of + BuildFailure msg _ + | needle `T.isInfixOf` msg -> Pass + | otherwise -> Fail ("wrong failure: " <> msg) + BuildSuccess _ -> Fail "malicious entry unexpectedly built" + -- Integration: the real unpacker rejects a rooted entry path and an + -- escaping ('..') symlink/hardlink target, end to end. + maliciousChecks <- + sequence + [ runTest "unpack: rooted file entry rejected" $ + rejectedWith "planted-abs.txt" rootFileResult, + runTest "unpack: escaping symlink target rejected" $ + rejectedWith "escape-link-target.txt" escapeSymlinkResult, + runTest "unpack: escaping hardlink target rejected" $ + rejectedWith "escape-hardlink-target.txt" escapeHardlinkResult + ] + dirLinkChecks <- case dirLinkResult of + BuildFailure msg code -> + sequence + [ runTest "unpack: directory symlink materialized as copied tree" $ + Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + BuildSuccess sp -> do + let outRoot = storePathToFilePath storeDir sp + linkedFile = outRoot "dirlink" "g.txt" + linkedExists <- Dir.doesFileExist linkedFile + outcome <- + if not linkedExists + then pure (Fail "dirlink/g.txt missing from the output") + else do + linked <- TIO.readFile linkedFile + -- The copy contract: a real directory, never a link (a + -- store link would need privilege and be machine-dependent). + isLink <- Dir.pathIsSymbolicLink (outRoot "dirlink") + pure $ + if linked == "dir-link-payload" && not isLink + then Pass + else Fail ("content=" <> linked <> " isLink=" <> T.pack (show isLink)) + sequence [runTest "unpack: directory symlink materialized as copied tree" outcome] + collisionGuardChecks <- + sequence + [ runTest "unpack: directory symlink onto existing content fails loudly" $ + rejectedWith "file collision" dirLinkCollideResult, + runTest "unpack: directory hardlink onto existing content fails loudly" $ + rejectedWith "file collision" hardLinkCollideResult + ] + budgetChecks <- + sequence + [ runTest "unpack: entry budget breach fails loudly" $ + rejectedWith "entry budget" manyEntriesResult, + runTest "unpack: size budget breach fails loudly" $ + rejectedWith "size budget" bigFileResult, + runTest "unpack: directory link copies charge the budget" $ + rejectedWith "size budget" amplifyResult + ] + -- Unit: the rooted (drive-relative) case is the Blocker-4 Windows vuln. + -- tar's toLinkTarget refuses an absolute payload on POSIX, so exercise the + -- guard predicate directly - portable and exact on every host. + guardChecks <- + sequence + [ runTest "unpack guard: rooted entry path rejected" $ + assertLeft "rooted entry" (entryComponents "/planted-abs.txt"), + runTest "unpack guard: rooted symlink target rejected" $ + assertLeft "rooted symlink" (resolveLinkTarget [] "/planted-link-target.txt"), + runTest "unpack guard: rooted hardlink target rejected" $ + assertLeft "rooted hardlink" (entryComponents "/planted-hardlink-target.txt") + ] + gitHubChecks <- case gitHubResult of + BuildFailure msg code -> + sequence + [ runTest "unpack: a gzip archive in GitHub's shape extracts" $ + Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + BuildSuccess sp -> do + let outRoot = storePathToFilePath storeDir sp + source = outRoot "repo-0123456" "src" "main.c" + sourceExists <- Dir.doesFileExist source + content <- if sourceExists then Just <$> TIO.readFile source else pure Nothing + topLevel <- Dir.listDirectory outRoot + sequence + [ runTest "unpack: a gzip archive in GitHub's shape extracts" $ + assertEqual "main.c" (Just "int main;") content, + runTest "unpack: the pax global header is not extracted" $ + assertEqual "top level" ["repo-0123456"] topLevel + ] + pure (seedChecks ++ collideChecks ++ escapeChecks ++ maliciousChecks ++ dirLinkChecks ++ collisionGuardChecks ++ budgetChecks ++ guardChecks ++ gitHubChecks) + +-- | Step 2 of the ladder: a dependency-aware build end-to-end. A root +-- derivation depends on a leaf; both @.drv@ files are pre-written to the store +-- (as the build driver's closure-writing does), and 'buildWithDeps' must read +-- the closure, topologically order it, build the leaf first, then the root - +-- whose 'validateInputs' requires the leaf's realized output to be valid. +-- +-- This is the regression guard for the input-@.drv@-closure fix: before it, no +-- derivation with a non-empty @drvInputDrvs@ could be realized (the closure was +-- never on disk, so the dependency graph could not be read). +testDependentBuildIO :: IO [Bool] +testDependentBuildIO = do + putStrLn "builder/dependent-native-build" + withTempStore $ \store -> do + let storeDir = stDir store + depOut = StorePath (T.replicate 31 "c" <> "0") "dep" + depDrvSP = StorePath (T.replicate 31 "c" <> "1") "dep.drv" + rootOut = StorePath (T.replicate 31 "a" <> "0") "root" + rootDrvSP = StorePath (T.replicate 31 "a" <> "1") "root.drv" + mkBuilder word + | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo " <> word <> ">%out%"]) + | otherwise = ("/bin/sh", ["-c", "echo " <> word <> " > $out"]) + (depBuilder, depArgs) = mkBuilder "leaf" + (rootBuilder, rootArgs) = mkBuilder "root" + depDrv = + Derivation + { drvOutputs = [DerivationOutput {doName = "out", doPath = depOut, doHashAlgo = "", doHash = ""}], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = depBuilder, + drvArgs = depArgs, + drvEnv = Map.singleton "name" "dep" + } + rootDrv = + Derivation + { drvOutputs = [DerivationOutput {doName = "out", doPath = rootOut, doHashAlgo = "", doHash = ""}], + drvInputDrvs = Map.singleton depDrvSP ["out"], + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = rootBuilder, + drvArgs = rootArgs, + drvEnv = Map.singleton "name" "root" + } + -- The build driver writes the full .drv closure before building; emulate + -- that here by writing both recipes to the store. + writeDrv store depDrv depDrvSP + writeDrv store rootDrv rootDrvSP + buildTmp <- ( "nova-nix-test-dep-build-tmp") <$> getTemporaryDirectory + forceRemoveIfExists buildTmp + createDirectoryIfMissing True buildTmp + let config = (defaultBuildConfig storeDir) {bcTmpDir = buildTmp} + result <- buildWithDeps config store rootDrv rootDrvSP + depValid <- isValid store depOut + rootValid <- isValid store rootOut + forceRemoveIfExists buildTmp + case result of + BuildSuccess sp -> + sequence + [ runTest "dependent build succeeds with root output" $ + assertEqual "root output path" rootOut sp, + runTest "leaf dependency built and registered first" $ + if depValid then Pass else Fail "leaf output not valid after build", + runTest "root output built and registered" $ + if rootValid then Pass else Fail "root output not valid after build" + ] + BuildFailure msg code -> + sequence + [ runTest "dependent build succeeds with root output" $ + Fail ("dependency-aware build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + +-- | A random reference graph over a few nodes, cycles and self-references +-- included, with roots drawn from it. +genReferenceGraph :: QC.Gen (Map.Map Int [Int], [Int]) +genReferenceGraph = do + size <- QC.chooseInt (1, 12) + references <- traverse (\node -> (,) node <$> QC.sublistOf [0 .. size - 1]) [0 .. size - 1] + roots <- QC.sublistOf [0 .. size - 1] + pure (Map.fromList references, roots) + +-- | Reference scanning covers the closure of a build's inputs, upstream's +-- @inputPaths@: an output records a path its inputs reach only through +-- their references, from an input derivation's output or from an input +-- source, and a collection keeps that path while the output is rooted. A +-- valid path outside the closure is not recorded, and neither is the input +-- derivation's @.drv@. +testReferenceClosureIO :: IO [Bool] +testReferenceClosureIO = do + putStrLn "builder/reference-closure" + shell <- findTestShell + buildTmp <- ( "nova-nix-test-reference-closure-tmp") <$> getTemporaryDirectory + closureLaw <- + runTestM "closureUnder is the least set holding the roots and closed under references" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll genReferenceGraph $ \(references, roots) -> + let referencesOf node = Map.findWithDefault [] node references + fixpoint reached + | next == reached = reached + | otherwise = fixpoint next + where + next = reached <> Set.fromList (concatMap referencesOf (Set.toList reached)) + in runIdentity (closureUnder (Identity . referencesOf) roots) QC.=== fixpoint (Set.fromList roots) + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + built <- withTempStore $ \store -> do + let sd = stDir store + onDisk = storePathToFilePath sd + pathText = T.pack . onDisk + plant sp = do + createDirectoryIfMissing True (onDisk sp) + BS.writeFile (onDisk sp "data") (TE.encodeUtf8 (spName sp)) + registration sp = PathRegistration sp ("sha256:" <> T.replicate 52 "0") 1 Nothing + -- The input derivation's output records libRuntime, and the input + -- source records srcRuntime. + lib = StorePath (T.replicate 32 "k") "closure-lib" + libRuntime = StorePath (T.replicate 32 "l") "closure-lib-runtime" + libDrvPath = StorePath (T.replicate 32 "m") "closure-lib.drv" + src = StorePath (T.replicate 32 "n") "closure-src" + srcRuntime = StorePath (T.replicate 32 "p") "closure-src-runtime" + stray = StorePath (T.replicate 32 "q") "closure-stray" + outSP = StorePath (T.replicate 32 "r") "closure-out" + libDrv = mkTestBuildDrv shell lib "mkdir -p \"$out\"" + script = + "mkdir -p \"$out\" && printf '%s\\n' " + <> T.unwords ["'" <> pathText sp <> "'" | sp <- [libRuntime, srcRuntime, stray, libDrvPath]] + <> " > \"$out/paths\"" + drv = (mkTestBuildDrv shell outSP script) {drvInputDrvs = Map.singleton libDrvPath ["out"], drvInputSrcs = [src]} + config = (defaultBuildConfig sd) {bcTmpDir = buildTmp} + rootFile = gcRootsDir sd T.unpack (spHash outSP <> "-" <> spName outSP) + mapM_ plant [lib, libRuntime, src, srcRuntime, stray] + registerPaths + (stDB store) + [ registration libRuntime [], + registration lib [libRuntime], + registration srcRuntime [], + registration src [srcRuntime], + registration stray [] + ] + writeDrv store libDrv libDrvPath + result <- buildDerivation config store drv testDrvPath + recorded <- Set.fromList <$> queryReferences (stDB store) outSP + createDirectoryIfMissing True (gcRootsDir sd) + BS.writeFile rootFile "" + collected <- collectGarbage store + validity <- mapM (isValid store) [outSP, libRuntime, srcRuntime, stray] + runtimesOnDisk <- mapM (Dir.doesPathExist . ( "data") . onDisk) [libRuntime, srcRuntime] + forceRemoveIfExists buildTmp + let recordedAmong = filter (\sp -> Set.member (pathText sp) recorded) + case result of + BuildFailure msg code -> + sequence + [ runTest "an output records a path its inputs reach through their references" $ + Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + ] + BuildSuccess _ -> + sequence + [ runTest "an output records a path its inputs reach through their references" $ + assertEqual "recorded" [libRuntime, srcRuntime] (recordedAmong [libRuntime, srcRuntime]), + runTest "a collection keeps a dependency of a dependency while the output is rooted" $ + assertRight "collectGarbage" collected $ \_ -> + assertEqual "out, libRuntime, srcRuntime, stray valid; runtimes on disk" ([True, True, True, False], [True, True]) (validity, runtimesOnDisk), + runTest "a path outside the input closure is not recorded" $ + assertEqual "recorded" [] (recordedAmong [stray, libDrvPath]) + ] + pure (closureLaw : built) + +-- | A random acyclic reference graph over a few nodes, labelled in random +-- order so that ascending order is not a topological one. A node +-- references only nodes before it in that order, and may also reference +-- itself or a node outside the graph, which 'orderByReferences' ignores. +genAcyclicReferences :: QC.Gen (Map.Map Int (Set.Set Int)) +genAcyclicReferences = do + size <- QC.chooseInt (1, 12) + labels <- QC.shuffle [0 .. size - 1] + let referencesOf (label, before) = do + earlier <- QC.sublistOf before + itself <- QC.elements [[], [label]] + outside <- QC.sublistOf [size, size + 1] + pure (label, Set.fromList (earlier ++ itself ++ outside)) + Map.fromList <$> traverse referencesOf (zip labels (inits labels)) + +-- | 'orderByReferences' is upstream's @topoSort@ (topo-sort.hh at 2.24.9) +-- followed by the reversal @registerOutputs@ applies. Over generated +-- graphs it finds a cycle exactly when the references hold one, an order +-- it returns lists every node once and after each node it references, and +-- a cycle it reports is closed by a real reference. The fixed cases are +-- what upstream's @topoSort@ and that reversal give for the same graphs. +testOutputOrderIO :: IO [Bool] +testOutputOrderIO = do + putStrLn "builder/output-order" + let quickCheckPasses property = do + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + -- A generated graph as the map the walk takes: its roots are the + -- nodes, and a reference may name a node outside them. + asNodes (references, roots) = + Map.fromList [(node, Set.fromList (Map.findWithDefault [] node references)) | node <- roots] + -- The references the walk follows: between two distinct nodes. + edgesWithin nodes = + [(from, to) | (from, references) <- Map.toList nodes, to <- Set.toList references, to /= from, Map.member to nodes] + successors nodes node = [to | (from, to) <- edgesWithin nodes, from == node] + hasCycle nodes = + any cyclic (Graph.stronglyConnComp [(node, node, successors nodes node) | node <- Map.keys nodes]) + cyclic (Graph.AcyclicSCC _) = False + cyclic _ = True + orderOf :: Map.Map Int (Set.Set Int) -> Either (ReferenceCycle Int) [(Int, Set.Set Int)] + orderOf = orderByReferences id + namedOrder :: [(Text, [Text])] -> Either (ReferenceCycle Text) [Text] + namedOrder graph = map fst <$> orderByReferences Set.fromList (Map.fromList graph) + sequence + [ runTestM "orderByReferences finds a cycle exactly when the references hold one" $ + quickCheckPasses . QC.checkCoverage $ + QC.forAll (QC.frequency [(2, asNodes <$> genReferenceGraph), (1, genAcyclicReferences)]) $ \nodes -> + QC.cover 25 (hasCycle nodes) "with a cycle" . QC.cover 25 (not (hasCycle nodes)) "without one" $ + either (const True) (const False) (orderOf nodes) QC.=== hasCycle nodes, + runTestM "orderByReferences lists every node once, after each node it references" $ + quickCheckPasses $ + QC.forAll genAcyclicReferences $ \nodes -> case orderOf nodes of + Left found -> QC.counterexample ("reported a cycle in an acyclic graph: " <> show found) False + Right order -> + let position = Map.fromList (zip (map fst order) [0 :: Int ..]) + before from to = (<) <$> Map.lookup to position <*> Map.lookup from position + in QC.conjoin + [ sort (map fst order) QC.=== Map.keys nodes, + Map.fromList order QC.=== nodes, + QC.counterexample "a node is listed before a node it references" (all (\(from, to) -> before from to == Just True) (edgesWithin nodes)) + ], + runTestM "a cycle orderByReferences reports is closed by a real reference" $ + quickCheckPasses . QC.checkCoverage $ + QC.forAll (asNodes <$> genReferenceGraph) $ \nodes -> QC.cover 40 (hasCycle nodes) "with a cycle" $ case orderOf nodes of + Right _ -> QC.property True + Left (ReferenceCycle node referrer) -> + let reachable = runIdentity (closureUnder (Identity . successors nodes) [node]) + in QC.counterexample (show (node, referrer)) $ + (referrer, node) `elem` edgesWithin nodes && Set.member referrer reachable, + runTest "orderByReferences gives upstream's output order and cycle for fixed graphs" $ + assertEqual + "orders" + [ Left (ReferenceCycle "dev" "out"), + Left (ReferenceCycle "b" "c"), + Right ["c", "a", "b"], + Right ["bin", "dev", "out"] + ] + [ namedOrder [("dev", ["out"]), ("out", ["dev"])], + namedOrder [("a", ["b"]), ("b", ["c"]), ("c", ["b"])], + namedOrder [("a", ["c"]), ("b", []), ("c", [])], + namedOrder [("bin", ["gone"]), ("dev", ["bin"]), ("out", ["dev", "out"])] + ] + ] + +-- | Outputs that reference each other in a cycle fail the build with +-- upstream's message (local-derivation-goal.cc:2406-2408 at 2.24.9) and +-- leave nothing registered, while a one-way reference between outputs and +-- a self-reference build and are recorded. A rebuilt output referencing a +-- sibling registered before the build is no cycle even when the sibling's +-- discarded copy references it back, since upstream treats a registered +-- output as a leaf. +testOutputCycleBuildIO :: IO [Bool] +testOutputCycleBuildIO = do + putStrLn "builder/output-cycle" + shell <- findTestShell + buildTmp <- ( "nova-nix-test-output-cycle-tmp") <$> getTemporaryDirectory + results <- withTempStore $ \store -> do + let sd = stDir store + config = (defaultBuildConfig sd) {bcTmpDir = buildTmp} + pathText = T.pack . storePathToFilePath sd + basename sp = spHash sp <> "-" <> spName sp + hashOf = T.replicate 32 + -- A derivation with outputs dev and out, written to the store as + -- the build driver writes what it builds, then built. + buildTwo drvSP name devSP outSP script = do + let drv = + Derivation + { drvOutputs = [DerivationOutput "dev" devSP "" "", DerivationOutput "out" outSP "" ""], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", script], + drvEnv = Map.singleton "name" name + } + writeDrv store drv drvSP + buildWithDeps config store drv drvSP + referencesOf sp = Set.fromList <$> queryReferences (stDB store) sp + cycleDrv = StorePath (hashOf "s") "cycle.drv" + cycleDev = StorePath (hashOf "v") "cycle-dev" + cycleOut = StorePath (hashOf "w") "cycle" + onewayDrv = StorePath (hashOf "x") "oneway.drv" + onewayDev = StorePath (hashOf "y") "oneway-dev" + onewayOut = StorePath (hashOf "z") "oneway" + leafFirstDrv = StorePath (hashOf "g") "leaf.drv" + leafSecondDrv = StorePath (hashOf "h") "leaf.drv" + leafDev = StorePath (hashOf "j") "leaf-dev" + leafOut = StorePath (hashOf "k") "leaf" + cycleResult <- buildTwo cycleDrv "cycle" cycleDev cycleOut "mkdir -p \"$out\" \"$dev\" && echo \"$dev\" > \"$out/dev\" && echo \"$out\" > \"$dev/out\"" + cycleValid <- mapM (isValid store) [cycleDev, cycleOut] + cycleOnDisk <- mapM (Dir.doesPathExist . storePathToFilePath sd) [cycleDev, cycleOut] + onewayResult <- buildTwo onewayDrv "oneway" onewayDev onewayOut "mkdir -p \"$out\" \"$dev\" && echo \"$dev\" > \"$out/dev\" && echo \"$out\" > \"$out/self\" && echo \"$dev\" > \"$dev/self\"" + onewayRefs <- mapM referencesOf [onewayDev, onewayOut] + leafFirst <- buildTwo leafFirstDrv "leaf" leafDev leafOut "mkdir -p \"$out\" \"$dev\" && echo first > \"$out/v\" && echo first > \"$dev/v\"" + deleted <- deleteStorePathRaw store (basename leafOut) + leafSecond <- buildTwo leafSecondDrv "leaf" leafDev leafOut "mkdir -p \"$out\" \"$dev\" && echo \"$dev\" > \"$out/dev\" && echo \"$out\" > \"$dev/out\"" + leafValid <- mapM (isValid store) [leafDev, leafOut] + leafRefs <- referencesOf leafOut + let succeeded result = case result of + BuildSuccess _ -> Pass + BuildFailure msg code -> Fail ("build failed (exit " <> T.pack (show code) <> "): " <> msg) + sequence + [ runTest "outputs referencing each other fail the build with upstream's message" $ + assertEqual + "result" + (BuildFailure ("building cycle failed: exit 1: cycle detected in build of '/nix/store/" <> hashOf "s" <> "-cycle.drv' in the references of output 'dev' from output 'out'") 1) + cycleResult, + runTest "outputs referencing each other leave nothing registered or in the store" $ + assertEqual "valid, on disk" ([False, False], [False, False]) (cycleValid, cycleOnDisk), + runTest "a one-way reference between outputs and self-references build" $ succeeded onewayResult, + runTest "a one-way reference between outputs and self-references are recorded" $ + assertEqual + "dev's and out's references" + [Set.fromList [pathText onewayDev], Set.fromList [pathText onewayDev, pathText onewayOut]] + onewayRefs, + runTest "a rebuilt output referencing a registered sibling that references it back builds" $ + case (leafFirst, deleted, leafSecond) of + (BuildSuccess _, Right outcome, BuildSuccess _) + | not (doRowRemoved outcome) -> Fail "the setup did not unregister out" + | otherwise -> assertEqual "valid, out's references" ([True, True], Set.fromList [pathText leafDev]) (leafValid, leafRefs) + (_, _, BuildFailure msg code) -> Fail ("the rebuild failed (exit " <> T.pack (show code) <> "): " <> msg) + _ -> Fail "the setup did not reach a registered dev and an unregistered out" + ] + forceRemoveIfExists buildTmp + pure results + +-- | Upstream value-conformance tests: each pins exact output bytes (hash +-- decode, number formatting) that must match what upstream Nix computes for +-- the same input, because these values can reach names, derivations, and +-- hashes. +testUpstreamConformance :: IO [Bool] +testUpstreamConformance = do + putStrLn "eval/conformance" + let xmlDocument body = mkStr ("\n\n" <> body <> "\n") + sequence + [ -- Hash decode is length-keyed per algorithm, never first-format-wins: + -- a 52-char all-hex-digit string is a nix32 sha256 hash (64 hex chars + -- after conversion), not a 26-byte hex string echoed back. + runTest "hash decode keys on nix32 length" $ + assertEval + "hash-nix32-length" + "builtins.stringLength (builtins.convertHash { hash = \"0aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"; hashAlgo = \"sha256\"; toHashFormat = \"base16\"; })" + (VInt 64), + runTest "hash hex to nix32 round-trips" $ + assertEval + "hash-roundtrip" + "builtins.convertHash { hash = builtins.convertHash { hash = \"sha256:e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855\"; toHashFormat = \"nix32\"; }; hashAlgo = \"sha256\"; toHashFormat = \"base16\"; }" + (mkStr "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), + runTest "hash base64 spelling decodes by length" $ + assertEval + "hash-base64" + "builtins.convertHash { hash = \"sha256:47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; toHashFormat = \"base16\"; }" + (mkStr "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), + runTest "truncated hash is rejected" $ + assertEvalFail + "hash-truncated" + "builtins.convertHash { hash = \"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b85\"; hashAlgo = \"sha256\"; toHashFormat = \"base16\"; }", + runTest "unknown hash algorithm is rejected" $ + assertEvalFail + "hash-bad-algo" + "builtins.convertHash { hash = \"00\"; hashAlgo = \"sha3\"; toHashFormat = \"base16\"; }", + -- SRI digests get the same decoded-length check as every other + -- spelling (upstream checks SRI too), at all three decode sites: + -- convertHash, fixed-output outputHash, and the fetch/path pins. + runTest "valid SRI digest converts" $ + assertEval + "hash-sri-valid" + "builtins.convertHash { hash = \"sha256-47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; toHashFormat = \"base16\"; }" + (mkStr "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"), + runTest "convertHash rejects a truncated SRI digest" $ + case evalNix "builtins.convertHash { hash = \"sha256-YWJj\"; toHashFormat = \"base16\"; }" of + Left err + | "wrong length" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected an SRI length error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + runTest "fixed-output outputHash rejects a truncated SRI digest" $ + case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha256-YWJj\"; }).drvPath" of + Left err + | "wrong length" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected an SRI length error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + -- An SRI or prefixed outputHash carries its own algorithm tag; a + -- non-empty outputHashAlgo must agree with it (hash.cc parseAny + -- with an expected type), and an unknown declared algorithm is an + -- error even when the spelling carries a valid tag of its own. + runTest "fixed-output SRI algorithm must match outputHashAlgo" $ + case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha1-2jmj7l5rSw0yVb/vlWAYkK/YBwk=\"; outputHashAlgo = \"sha256\"; }).drvPath" of + Left err + | "should have type 'sha256'" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected a hash-type error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + runTest "fixed-output prefixed algorithm must match outputHashAlgo" $ + case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"md5:d41d8cd98f00b204e9800998ecf8427e\"; outputHashAlgo = \"sha256\"; }).drvPath" of + Left err + | "should have type 'sha256'" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected a hash-type error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + runTest "fixed-output SRI agreeing with outputHashAlgo accepted" $ + case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha256-47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; outputHashAlgo = \"sha256\"; }).drvPath" of + Right _ -> Pass + Left err -> Fail ("expected success, got: " <> err), + runTest "fixed-output unknown outputHashAlgo rejected despite SRI tag" $ + case evalNix "(derivation { name = \"t\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputHash = \"sha256-47DEQpj8HBSa+/TImW+5JCeuQeRkm5NMpJWZG3hSuFU=\"; outputHashAlgo = \"sha3\"; }).drvPath" of + Left err + | "unknown hash algorithm" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected an unknown-algorithm error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + runTest "builtins.path pin rejects a truncated SRI digest" $ + case evalNix "builtins.path { path = ./x; sha256 = \"sha256-YWJj\"; }" of + Left err + | "wrong length" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected an SRI length error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + runTest "builtins.path pin rejects a non-sha256 SRI digest" $ + case evalNix ("builtins.path { path = ./x; sha256 = \"sha512-" <> T.replicate 86 "A" <> "==\"; }") of + Left err + | "should have type 'sha256'" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected a hash-type error, got: " <> err) + Right val -> Fail ("expected failure, got: " <> T.pack (show val)), + -- toJSON floats: nlohmann's layout - shortest round-trip digits, .0 + -- kept on integral values, scientific outside point positions (-4, 15]. + runTest "toJSON float shortest digits" $ + assertEval "json-float-third" "builtins.toJSON (1.0 / 3.0)" (mkStr "0.3333333333333333"), + runTest "toJSON integral float keeps .0" $ + assertEval "json-float-integral" "builtins.toJSON 100.0" (mkStr "100.0"), + runTest "toJSON float plain decimal" $ + assertEval "json-float-tenth" "builtins.toJSON 0.1" (mkStr "0.1"), + runTest "toJSON float zero" $ + assertEval "json-float-zero" "builtins.toJSON 0.0" (mkStr "0.0"), + runTest "toJSON float widest plain integral" $ + assertEval "json-float-e14" "builtins.toJSON 1.0e14" (mkStr "100000000000000.0"), + runTest "toJSON float first scientific integral" $ + assertEval "json-float-e15" "builtins.toJSON 1.0e15" (mkStr "1e+15"), + runTest "toJSON float large exponent" $ + assertEval "json-float-e21" "builtins.toJSON 1.0e21" (mkStr "1e+21"), + runTest "toJSON float negative exponent" $ + assertEval "json-float-e-5" "builtins.toJSON 1.0e-5" (mkStr "1e-05"), + runTest "toJSON float smallest plain" $ + assertEval "json-float-e-4" "builtins.toJSON 1.0e-4" (mkStr "0.0001"), + runTest "toJSON non-finite float is null" $ + assertEval "json-float-inf" "builtins.toJSON (1.0e308 * 10.0)" (mkStr "null"), + -- fromJSON integers: int64 range stays int, wider falls back to float. + runTest "fromJSON promotes past-64-bit integer to float" $ + assertEval "json-bigint-type" "builtins.typeOf (builtins.fromJSON \"999999999999999999999\")" (mkStr "float"), + runTest "fromJSON past-64-bit integer value" $ + assertEval "json-bigint-val" "builtins.fromJSON \"999999999999999999999\" == 999999999999999999999.0" (VBool True), + runTest "fromJSON int64 max stays an int" $ + assertEval "json-int64-max" "builtins.fromJSON \"9223372036854775807\"" (VInt 9223372036854775807), + -- toXML floats: C++ default ostream formatting, 6 significant digits. + runTest "toXML float 6 significant digits" $ + assertEval + "xml-float-third" + "builtins.toXML (1.0 / 3.0)" + (xmlDocument " \n"), + runTest "toXML float plain decimal" $ + assertEval + "xml-float-centi" + "builtins.toXML 0.01" + (xmlDocument " \n"), + runTest "toXML integral float drops the point" $ + assertEval + "xml-float-integral" + "builtins.toXML 100.0" + (xmlDocument " \n"), + runTest "toXML float large exponent" $ + assertEval + "xml-float-e21" + "builtins.toXML 1.0e21" + (xmlDocument " \n"), + runTest "toXML float small exponent" $ + assertEval + "xml-float-e-5" + "builtins.toXML 2.5e-5" + (xmlDocument " \n"), + -- The document is upstream's XMLWriter output (value-to-xml.cc and + -- xml-writer.cc at 2.24.9): every element two spaces deeper than the + -- one around it, a newline in a value written as a character + -- reference. Each expected document is nix-instantiate 2.24.9's and + -- 2.33.2's (#221). + runTest "toXML indents each element under the one around it" $ + assertEval + "xml-nesting" + "builtins.toXML { s = \"a&\\\"q'\\n\\tz\"; l = [ 1 { } ]; }" + ( xmlDocument + ( " \n \n \n \n" + <> " \n \n \n \n" + <> " \n \n" + <> " \n \n" + ) + ), + runTest "toXML writes a lambda's argument pattern and leaves a primop unevaluated" $ + assertEval + "xml-functions" + "builtins.toXML [ (x: x) (args@{ z, ... }: 1) ({ b, a }: a) builtins.map (builtins.map (x: x)) ]" + ( xmlDocument + ( " \n \n \n \n" + <> " \n \n \n" + <> " \n \n" + <> " \n \n \n \n" + <> " \n \n" + <> " \n \n \n" + ) + ), + runTest "toXML writes a derivation in full once and repeated after" $ + assertEval + "xml-derivations" + "builtins.toXML [ { type = \"derivation\"; drvPath = \"/p\"; outPath = \"/o\"; a = 1; } { type = \"derivation\"; drvPath = \"/p\"; } { type = \"derivation\"; outPath = 2; } ]" + ( xmlDocument + ( " \n \n" + <> " \n \n \n" + <> " \n \n \n" + <> " \n \n \n" + <> " \n \n \n" + <> " \n" + <> " \n \n \n" + <> " \n \n \n \n" + ) + ), + runTest "toXML keeps the contexts of the strings it writes" $ + assertEval + "xml-context" + "let d = derivation { name = \"x\"; system = \"s\"; builder = \"b\"; }; in builtins.getContext (builtins.toXML { s = \"${d}\"; }) == builtins.getContext \"${d}\"" + (VBool True), + -- fromTOML integers: 64-bit signed range enforced, no silent wrap. + runTest "fromTOML rejects past-64-bit integer" $ + assertEvalFail "toml-int-overflow" "builtins.fromTOML \"v = 99999999999999999999\"", + runTest "fromTOML rejects past-64-bit hex integer" $ + assertEvalFail "toml-hex-overflow" "builtins.fromTOML \"v = 0xffffffffffffffff\"", + runTest "fromTOML int64 max parses" $ + assertEval "toml-int64-max" "(builtins.fromTOML \"v = 9223372036854775807\").v" (VInt 9223372036854775807), + runTest "fromTOML int64 min parses" $ + assertEval "toml-int64-min" "(builtins.fromTOML \"v = -9223372036854775808\").v == (0 - 9223372036854775807 - 1)" (VBool True), + -- drv3: pure eval cannot read the store, so hashing a dependent + -- derivation fails loudly rather than emitting a guessed input hash. + runTest "dependent derivation drvPath fails loudly in pure eval" $ + assertEvalFail + "drv-modulo-pure-miss" + "let dep = derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }; main = derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; src = dep.outPath; }; in main.drvPath", + -- Path values canonicalize lexically (CanonPath): no dot segment or + -- doubled separator survives into a path value's text, so different + -- spellings of the same path compare equal. + runTest "path literal canonicalizes dot segments" $ + assertEval "path-canon-dot" "builtins.toString ./. == builtins.toString ./x/.." (VBool True), + runTest "path literal collapses inner dot" $ + assertEval "path-canon-inner" "builtins.toString ./a/./b == builtins.toString ./a/b" (VBool True), + runTest "path plus string canonicalizes" $ + assertEval "path-canon-plus" "./a + \"/../b\" == ./b" (VBool True), + runTest "toPath canonicalizes" $ + assertEval "path-canon-topath" "builtins.toString (builtins.toPath \"/a/../b\")" (mkStr "/b"), + runTest "toPath collapses inner dot" $ + assertEval "path-canon-topath-dot" "builtins.toString (builtins.toPath \"/a/./b\")" (mkStr "/a/b"), + runTest "toPath preserves forward-slash root" $ + assertEval "path-canon-topath-root" "builtins.toString (builtins.toPath \"//nix//store\")" (mkStr "/nix/store") + ] + +-- | Eval-fidelity regression tests: each pins a semantic where the evaluator +-- must match upstream Nix. All are parity-safe - none affects a derivation +-- or store-path hash. +testEvalFidelity :: IO [Bool] +testEvalFidelity = do + putStrLn "eval/fidelity" + sequence + [ -- builtins.match: a non-participating capture group is null, not "" + runTest "match null capture group" $ + assertEval "match-null" "builtins.isNull (builtins.elemAt (builtins.match \"(a)(b)?\" \"a\") 1)" (VBool True), + runTest "match participating group value" $ + assertEval "match-val" "builtins.elemAt (builtins.match \"(a)(b)\" \"ab\") 1" (mkStr "b"), + -- builtins.split: a non-participating group is null too + runTest "split null capture group" $ + assertEval "split-null" "builtins.isNull (builtins.elemAt (builtins.elemAt (builtins.split \"(a)|(b)\" \"a\") 1) 1)" (VBool True), + -- builtins.match is whole-string like regex_match: top-level + -- alternation must not decay into a prefix/suffix match. + runTest "match alternation is whole-string" $ + assertEval "match-alt" "builtins.match \"a|b\" \"ab\"" VNull, + runTest "match alternation positive" $ + assertEval "match-alt-pos" "builtins.match \"a|b\" \"a\" == [ ]" (VBool True), + -- No multiline mode: ^/$ anchor only at the string boundaries and + -- '.' matches a newline, as POSIX ERE whole-string matching does. + runTest "match does not anchor at inner newlines" $ + assertEval "match-nl" "builtins.match \"foo\" \"bar\\nfoo\"" VNull, + runTest "match dot spans newline" $ + assertEval "match-dot-nl" "builtins.match \"(.*)\" \"a\\nb\" == [ \"a\\nb\" ]" (VBool True), + runTest "split dot spans newline" $ + assertEval "split-dot-nl" "builtins.split \"a.b\" \"xa\\nby\" == [ \"x\" [ ] \"y\" ]" (VBool True), + -- Derivations compare by outPath alone (C++ eqValues special case) - + -- even when the rest of the attrs (or the key sets) differ. + runTest "derivation eq by outPath" $ + assertEval + "drv-eq" + "{ type = \"derivation\"; outPath = \"/nix/store/a\"; f = (x: x); } == { type = \"derivation\"; outPath = \"/nix/store/a\"; f = (y: y); extra = 1; }" + (VBool True), + runTest "derivation neq by outPath" $ + assertEval + "drv-neq" + "{ type = \"derivation\"; outPath = \"/a\"; } == { type = \"derivation\"; outPath = \"/b\"; }" + (VBool False), + runTest "derivation-tagged sets without outPath deep-compare" $ + assertEval + "drv-no-outpath" + "{ type = \"derivation\"; n = 1; } == { type = \"derivation\"; n = 1; }" + (VBool True), + -- A throwing derivation attr fails evaluation - never a silent drop + -- (a dropped attr once produced an empty no-input .drv that "built"). + runTest "derivation attr throw propagates" $ + assertEvalFail "drv-throw" "(derivation { name = \"x\"; system = \"s\"; builder = \"/b\"; src = throw \"boom\"; }).drvPath", + -- __ignoreNulls drops null attrs; without it null coerces to "". + runTest "derivation ignoreNulls drops null" $ + assertEval "drv-ignore-nulls" "builtins.isString (derivation { name = \"x\"; system = \"s\"; builder = \"/b\"; src = null; __ignoreNulls = true; }).drvPath" (VBool True), + runTest "derivation null coerces without ignoreNulls" $ + assertEval "drv-null-empty" "builtins.isString (derivation { name = \"x\"; system = \"s\"; builder = \"/b\"; foo = null; }).drvPath" (VBool True), + -- A literal string key is static, as in upstream's parser: legal in + -- let, referenceable as a rec sibling. + runTest "let with literal string key" $ + assertEval "let-string-key" "let \"x\" = 1; in x" (VInt 1), + runTest "rec string key is a referenceable sibling" $ + assertEval "rec-string-key" "(rec { \"a\" = 1; b = a; }).b" (VInt 1), + -- A dynamic TOP-LEVEL key in let is a parse error upstream; nested + -- dynamic keys live in a nested attrset and stay legal. + runTest "dynamic key in let rejected" $ + assertParseFail "let-dyn-key" "let k = \"y\"; in let ${k} = 1; in y", + runTest "interpolated string key in let rejected" $ + assertParseFail "let-interp-key" "let k = \"y\"; in let \"${k}\" = 1; in y", + runTest "nested dynamic key in let allowed" $ + assertEval "let-nested-dyn" "let k = \"q\"; in let a.${k} = 1; in a.q" (VInt 1), + -- Nested interpolated strings inside braces: the lexer's brace-depth + -- stack must restore the enclosing count when an interpolation + -- closes, or the outer attrset's '}' mislexes as TokInterpClose. + runTest "nested interpolated string inside attrset braces" $ + assertEval "nested-interp" "let y = \"v\"; in \"${ { a = \"${y}\"; }.a }\"" (mkStr "v"), + runTest "nested interpolation in indented string" $ + assertEval "nested-interp-ind" "let y = \"w\"; in ''pre ${ { a = ''${y}''; }.a } post''" (mkStr "pre w post"), + runTest "doubly nested interpolated strings" $ + assertEval "nested-interp-2" "let y = \"z\"; in \"${ { a = \"${ { b = \"${y}\"; }.b }\"; }.a }\"" (mkStr "z"), + -- Attrpath merging (upstream parser.y addAttr): a literal set and a + -- nested path under the same key merge; genuine duplicates error. + runTest "literal set merges with attrpath (kept attr)" $ + assertEval "merge-keep" "{ a = { b = 1; }; a.c = 2; }.a.b" (VInt 1), + runTest "literal set merges with attrpath (added attr)" $ + assertEval "merge-add" "{ a = { b = 1; }; a.c = 2; }.a.c" (VInt 2), + runTest "duplicate plain key is a parse error" $ + assertParseFail "dup-key" "{ a = 1; a = 2; }", + runTest "duplicate formal is rejected" $ + assertParseFail "dup-formal" "{ a, a }: a", + runTest "duplicate formal with defaults is rejected" $ + assertParseFail "dup-formal-default" "{ a ? 1, a ? 2 }: a", + runTest "duplicate inner key on merge is an error" $ + assertParseFail "dup-inner" "{ a.b = 1; a = { b = 2; }; }", + runTest "inherit conflicting with a definition is an error" $ + assertParseFail "dup-inherit" "let q = 1; in { inherit q; q = 2; }", + runTest "attrpath into a non-set is an error" $ + assertParseFail "merge-non-set" "{ a = 1; a.b = 2; }", + -- rec markers in attrpath merging follow upstream's addAttr: the + -- existing set's marker governs the result; the new set's marker is + -- discarded. + runTest "merge into rec literal keeps rec (sibling visible)" $ + assertEval "merge-rec-keep" "{ a = rec { b = 1; }; a.c = b; }.a.c" (VInt 1), + runTest "merged-in rec marker is discarded (outer binding wins)" $ + assertEval "merge-rec-discard" "let d = 7; in { a = { x = 1; }; a = rec { c = d; }; }.a.c" (VInt 7), + -- Exactly upstream's unprefixed global surface: fetchurl and toFile + -- exist only under builtins. + runTest "bare fetchurl is not a global" $ + assertEvalFail "no-bare-fetchurl" "fetchurl", + runTest "bare toFile is not a global" $ + assertEvalFail "no-bare-tofile" "toFile", + -- Dynamic keys colliding with an existing attr are an eval error, + -- never a silent last-win merge. + runTest "dynamic key colliding with static errors" $ + assertEvalFail "dyn-collide" "{ b = 1; ${\"b\"} = 2; }", + runTest "rec dynamic key colliding with static errors" $ + assertEvalFail "dyn-collide-rec" "rec { b = 1; p.q = 1; ${\"b\"} = 2; }", + -- Higher-order list builtins pass elements as unforced thunks: an + -- element the function never inspects may throw without failing. + runTest "filter does not force elements" $ + assertEval "filter-lazy" "builtins.length (builtins.filter (x: true) [ (builtins.throw \"never\") ])" (VInt 1), + runTest "any does not force undecided elements" $ + assertEval "any-lazy" "builtins.any (x: x) [ true (builtins.throw \"never\") ]" (VBool True), + runTest "foldl' passes elements unforced" $ + assertEval "foldl-lazy" "builtins.foldl' (a: b: a) 0 [ (builtins.throw \"never\") ]" (VInt 0), + -- Attrset equality stops at the first mismatch; later pairs are + -- never forced. + runTest "attrset eq short-circuits" $ + assertEval "eq-short" "{ a = 1; b = builtins.throw \"never\"; } == { a = 2; b = builtins.throw \"never\"; }" (VBool False), + -- toString of a float is std::to_string's fixed 6 decimals; value + -- printing and toJSON keep the trimmed form. + runTest "toString float has fixed 6 decimals" $ + assertEval "tostr-float" "builtins.toString 1.5" (mkStr "1.500000"), + runTest "toJSON float stays trimmed" $ + assertEval "tojson-float" "builtins.toJSON 1.5" (mkStr "1.5"), + -- path + string-with-context is an error (a store-path reference + -- cannot survive inside a path value). + runTest "path plus string with context errors" $ + assertEvalFail "path-ctx" "./x + (derivation { name = \"q\"; system = \"s\"; builder = \"/b\"; }).drvPath", + -- builtins.toJSON honors __toString, preferring it over outPath + runTest "toJSON __toString" $ + assertEval "tojson-tostr" "builtins.toJSON { __toString = self: \"x\"; }" (mkStr "\"x\""), + runTest "toJSON __toString beats outPath" $ + assertEval "tojson-tostr-out" "builtins.toJSON { __toString = self: \"a\"; outPath = \"/b\"; }" (mkStr "\"a\""), + runTest "toJSON outPath still works" $ + assertEval "tojson-out" "builtins.toJSON { outPath = \"/b\"; }" (mkStr "\"/b\""), + -- String interpolation is strict (coerceMore = False): scalars error + runTest "interp rejects int" $ + assertEvalFail "interp-int" "\"v${1}\"", + runTest "interp rejects bool" $ + assertEvalFail "interp-bool" "\"${true}\"", + runTest "interp rejects null" $ + assertEvalFail "interp-null" "\"${null}\"", + runTest "concatStringsSep rejects int" $ + assertEvalFail "ccs-int" "builtins.concatStringsSep \",\" [ 1 2 ]", + -- builtins.toString stays permissive + runTest "toString still coerces int" $ + assertEval "tostr-int" "builtins.toString 1" (mkStr "1"), + runTest "interp via toString works" $ + assertEval "interp-tostr" "\"v${builtins.toString 1}\"" (mkStr "v1"), + -- builtins.substring rejects a negative start position + runTest "substring negative start errors" $ + assertEvalFail "substr-neg" "builtins.substring (0 - 1) 3 \"hello\"", + -- an integer literal that overflows Int64 is a parse error, not a wrap + runTest "integer literal overflow errors" $ + assertParseFail "int-overflow" "99999999999999999999", + -- float exponents and leading-dot floats lex per the Nix grammar + runTest "float exponent lexes as float" $ + assertEval "float-exp-type" "builtins.typeOf 6.022e23" (mkStr "float"), + runTest "float negative exponent lexes" $ + assertEval "float-negexp-type" "builtins.typeOf 1.0e-3" (mkStr "float"), + runTest "float exponent value" $ + assertEval "float-exp-val" "1.5e1 == 15.0" (VBool True), + runTest "leading-dot float lexes as float" $ + assertEval "leading-dot-type" "builtins.typeOf .5" (mkStr "float"), + runTest "leading-dot float value" $ + assertEval "leading-dot-val" ".5 == 0.5" (VBool True), + -- PureEval tryEval must NOT catch abort - it propagates (matches C++ Nix) + runTest "tryEval does not catch abort" $ + assertEvalFail "tryeval-abort" "(builtins.tryEval (builtins.abort \"x\")).success", + -- every builtin in the registry (the source of builtinNames/builtinArgModes) + -- is actually exposed in the builtins set - guards against builtinRegistry + -- drifting from the exposed builtins + runTest "every registered builtin is exposed" $ + let missing = [n | n <- builtinNames, evalNix ("builtins ? \"" <> n <> "\"") /= Right (VBool True)] + in if null missing then Pass else Fail ("not exposed: " <> T.intercalate ", " missing) + ] + +-- | Pure hash decode/digest helpers shared by eval (fixed-output paths) and +-- the builder (builtin:fetchurl verification). +testHashHelpers :: IO [Bool] +testHashHelpers = do + putStrLn "hash/decode-helpers" + sequence + [ -- The incremental digest is the streaming twin of the one-shot: + -- chunked input must produce identical bytes for every algorithm. + runTest "incremental digest matches one-shot across algorithms" $ + let chunks = ["nova", "-", "nix", " streams", BS.replicate 1000 55] + agrees algo = case (Hash.hashInitWithAlgo algo, Hash.rawHashWithAlgo algo (BS.concat chunks)) of + (Just ctx0, Just expected) -> + Hash.hashFinalizeBytes (foldl' Hash.hashUpdateChunk ctx0 chunks) == expected + _ -> False + in if all agrees ["sha256", "sha512", "sha1", "md5"] + then Pass + else Fail "incremental and one-shot digests disagree", + runTest "incremental digest rejects an unknown algorithm" $ + case Hash.hashInitWithAlgo "blake3" of + Nothing -> Pass + Just _ -> Fail "unknown algorithm accepted", + runTest "hexToBytes empty" $ assertEqual "empty" (Just BS.empty) (Hash.hexToBytes ""), + runTest "hexToBytes deadbeef" $ + assertEqual "deadbeef" (Just (BS.pack [0xde, 0xad, 0xbe, 0xef])) (Hash.hexToBytes "deadbeef"), + runTest "hexToBytes uppercase" $ + assertEqual "DEADBEEF" (Just (BS.pack [0xde, 0xad, 0xbe, 0xef])) (Hash.hexToBytes "DEADBEEF"), + runTest "hexToBytes odd length rejected" $ assertEqual "odd" Nothing (Hash.hexToBytes "abc"), + runTest "hexToBytes non-hex rejected" $ assertEqual "nonhex" Nothing (Hash.hexToBytes "zz"), + runTest "rawHashWithAlgo sha256 empty == known vector" $ + assertEqual + "sha256-empty" + (Hash.hexToBytes "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855") + (Hash.rawHashWithAlgo "sha256" BS.empty), + runTest "rawHashWithAlgo unknown algo rejected" $ + assertEqual "unknown" Nothing (Hash.rawHashWithAlgo "sha3-256" (BS.pack [1, 2, 3])), + -- verifyFetchHash: the composed builtin:fetchurl integrity gate that + -- guards every fixed-output seed fetch + runTest "verifyFetchHash accepts a matching flat hash" $ + assertEqual + "fetch-hash-ok" + (Right ()) + (verifyFetchHash "https://x/f.tar.gz" (fetchOut "sha256" sha256Hello) "hello"), + runTest "verifyFetchHash rejects mismatched bytes" $ + case verifyFetchHash "https://x/f.tar.gz" (fetchOut "sha256" sha256Hello) "world" of + Left (_, msg) | "hash mismatch" `T.isInfixOf` msg -> Pass + other -> Fail ("expected mismatch rejection, got: " <> T.pack (show other)), + runTest "verifyFetchHash rejects a malformed expected hash" $ + case verifyFetchHash "https://x/f" (fetchOut "sha256" "zz-not-hex") "hello" of + Left (_, msg) | "malformed expected hash" `T.isInfixOf` msg -> Pass + other -> Fail ("expected malformed-hash rejection, got: " <> T.pack (show other)), + runTest "verifyFetchHash rejects an unsupported algorithm" $ + case verifyFetchHash "https://x/f" (fetchOut "sha3-256" "00") "hello" of + Left (_, msg) | "unsupported hash algorithm" `T.isInfixOf` msg -> Pass + other -> Fail ("expected unsupported-algo rejection, got: " <> T.pack (show other)), + runTest "verifyFetchHash rejects recursive mode rather than comparing flat" $ + case verifyFetchHash "https://x/f" (fetchOut "r:sha256" sha256Hello) "hello" of + Left (_, msg) | "recursive" `T.isInfixOf` msg -> Pass + other -> Fail ("expected recursive-mode rejection, got: " <> T.pack (show other)) + ] + where + -- sha256 of the ASCII bytes "hello". + sha256Hello = "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824" + fetchOut algo hash = + DerivationOutput + { doName = "out", + doPath = StorePath (T.replicate 32 "f") "fetched", + doHashAlgo = algo, + doHash = hash + } + +-- --------------------------------------------------------------------------- +-- Tests: NAR and hash known-answer vectors +-- --------------------------------------------------------------------------- + +-- | Encode one NAR string per the spec: little-endian u64 length, the +-- bytes, zero-padding to the next 8-byte boundary. Written here from the +-- format definition, deliberately independent of nova-cache's encoder, so +-- these vectors pin the wire layout rather than the library against +-- itself. +narSpecStr :: BS.ByteString -> BS.ByteString +narSpecStr s = lenLE <> s <> padding + where + n = BS.length s + lenLE = BS.pack [fromIntegral ((n `shiftR` (8 * i)) .&. 0xff) | i <- [0 .. 7]] + padding = BS.replicate ((8 - n `mod` 8) `mod` 8) 0 + +-- | Hand-encoded NAR of a directory holding an executable, a plain file, +-- and a symlink - covering entry ordering, the executable marker, content +-- padding, and all node kinds. +narSpecVector :: BS.ByteString +narSpecVector = + BS.concat $ + map + narSpecStr + [ "nix-archive-1", + "(", + "type", + "directory", + "entry", + "(", + "name", + "bin", + "node", + "(", + "type", + "directory", + "entry", + "(", + "name", + "tool", + "node", + "(", + "type", + "regular", + "executable", + "", + "contents", + "#!x", + ")", + ")", + ")", + ")", + "entry", + "(", + "name", + "data.txt", + "node", + "(", + "type", + "regular", + "contents", + "hello\n", + ")", + ")", + "entry", + "(", + "name", + "link", + "node", + "(", + "type", + "symlink", + "target", + "data.txt", + ")", + ")", + ")" + ] + +-- | The in-memory tree 'narSpecVector' encodes. +narSpecTree :: NAR.NarEntry +narSpecTree = + NAR.NarDirectory + [ ("bin", NAR.NarDirectory [("tool", NAR.NarRegular True "#!x")]), + ("data.txt", NAR.NarRegular False "hello\n"), + ("link", NAR.NarSymlink "data.txt") + ] + +-- | Hand-encoded NAR of just @data.txt@, for the on-disk addToStore vector. +-- No executable entry, so the vector stays a fixture for addToStore rather +-- than for the exec bit; 'testExecBit' covers that on both platforms. +narSpecFileVector :: BS.ByteString +narSpecFileVector = + BS.concat $ + map + narSpecStr + [ "nix-archive-1", + "(", + "type", + "directory", + "entry", + "(", + "name", + "data.txt", + "node", + "(", + "type", + "regular", + "contents", + "hello\n", + ")", + ")", + ")" + ] + +-- | fromTOML: multi-line values (the Cargo.lock shapes) and comment +-- placement relative to strings. +testFromTOML :: IO [Bool] +testFromTOML = do + putStrLn "eval/fromTOML" + sequence + [ -- Key splitting and logical-line joining accumulate in chunks, so + -- cost is linear in the input (per-character/per-line append was + -- quadratic). The watchdog turns a cost regression into a FAIL + -- rather than a stuck suite. + runTestM "fromTOML long key parses in linear time" $ do + let source = + "builtins.length (builtins.attrNames (builtins.fromTOML \"" + <> T.replicate 200000 "k" + <> " = 1\"))" + counted = evalNix source == Right (VInt 1) + outcome <- timeout walkWatchdogMicros (evaluate counted) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong parse for a long key" + Nothing -> Fail "long key did not parse promptly", + runTestM "fromTOML many continued lines join in linear time" $ do + -- 4000 physical lines of 50 elements each: one ~400KB logical + -- line, one 200000-element array. + let line = T.intercalate " " (replicate 50 "1,") + body = "x = [\n" <> T.intercalate "\n" (replicate 4000 line) <> "\n]" + source = "builtins.length (builtins.fromTOML \"" <> body <> "\").x" + counted = evalNix source == Right (VInt 200000) + outcome <- timeout walkWatchdogMicros (evaluate counted) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong parse for continued lines" + Nothing -> Fail "continued lines did not join promptly", + runTest "multi-line array" $ + assertEval + "toml-ml-array" + "builtins.concatStringsSep \",\" (builtins.fromTOML \"deps = [\\n \\\"bar\\\",\\n \\\"baz\\\",\\n]\\n\").deps" + (mkStr "bar,baz"), + runTest "Cargo.lock package shape" $ + assertEval + "toml-cargo-lock" + "(builtins.elemAt (builtins.fromTOML \"[[package]]\\nname = \\\"foo\\\"\\ndependencies = [\\n \\\"bar\\\",\\n]\\n\").package 0).name" + (mkStr "foo"), + runTest "multi-line basic string" $ + assertEval + "toml-ml-string" + "(builtins.fromTOML \"s = \\\"\\\"\\\"\\nline1\\nline2\\\"\\\"\\\"\").s" + (mkStr "line1\nline2"), + runTest "multi-line literal string" $ + assertEval + "toml-ml-literal" + "(builtins.fromTOML \"s = '''\\nkeep'''\").s" + (mkStr "keep"), + runTest "comment inside a multi-line array" $ + assertEval + "toml-ml-comment" + "builtins.concatStringsSep \",\" (builtins.fromTOML \"deps = [ # opening\\n \\\"bar\\\", # trailing\\n]\").deps" + (mkStr "bar"), + runTest "hash inside a string is content" $ + assertEval + "toml-hash-content" + "(builtins.fromTOML \"s = \\\"\\\"\\\"a#b\\\"\\\"\\\"\").s" + (mkStr "a#b"), + runTest "single-line values still parse" $ + assertEval + "toml-single-line" + "(builtins.fromTOML \"x = 4\\ny = \\\"z\\\" # cmt\").y" + (mkStr "z") + ] + +testAttrPath :: IO [Bool] +testAttrPath = do + putStrLn "\n-- Attribute paths (build -A) --" + sequence + [ runTest "a bare name is one component" $ + assertEqual "single" (Right ["hello"]) (parseAttrPath "hello"), + runTest "dots separate components" $ + assertEqual "dotted" (Right ["a", "b", "c"]) (parseAttrPath "a.b.c"), + runTest "a quoted component carries a dot" $ + assertEqual "quoted" (Right ["a", "b.c", "d"]) (parseAttrPath "a.\"b.c\".d"), + -- Upstream's quotes concatenate rather than delimit, so a quoted run + -- glues onto whatever sits beside it instead of standing alone. + runTest "quotes concatenate onto the surrounding name" $ + assertEqual + "glued" + [Right ["foobar"], Right ["foobar"]] + [parseAttrPath "\"foo\"bar", parseAttrPath "foo\"bar\""], + -- The last component is kept only when non-empty, so these three + -- select nothing at all rather than naming an empty attribute. + runTest "an empty path selects nothing" $ + assertEqual + "nothing" + [Right [], Right [], Right ["a"]] + [parseAttrPath "", parseAttrPath "\"\"", parseAttrPath "a."], + -- An interior empty component survives tokenizing; selection rejects + -- it, and only after checking the type of what it would index. + runTest "an interior empty component survives tokenizing" $ + assertEqual + "interior" + [Right ["", "a"], Right ["a", "", "b"]] + [parseAttrPath ".a", parseAttrPath "a..b"], + runTest "an unclosed quote is an error" $ + assertEqual + "unclosed" + (Left "missing closing quote in selection path \'a.\"b\'") + (parseAttrPath "a.\"b") + ] + +-- | The remembered-fetch record, on its own. All three functions are pure, +-- and every property that keeps a warm cache honest is decided here: what +-- shares an entry, what round-trips, and what a torn file decodes to. +testFetchCache :: IO [Bool] +testFetchCache = do + putStrLn "eval/fetch-cache" + sequence + [ runTest "the key separates every input that decides the answer" $ + let base = fetchCacheKey "https://example.com/r" "source" "abc" False False + variants = + [ fetchCacheKey "https://example.com/s" "source" "abc" False False, + fetchCacheKey "https://example.com/r" "other" "abc" False False, + fetchCacheKey "https://example.com/r" "source" "def" False False, + fetchCacheKey "https://example.com/r" "source" "abc" True False, + -- shallow decides revCount, so it cannot share an entry + -- with a full clone of the same revision. + fetchCacheKey "https://example.com/r" "source" "abc" False True + ] + in assertEqual "collisions with the base key" [] (filter (== base) variants), + runTest "the same fetch keys the same both times" $ + assertEqual + "repeat" + (fetchCacheKey "https://example.com/r" "source" "abc" True True) + (fetchCacheKey "https://example.com/r" "source" "abc" True True), + runTest "an entry round-trips through encode and decode" $ + assertEqual "decode . encode" (Just sampleFetchCache) (decodeFetchCache (encodeFetchCache sampleFetchCache)), + runTest "a torn entry decodes to nothing" $ + let whole = encodeFetchCache sampleFetchCache + -- Every prefix, so the cut lands in each field in turn. The + -- last field is the one that matters: a cut before it leaves + -- fewer than five lines and is rejected on shape alone, while + -- a cut inside narHash still leaves five. + torn = [T.take n whole | n <- [0 .. T.length whole - 1]] + in assertEqual "prefixes that decoded" [] (filter (isJust . decodeFetchCache) torn), + runTest "a non-decimal count is not an entry" $ + assertEqual + "revCount" + Nothing + (decodeFetchCache (replaceCount (encodeFetchCache sampleFetchCache) "12x")), + -- The hit path itself, end to end through builtins.fetchGit. Nothing + -- here can reach the network: the stub's createScratchDir throws, so + -- a Right at all proves the fetch was skipped, and every field comes + -- from the entry rather than from git. + runTest "a warm entry answers builtins.fetchGit without fetching" $ + case evalWarmFetchGit sampleFetchCache (Set.singleton (fcStorePath sampleFetchCache)) of + Left err -> Fail ("a warm cache still tried to fetch: " <> err) + Right val -> + assertEqual + "fields" + [ ("outPath", VPath (fcStorePath sampleFetchCache)), + ("rev", mkStr (fcRev sampleFetchCache)), + ("revCount", VInt 1234), + ("narHash", mkStr ("sha256-" <> fcNarHash sampleFetchCache)) + ] + (fetchGitFields val ["outPath", "rev", "revCount", "narHash"]), + -- The guard on the hit, on the axis that matters. doesPathExist is + -- False throughout the stub and adoptStorePath is what decides, so a + -- hit that consulted mere existence would fail this and a hit that + -- adopts the path passes the case above. Adoption is what records + -- the store write, and a hit that skipped it would hand back an + -- outPath no derivation naming it could be built against. + runTest "an entry whose path cannot be adopted refetches" $ + case evalWarmFetchGit sampleFetchCache Set.empty of + Right _ -> Fail "an unadoptable entry was served from the cache" + Left err + | "createScratchDir" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected a refetch, got: " <> err), + runTest "a bare ref is never served from the cache" $ + -- Whatever the cache holds, a ref means "wherever this branch + -- points now", so the entry must not be consulted at all. + case evalNixStubWith + (warmEnv sampleFetchCache (Set.singleton (fcStorePath sampleFetchCache))) + "builtins.fetchGit { url = \"https://example.com/r\"; ref = \"main\"; }" of + Right _ -> Fail "a bare ref was served from the cache" + Left err + | "createScratchDir" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected a fetch, got: " <> err), + runTest "a hash that is not base64 sha256 is not an entry" $ + assertEqual + "narHash" + [Nothing, Nothing, Nothing] + ( map + (decodeFetchCache . encodeFetchCache) + [ sampleFetchCache {fcNarHash = T.take 43 (fcNarHash sampleFetchCache)}, + sampleFetchCache {fcNarHash = T.replicate 44 "="}, + sampleFetchCache {fcNarHash = T.take 43 (fcNarHash sampleFetchCache) <> "A"} + ] + ) + ] + where + -- Swap the encoded revCount line, which encodeFetchCache cannot + -- produce: the field is an Integer on the way in. + replaceCount encoded replacement = case T.splitOn "\n" encoded of + [storePath, rev, _, lastModified, narHash] -> + T.intercalate "\n" [storePath, rev, replacement, lastModified, narHash] + _ -> encoded + +-- | A stub store whose cache is warm for 'evalWarmFetchGit'\'s fetch, and +-- which will adopt exactly the given store paths. +warmEnv :: FetchCache -> Set.Set Text -> StubEnv +warmEnv fields adoptable = + (stubEnv Map.empty) + { seFetchCache = + Map.singleton + (fetchCacheKey "https://example.com/r" "source" warmFetchGitRev False False) + (encodeFetchCache fields), + seAdoptable = adoptable + } + +-- | The pinned revision 'evalWarmFetchGit' asks for. +warmFetchGitRev :: Text +warmFetchGitRev = T.replicate 40 "b" + +-- | Evaluate a pinned @builtins.fetchGit@ against a warm cache. +evalWarmFetchGit :: FetchCache -> Set.Set Text -> Either Text NixValue +evalWarmFetchGit fields adoptable = + evalNixStubWith + (warmEnv fields adoptable) + ("builtins.fetchGit { url = \"https://example.com/r\"; rev = \"" <> warmFetchGitRev <> "\"; }") + +-- | Read the named attributes off a @fetchGit@ result, in the order asked. +fetchGitFields :: NixValue -> [Text] -> [(Text, NixValue)] +fetchGitFields val names = case val of + VAttrs attrs -> + [ (name, value) + | name <- names, + Just thunk <- [attrSetLookup name attrs], + Just value <- [readThunkValue thunk] + ] + _ -> [] + +-- | One recorded fetch, with a real 44-character base64 sha256. +sampleFetchCache :: FetchCache +sampleFetchCache = + FetchCache + { fcStorePath = "/nix/store/" <> T.replicate 32 "a" <> "-source", + fcRev = T.replicate 40 "b", + fcRevCount = 1234, + fcLastModified = 1700000000, + fcNarHash = T.replicate 43 "A" <> "=" + } + +-- | Which derivations this machine will spawn, and how. +-- +-- The distinction that matters is between the two answers that used to be +-- one: a derivation for this platform needs no launcher, and a derivation +-- for another platform with no launcher configured is not the same thing. +testExecWrapper :: IO [Bool] +testExecWrapper = do + putStrLn "builder/exec-wrapper" + sequence + [ runTest "a derivation for this platform is spawned directly" $ + assertEqual + "native" + SpawnNative + (execWrapperFor (wrapperConfig [(platformToText foreignPlatform, "/usr/bin/wine")]) (drvFor currentPlatform)), + runTest "a configured foreign system spawns through its launcher" $ + assertEqual + "wrapped" + (SpawnThrough "/usr/bin/wine") + (execWrapperFor (wrapperConfig [(platformToText foreignPlatform, "/usr/bin/wine")]) (drvFor foreignPlatform)), + -- The finding this exists for: without a distinct answer here, a + -- foreign builder was spawned natively and failed in the loader, + -- after the whole closure had already been realized. + runTest "an unconfigured foreign system is refused, not spawned" $ + assertEqual + "unsupported" + (SpawnUnsupported (platformToText foreignPlatform)) + (execWrapperFor (wrapperConfig []) (drvFor foreignPlatform)), + -- A 32-bit derivation on a 64-bit host of the same OS is native, as + -- upstream's extra-platforms makes it, launcher or no launcher; on + -- any other host it is as foreign as anything else. + runTest "an i686 derivation spawns natively on its x86_64 host, whatever is configured" $ + assertEqual + "wow64" + [SpawnNative, SpawnNative, SpawnNative, SpawnNative] + [ spawnFor X86_64_Windows (wrapperConfig []) (drvFor I686_Windows), + spawnFor X86_64_Windows (wrapperConfig [("i686-windows", "/usr/bin/wine")]) (drvFor I686_Windows), + spawnFor X86_64_Linux (wrapperConfig []) (drvFor I686_Linux), + spawnFor X86_64_Linux (wrapperConfig [("i686-linux", "/opt/qemu")]) (drvFor I686_Linux) + ], + runTest "an i686 derivation elsewhere is refused or launched like any foreign system" $ + assertEqual + "elsewhere" + [SpawnUnsupported "i686-windows", SpawnThrough "/usr/bin/wine", SpawnUnsupported "i686-linux"] + [ spawnFor X86_64_Linux (wrapperConfig []) (drvFor I686_Windows), + spawnFor X86_64_Linux (wrapperConfig [("i686-windows", "/usr/bin/wine")]) (drvFor I686_Windows), + spawnFor Aarch64_Darwin (wrapperConfig []) (drvFor I686_Linux) + ], + -- The system string is the derivation's own spelling, matched + -- exactly. The documentation once named a different one, which + -- parsed, stored, and then never matched anything. + runTest "SYSTEM=PATH splits at the first separator" $ + assertEqual + "specs" + (Right (Map.fromList [("x86_64-windows", "/usr/bin/wine"), ("aarch64-linux", "/opt/qemu=static/qemu")])) + (execWrapperConfig ["x86_64-windows=/usr/bin/wine", "aarch64-linux=/opt/qemu=static/qemu"]), + runTest "no specs is an empty map, not an error" $ + assertEqual "empty" (Right Map.empty) (execWrapperConfig []), + runTest "a spec missing either half is rejected" $ + assertEqual + "malformed" + (replicate 4 True) + (map (either (const True) (const False) . execWrapperConfig . pure) ["wine", "=wine", "x86_64-windows=", ""]), + -- Last-one-wins would run a build through a launcher the operator + -- did not think they had asked for. + runTest "naming one system twice is rejected" $ + assertEqual + "duplicate" + (Left "--exec-wrapper names x86_64-windows twice") + (execWrapperConfig ["x86_64-windows=/usr/bin/wine", "x86_64-windows=/usr/bin/wine64"]), + runTest "a launcher keyed on any other spelling does not match" $ + assertEqual + "near-miss keys" + (replicate 3 (SpawnUnsupported (platformToText foreignPlatform))) + ( [ execWrapperFor (wrapperConfig [(key, "/usr/bin/wine")]) (drvFor foreignPlatform) + | key <- ["x86-windows", "windows", T.toUpper (platformToText foreignPlatform)] + ] + ) + ] + where + -- Some platform this test is not running on, so "foreign" is foreign + -- whichever host runs the suite. + foreignPlatform = + if currentPlatform == X86_64_Windows then X86_64_Linux else X86_64_Windows + wrapperConfig entries = + (defaultBuildConfig (StoreDir "/nix/store")) {bcExecWrappers = Map.fromList entries} + drvFor platform = + Derivation + { drvOutputs = [DerivationOutput "out" (StorePath (T.replicate 32 "a") "spawn") "" ""], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = platform, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + +testFetchMirrors :: IO [Bool] +testFetchMirrors = do + putStrLn "builder/fetch-mirrors" + sequence + [ runTest "fetch URLs preserve the legacy single URL" $ + assertEqual + "url" + (Right ("https://a/file%20name" :| [])) + (fetchUrlsFromEnv (Map.singleton "url" "https://a/file%20name")), + runTest "fetch URLs prefer the explicit ordered list" $ + assertEqual + "urls" + (Right ("https://a" :| ["https://b"])) + (fetchUrlsFromEnv (Map.fromList [("url", "https://ignored"), ("urls", " https://a\t https://b\n")])), + runTest "fetch URLs preserve non-ASCII whitespace within a URL" $ + let url = "https://a/has\xA0space" + in assertEqual + "non-ASCII URL" + (Right (url :| ["https://b"])) + (fetchUrlsFromEnv (Map.singleton "urls" (TE.encodeUtf8 (url <> " https://b")))), + runTest "fetch URLs reject missing, empty and invalid UTF-8 inputs" $ + assertEqual + "invalid" + (replicate 5 True) + ( map + (either (const True) (const False) . fetchUrlsFromEnv) + [Map.empty, Map.singleton "url" "", Map.fromList [("urls", " "), ("url", "https://ignored")], Map.singleton "url" (BS.pack [255]), Map.singleton "urls" (BS.pack [255])] + ), + runTestM "mirror policy retries timeout and hash failures in order" $ do + calls <- newIORef [] + let attempt url = do + atomicModifyIORef' calls (\seen -> (seen ++ [url], ())) + pure $ case url of + "slow" -> Left "download timeout" + "corrupt" -> Left "hash mismatch" + _ -> Right ("verified" :: Text) + result <- tryFetchUrlsWith attempt ("slow" :| ["corrupt", "good", "unused"]) + seen <- readIORef calls + pure (assertEqual "ordered attempts" (Right "verified", ["slow", "corrupt", "good"]) (result, seen)), + runTestM "mirror policy returns every failure in order" $ do + result <- tryFetchUrlsWith (pure . Left) ("first failure" :| ["second failure"]) + pure (assertEqual "failures" (Left "first failure\nsecond failure" :: Either Text ()) result), + runTestM "mirror policy does not evaluate candidates after success" $ do + let attempt "good" = pure (Right "good") + attempt _ = fail "unused mirror attempted" + result <- tryFetchUrlsWith attempt ("good" :| ["unused"]) + pure (assertEqual "first success" (Right "good" :: Either Text Text) result), + -- The per-URL retry policy, with its effects injected: upstream's five + -- attempts and doubling delay from 250 ms, spent on transient failures + -- only. + runTest "retry delay is upstream's 250 ms doubling, with jitter on the exponent" $ + assertEqual + "delays" + ([250, 500, 1000, 2000], 353, 2828) + ( map (\retry -> retryDelayMs defaultFetchRetryPolicy retry 0) [1 .. 4], + retryDelayMs defaultFetchRetryPolicy 1 0.5, + retryDelayMs defaultFetchRetryPolicy 4 0.5 + ), + runTestM "retry policy retries a transient failure with backoff until it succeeds" $ do + calls <- newIORef (0 :: Int) + sleeps <- newIORef [] + warnings <- newIORef [] + let effects = + RetryEffects + { reSleepMs = \ms -> atomicModifyIORef' sleeps (\seen -> (seen ++ [ms], ())), + reJitter = pure 0, + reWarn = \msg -> atomicModifyIORef' warnings (\seen -> (seen ++ [msg], ())) + } + attempt = do + n <- atomicModifyIORef' calls (\c -> (c + 1, c + 1)) + pure (if n < 3 then Left (Subst.TransientFailure "HTTP 503 fetching u") else Right ("verified" :: Text)) + result <- retryTransient defaultFetchRetryPolicy effects attempt + seenSleeps <- readIORef sleeps + seenWarnings <- readIORef warnings + pure + ( assertEqual + "two retries" + (Right "verified", [250, 500], ["HTTP 503 fetching u; retrying in 250 ms", "HTTP 503 fetching u; retrying in 500 ms"]) + (result, seenSleeps, seenWarnings) + ), + runTestM "retry policy gives up after five attempts" $ do + calls <- newIORef (0 :: Int) + sleeps <- newIORef [] + let effects = RetryEffects {reSleepMs = \ms -> atomicModifyIORef' sleeps (\seen -> (seen ++ [ms], ())), reJitter = pure 0, reWarn = \_ -> pure ()} + attempt = atomicModifyIORef' calls (\c -> (c + 1, ())) >> pure (Left (Subst.TransientFailure "timeout") :: Either Subst.AttemptFailure ()) + result <- retryTransient defaultFetchRetryPolicy effects attempt + seenCalls <- readIORef calls + seenSleeps <- readIORef sleeps + pure (assertEqual "spent" (Left (Subst.TransientFailure "timeout"), 5, [250, 500, 1000, 2000]) (result, seenCalls, seenSleeps)), + runTestM "retry policy does not retry a fatal failure" $ do + calls <- newIORef (0 :: Int) + let effects = RetryEffects {reSleepMs = \_ -> fail "slept on a fatal failure", reJitter = pure 0, reWarn = \_ -> fail "warned on a fatal failure"} + attempt = atomicModifyIORef' calls (\c -> (c + 1, ())) >> pure (Left (Subst.FatalFailure "HTTP 404") :: Either Subst.AttemptFailure ()) + result <- retryTransient defaultFetchRetryPolicy effects attempt + seenCalls <- readIORef calls + pure (assertEqual "once" (Left (Subst.FatalFailure "HTTP 404"), 1) (result, seenCalls)), + -- The classification tables, against upstream's (filetransfer.cc at + -- 2.24.9): which statuses and which client failures a retry can outlive. + runTest "status classification matches upstream's transfer layer" $ + let transient status = case fetchStatusFailure "u" status of + Subst.TransientFailure _ -> True + Subst.FatalFailure _ -> False + in assertEqual + "classes" + (replicate 6 True, replicate 10 False) + ( map transient [HTTP.status408, HTTP.status429, HTTP.status500, HTTP.status502, HTTP.status503, HTTP.status504], + map transient [HTTP.status404, HTTP.status410, HTTP.status401, HTTP.status403, HTTP.status407, HTTP.status400, HTTP.status418, HTTP.status501, HTTP.status505, HTTP.status511] + ), + runTest "status verdicts follow upstream's FileTransfer::Error, in its order" $ + assertEqual + "verdicts" + (replicate 2 NotFound ++ replicate 3 Forbidden ++ replicate 5 Misc ++ replicate 6 Transient) + ( map + statusError + [ HTTP.status404, + HTTP.status410, + HTTP.status401, + HTTP.status403, + HTTP.status407, + HTTP.status400, + HTTP.status418, + HTTP.status501, + HTTP.status505, + HTTP.status511, + HTTP.status408, + HTTP.status429, + HTTP.status500, + HTTP.status502, + HTTP.status503, + HTTP.status504 + ] + ), + runTest "exception classification retries transport failures only" $ + let transient err = case fetchExceptionFailure "u" err of + Subst.TransientFailure _ -> True + Subst.FatalFailure _ -> False + request = HTTP.defaultRequest + in assertEqual + "classes" + (replicate 4 True, replicate 4 False) + ( map + transient + [ HTTP.HttpExceptionRequest request HTTP.ConnectionTimeout, + HTTP.HttpExceptionRequest request (HTTP.ResponseBodyTooShort 100 5), + HTTP.HttpExceptionRequest request HTTP.ResponseTimeout, + HTTP.HttpExceptionRequest request (HTTP.InternalException (toException connectionReset)) + ], + map + transient + [ HTTP.InvalidUrlException "ftp://x" "Invalid scheme", + HTTP.HttpExceptionRequest request (HTTP.InvalidDestinationHost ""), + HTTP.HttpExceptionRequest request HTTP.TlsNotSupported, + HTTP.HttpExceptionRequest request (HTTP.TooManyRedirects []) + ] + ), + -- The attempt boundary: an IOException there is a failure writing + -- the output, and an asynchronous exception is never caught. + runTestM "a failure writing the download is fatal" $ do + outcome <- throwIO (userError "disk full") `catches` transferFailureHandlers "u" :: IO (Either Subst.AttemptFailure ()) + pure $ case outcome of + Left (Subst.FatalFailure _) -> Pass + other -> Fail ("expected a fatal failure, got: " <> T.pack (show other)), + runTestM "an interrupt passes through the attempt boundary untouched" $ do + outcome <- try (throwIO ThreadKilled `catches` transferFailureHandlers "u" :: IO (Either Subst.AttemptFailure ())) + pure $ case outcome of + Left err | fromException err == Just ThreadKilled -> Pass + other -> Fail ("expected ThreadKilled to propagate, got: " <> T.pack (show other)), + -- The body reader: the HTTP client wraps a failure opening the + -- response but not one reading its body, where a reset mid-body + -- arrives as a bare IOException. Read through transferBodyReader it + -- is a transport failure, retried like any other. + runTestM "a connection reset mid-body is a transport failure, not a failed write" $ do + let reader = transferBodyReader HTTP.defaultRequest (throwIO connectionReset) + outcome <- (Right <$> reader) `catches` transferFailureHandlers "u" + pure $ case outcome of + Left (Subst.TransientFailure _) -> Pass + other -> Fail ("expected a transient failure, got: " <> T.pack (show other)), + runTestM "the body reader passes the client's own failures and an interrupt through unchanged" $ do + let tooShort = HTTP.HttpExceptionRequest HTTP.defaultRequest (HTTP.ResponseBodyTooShort 100 5) + clientFailure <- try (transferBodyReader HTTP.defaultRequest (throwIO tooShort)) + interrupt <- try (transferBodyReader HTTP.defaultRequest (throwIO ThreadKilled)) + chunk <- transferBodyReader HTTP.defaultRequest (pure "bytes") + pure $ case (clientFailure, interrupt) of + (Left (HTTP.HttpExceptionRequest _ (HTTP.ResponseBodyTooShort 100 5)), Left ThreadKilled) + | chunk == "bytes" -> Pass + other -> Fail ("unexpected body reader outcomes: " <> T.pack (show (other, chunk))), + -- End to end against the loopback fixture, under a policy with a 1 ms + -- base delay: a torn transfer and a server error spend all five + -- attempts before the next mirror; a 404 and a hash mismatch spend one. + runTestM "HTTP mirrors retry a torn transfer, skip a missing or corrupt one, and stop on success" $ + httpCase "fallback" False ["/missing", "/bad", "/partial", "/good", "/unused"] True (["/missing", "/bad"] ++ replicate 5 "/partial" ++ ["/good"]), + runTestM "HTTP fetch retains single-url compatibility" $ + httpCase "legacy" True ["/good"] True ["/good"], + runTestM "a server error is retried five times before the next mirror" $ + httpCase "retried" False ["/error", "/good"] True (replicate 5 "/error" ++ ["/good"]), + runTestM "HTTP failure leaves no output or registration" $ + httpCase "errors" False ["/error", "/missing"] False (replicate 5 "/error" ++ ["/missing"]), + runTestM "hash failure leaves no corrupt output or registration" $ + httpCase "corrupt" False ["/bad", "/partial"] False ("/bad" : replicate 5 "/partial"), + runTestM "cancelling a download releases its lock and does not try another mirror" $ + withFetchurlServer $ \base requests requested -> + withStore "cancel" $ \store config sp -> do + let drv = fixtureDrv sp (Map.singleton "urls" (TE.encodeUtf8 (base <> "/slow " <> base <> "/good"))) + outcome <- timeout 10000000 $ + withAsync (buildDerivation config store drv testDrvPath) $ \worker -> do + requested + cancel worker + waitCatch worker + seen <- requests + valid <- isValid store sp + present <- Dir.doesPathExist (storePathToFilePath (stDir store) sp) + lock <- tryAcquirePathLock (stDir store) sp + mapM_ releasePathLock lock + pure $ case outcome of + Just (Left _) | seen == ["/slow"] && not valid && not present && isJust lock -> Pass + _ -> Fail ("cancellation failed: " <> T.pack (show (outcome, seen, valid, present, isJust lock))) + ] + where + hash = "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824" + -- What http-client 0.7's body reader raises when the server resets + -- the connection mid-body. + connectionReset = mkIOError resourceVanishedErrorType "Network.Socket.recvBuf" Nothing Nothing + withStore label action = do + tmpBase <- getTemporaryDirectory + let root = tmpBase ("nova-nix-test-mirrors-" ++ label) + dir = StoreDir (root "store") + config = (defaultBuildConfig dir) {bcTmpDir = root "build", bcFetchRetry = defaultFetchRetryPolicy {frpBaseDelayMs = 1}} + sp <- either (fail . show) pure (makeFixedOutputPath "mirrors" "sha256" "flat" (sha256Digest "hello")) + bracket_ (forceRemoveIfExists root) (forceRemoveIfExists root) $ + bracket (openStore dir) closeStore $ + \store -> action store config sp + fixtureDrv sp env = + Derivation + { drvOutputs = [DerivationOutput "out" sp "sha256" hash], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = "builtin:fetchurl", + drvArgs = [], + drvEnv = env + } + httpCase label legacy paths succeeds expectedRequests = + withFetchurlServer $ \base requests _ -> + withStore label $ \store config sp -> do + let urls = T.unwords (map (base <>) paths) + env = Map.singleton (if legacy then "url" else "urls") (TE.encodeUtf8 urls) + result <- buildDerivation config store (fixtureDrv sp env) testDrvPath + seen <- requests + valid <- isValid store sp + present <- Dir.doesPathExist (storePathToFilePath (stDir store) sp) + case result of + BuildSuccess _ + | succeeds && valid && present && seen == expectedRequests -> + assertEqual "verified output" "hello" <$> BS.readFile (storePathToFilePath (stDir store) sp) + BuildFailure msg _ | not succeeds && not valid && not present && seen == expectedRequests && not (T.null msg) -> pure Pass + _ -> pure (Fail (T.pack (show (result, seen, valid, present)))) + +-- | The substituter's narinfo and NAR requests under the transfer +-- layer's retry policy, against a loopback cache. The policy's effects +-- are recorded rather than slept, so each case states the requests the +-- cache saw and the backoff the policy chose. +testSubstituterRetry :: IO [Bool] +testSubstituterRetry = do + putStrLn "substituter/retry" + case signedNarInfo of + Left err -> (: []) <$> runTest "substituter retry setup" (Fail (T.pack err)) + Right (publicKey, narInfoText) -> + let narInfoOk = Send (httpResponse "200 OK" (TE.encodeUtf8 narInfoText)) + narOk = Send (httpResponse "200 OK" nar) + unavailable = Send (httpResponse "503 Service Unavailable" "") + unsignedNarInfo = Send (httpResponse "200 OK" (TE.encodeUtf8 (NarInfo.renderNarInfo unsigned))) + trustingCache base = Subst.CacheConfig base [publicKey] + -- Realise a derivation whose one output is the fixture's path, + -- from the caches given, under the adjusted config, in a store + -- kept under the temporary directory rather than at /nix/store. + -- Returns the result and whether the output is the substitute's + -- tree or the builder's file. + realiseFrom label caches adjust = do + tmpBase <- getTemporaryDirectory + let root = tmpBase ("nova-nix-test-subst-fallback-" ++ label) + storeDir = StoreDir (root "store") + drvSP = StorePath (T.replicate 32 "d") "retry.drv" + (builder, builderArgs) + | SI.os == "mingw32" = ("cmd.exe", ["/c", "echo built>%out%"]) + | otherwise = ("/bin/sh", ["-c", "echo built > $out"]) + drv = + Derivation + { drvOutputs = [DerivationOutput "out" sp "" ""], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = builder, + drvArgs = builderArgs, + drvEnv = Map.singleton "name" "retry" + } + config = + adjust + (defaultBuildConfig storeDir) + { bcTmpDir = root "build", + bcCaches = caches, + bcFetchRetry = defaultFetchRetryPolicy {frpBaseDelayMs = 1} + } + outPath = storePathToFilePath storeDir sp + bracket_ (forceRemoveIfExists root) (forceRemoveIfExists root) $ + bracket (openStore storeDir) closeStore $ \store -> do + createDirectoryIfMissing True (root "build") + writeDrv store drv drvSP + result <- buildWithDeps config store drv drvSP + substituted <- Dir.doesFileExist (outPath "data") + built <- Dir.doesFileExist outPath + pure (result, substituted, built) + substitute label narInfoReply narReply = + withHttpServer (route narInfoReply narReply) $ \base requests _ -> do + tmpBase <- getTemporaryDirectory + sleeps <- newIORef [] + warnings <- newIORef [] + let root = tmpBase ("nova-nix-test-subst-retry-" ++ label) + cache = Subst.CacheConfig base [publicKey] 40 + effects = + RetryEffects + { reSleepMs = \ms -> atomicModifyIORef' sleeps (\seen -> (seen ++ [ms], ())), + reJitter = pure 0, + reWarn = \msg -> atomicModifyIORef' warnings (\seen -> (seen ++ [msg], ())) + } + bracket_ (forceRemoveIfExists root) (forceRemoveIfExists root) $ + bracket (openStore (StoreDir root)) closeStore $ \store -> do + result <- Subst.trySubstituteWith defaultFetchRetryPolicy effects store [cache] sp + outcome <- case result of + Subst.SubstSuccess _ lock -> do + releasePathLock lock + Right <$> BS.readFile (storePathToFilePath (stDir store) sp "data") + other -> pure (Left other) + (,,,,) base outcome <$> requests <*> readIORef sleeps <*> readIORef warnings + in sequence $ + [ -- The order two processes meet the locks in decides whether they + -- can deadlock, and each path's narinfo is requested under its + -- lock, so the requests show the order without a race to observe. + runTestM "a substitution takes its output locks in the order a build does" $ + withHttpServer (\_ _ -> Send (httpResponse "404 Not Found" "")) $ \base requests _ -> do + tmpBase <- getTemporaryDirectory + let root = tmpBase "nova-nix-test-substitute-lock-order" + low = T.replicate 32 "a" + high = T.replicate 32 "z" + drv = + Derivation + { drvOutputs = + [ DerivationOutput "bin" (StorePath high "lock-order-bin") "" "", + DerivationOutput "lib" (StorePath low "lock-order-lib") "" "" + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/sh", + drvArgs = [], + drvEnv = Map.empty + } + config = (defaultBuildConfig (StoreDir root)) {bcCaches = [Subst.CacheConfig base [] 40]} + bracket_ (forceRemoveIfExists root) (forceRemoveIfExists root) $ + bracket (openStore (StoreDir root)) closeStore $ \store -> do + _ <- substitutePaths config store (map doPath (drvOutputs drv)) + assertEqual "narinfo requests" (map (\h -> "/" <> TE.encodeUtf8 h <> ".narinfo") [low, high]) <$> requests, + runTestM "a reference query believes a signed narinfo for the path" $ + withHttpServer (route (const narInfoOk) (const narOk)) $ \base _ _ -> + assertEqual "references" (Realise.Offered []) + <$> Subst.queryReferencesWith defaultFetchRetryPolicy quietRetry Realise.NoFallback [trustingCache base 40] sp, + runTestM "a reference query passes over a narinfo no trusted key signed" $ + withHttpServer (route (const unsignedNarInfo) (const narOk)) $ \base _ _ -> + assertEqual "references" Realise.NotOffered + <$> Subst.queryReferencesWith defaultFetchRetryPolicy quietRetry Realise.NoFallback [trustingCache base 40] sp, + runTestM "a reference query passes over a narinfo for another path" $ + withHttpServer (\_ _ -> narInfoOk) $ \base _ _ -> + assertEqual "references" Realise.NotOffered + <$> Subst.queryReferencesWith defaultFetchRetryPolicy quietRetry Realise.NoFallback [trustingCache base 40] (StorePath (T.replicate 32 "c") "retry"), + -- Upstream rethrows a failed narinfo query unless fallback is + -- set, so a later cache holding the path is never asked. + runTestM "a reference query stops at a failing cache" $ + withHttpServer (route (const unavailable) (const narOk)) $ \failing _ _ -> + withHttpServer (route (const narInfoOk) (const narOk)) $ \working workingRequests _ -> do + offer <- Subst.queryReferencesWith defaultFetchRetryPolicy quietRetry Realise.NoFallback [trustingCache failing 10, trustingCache working 40] sp + seen <- workingRequests + pure (assertEqual "stopped" (Realise.QueryFailed (failing <> ": retry: HTTP 503 fetching " <> failing <> "/" <> hash <> ".narinfo"), []) (offer, seen)), + runTestM "under fallback a reference query falls through a failing cache to the next" $ + withHttpServer (route (const unavailable) (const narOk)) $ \failing _ _ -> + withHttpServer (route (const narInfoOk) (const narOk)) $ \working _ _ -> + assertEqual "references" (Realise.Offered []) + <$> Subst.queryReferencesWith defaultFetchRetryPolicy quietRetry Realise.BuildFromSource [trustingCache failing 10, trustingCache working 40] sp, + -- The whole realisation, against upstream's outcomes: a cache + -- that fails stops the build unless fallback is on, and one + -- that lacks the path or offers an untrusted narinfo does not. + -- The .drv is named under the logical store directory, as + -- upstream's printStorePath names it, though the store's files + -- are kept elsewhere. + runTestM "a NAR that fails after its retries stops the build and names --fallback" $ + withHttpServer (route (const narInfoOk) (const unavailable)) $ \base _ _ -> do + (result, substituted, built) <- realiseFrom "nar-down" [trustingCache base 40] id + pure + ( assertEqual + "stopped" + ( BuildFailure + ( "some substitutes for the outputs of derivation '/nix/store/" + <> T.replicate 32 "d" + <> "-retry.drv' failed (usually happens due to networking issues); try '--fallback' to build derivation from source" + ) + 1, + False, + False + ) + (result, substituted, built) + ), + runTestM "under fallback a NAR that fails builds from source instead" $ + withHttpServer (route (const narInfoOk) (const unavailable)) $ \base _ _ -> do + (result, substituted, built) <- realiseFrom "nar-down-fallback" [trustingCache base 40] (\config -> config {bcFallback = Realise.BuildFromSource}) + pure (assertEqual "built" (BuildSuccess sp, False, True) (result, substituted, built)), + runTestM "a narinfo the cache lacks builds, with no flag" $ + withHttpServer (\_ _ -> Send (httpResponse "404 Not Found" "")) $ \base requests _ -> do + (result, substituted, built) <- realiseFrom "narinfo-404" [trustingCache base 40] id + seen <- requests + pure (assertEqual "built" (BuildSuccess sp, False, True, [narInfoPath]) (result, substituted, built, seen)), + runTestM "a narinfo that fails after its retries stops the build with the failure" $ + withHttpServer (route (const unavailable) (const narOk)) $ \base requests _ -> do + (result, substituted, built) <- realiseFrom "narinfo-down" [trustingCache base 40] id + seen <- requests + pure + ( assertEqual + "stopped" + (BuildFailure (base <> ": retry: HTTP 503 fetching " <> base <> "/" <> hash <> ".narinfo") 1, False, False, replicate 5 narInfoPath) + (result, substituted, built, seen) + ), + runTestM "under fallback a narinfo that fails builds from source instead" $ + withHttpServer (route (const unavailable) (const narOk)) $ \base _ _ -> do + (result, substituted, built) <- realiseFrom "narinfo-down-fallback" [trustingCache base 40] (\config -> config {bcFallback = Realise.BuildFromSource}) + pure (assertEqual "built" (BuildSuccess sp, False, True) (result, substituted, built)), + runTestM "an unsigned narinfo is passed over for the next cache" $ + withHttpServer (route (const unsignedNarInfo) (const narOk)) $ \untrusted untrustedRequests _ -> + withHttpServer (route (const narInfoOk) (const narOk)) $ \trusted _ _ -> do + (result, substituted, built) <- realiseFrom "unsigned-then-signed" [trustingCache untrusted 10, trustingCache trusted 40] id + seen <- untrustedRequests + pure (assertEqual "substituted" (BuildSuccess sp, True, False, False) (result, substituted, built, narPath `elem` seen)), + runTestM "an unsigned narinfo alone builds, with no flag" $ + withHttpServer (route (const unsignedNarInfo) (const narOk)) $ \base requests _ -> do + (result, substituted, built) <- realiseFrom "unsigned" [trustingCache base 40] id + seen <- requests + pure (assertEqual "built" (BuildSuccess sp, False, True, False) (result, substituted, built, narPath `elem` seen)), + runTestM "a narinfo that fails once with a 503 is fetched on the retry" $ do + (base, outcome, seen, sleeps, warnings) <- + substitute "narinfo-503" (\earlier -> if earlier == 0 then unavailable else narInfoOk) (const narOk) + pure + ( assertEqual + "substituted after one retry" + (Right payload, [narInfoPath, narInfoPath, narPath], [250], ["HTTP 503 fetching " <> base <> "/" <> hash <> ".narinfo; retrying in 250 ms"]) + (outcome, seen, sleeps, warnings) + ), + runTestM "a narinfo that keeps failing spends upstream's five attempts and doubling delay" $ do + (_, outcome, seen, sleeps, _) <- substitute "narinfo-down" (const unavailable) (const narOk) + pure $ case outcome of + Left (Subst.SubstError _) -> assertEqual "attempts" (replicate 5 narInfoPath, [250, 500, 1000, 2000]) (seen, sleeps) + other -> Fail ("expected a substitution error, got: " <> T.pack (show other)), + runTestM "a NAR download answering 501 stops after one request" $ do + (_, outcome, seen, sleeps, _) <- + substitute "nar-501" (const narInfoOk) (const (Send (httpResponse "501 Not Implemented" ""))) + pure $ case outcome of + Left (Subst.SubstError err) + | "HTTP 501" `T.isInfixOf` err -> assertEqual "one request" ([narInfoPath, narPath], []) (seen, sleeps) + other -> Fail ("expected an HTTP 501 substitution error, got: " <> T.pack (show other)), + -- One attempt follows the client's redirect limit, then stops. + runTestM "a NAR redirect loop stops after one attempt" $ do + (_, outcome, seen, sleeps, _) <- + substitute "nar-redirect" (const narInfoOk) (const (Send "HTTP/1.1 302 Found\r\nLocation: /nar/retry.nar\r\nContent-Length: 0\r\nConnection: close\r\n\r\n")) + pure $ case outcome of + Left (Subst.SubstError err) + | "too many redirects" `T.isInfixOf` err -> + assertEqual "one attempt" (narInfoPath : replicate (HTTP.redirectCount HTTP.defaultRequest + 1) narPath, []) (seen, sleeps) + other -> Fail ("expected a redirect-loop substitution error, got: " <> T.pack (show other)), + runTestM "a torn NAR transfer is retried from its first byte" $ do + let torn = "HTTP/1.1 200 OK\r\nContent-Length: " <> TE.encodeUtf8 (T.pack (show (BS.length nar))) <> "\r\nConnection: close\r\n\r\n" <> BS.take 10 nar + (base, outcome, seen, sleeps, warnings) <- + substitute "nar-torn" (const narInfoOk) (\earlier -> if earlier == 0 then Send torn else narOk) + let warnedTorn = case warnings of + [warning] -> ("download error fetching " <> base <> "/nar/retry.nar: ResponseBodyTooShort") `T.isPrefixOf` warning + _ -> False + pure $ + if warnedTorn + then assertEqual "substituted after one retry" (Right payload, [narInfoPath, narPath, narPath], [250]) (outcome, seen, sleeps) + else Fail ("unexpected warnings: " <> T.pack (show warnings)) + ] + -- Upstream's NotFound and Forbidden: a binary cache store + -- reads both as the file not being in that cache. + ++ [ runTestM ("a narinfo answered " <> status <> " is a miss, not retried") $ do + (_, outcome, seen, sleeps, _) <- + substitute ("narinfo-" ++ statusCode status) (const (Send (httpResponse (TE.encodeUtf8 status) ""))) (const narOk) + pure (assertEqual "miss" (Left Subst.SubstNotFound, [narInfoPath], []) (outcome, seen, sleeps)) + | status <- notInCache + ] + -- A NAR the narinfo named and the cache no longer holds is + -- upstream's SubstituteGone: one request, never retried, and + -- a miss rather than a failed substitute. + ++ [ runTestM ("a NAR answered " <> status <> " is a miss after one request") $ do + (_, outcome, seen, sleeps, _) <- + substitute ("nar-" ++ statusCode status) (const narInfoOk) (const (Send (httpResponse (TE.encodeUtf8 status) ""))) + pure (assertEqual "gone" (Left Subst.SubstNotFound, [narInfoPath, narPath], []) (outcome, seen, sleeps)) + | status <- notInCache + ] + where + notInCache :: [Text] + notInCache = ["404 Not Found", "410 Gone", "401 Unauthorized", "403 Forbidden", "407 Proxy Authentication Required"] + statusCode = T.unpack . T.take 3 + quietRetry = RetryEffects {reSleepMs = const (pure ()), reJitter = pure 0, reWarn = const (pure ())} + hash = T.replicate 32 "b" + sp = StorePath hash "retry" + narInfoPath = "/" <> TE.encodeUtf8 hash <> ".narinfo" + narPath = "/nar/retry.nar" + payload = "retried payload\n" + nar = NAR.serialise (NAR.NarDirectory [("data", NAR.NarRegular False payload)]) + unsigned = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/" <> hash <> "-retry", + NarInfo.niUrl = "nar/retry.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = CHash.formatNixHash (CHash.hashBytes nar), + NarInfo.niNarSize = fromIntegral (BS.length nar), + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + signedNarInfo = do + secretKey <- Signing.parseSecretKey sigTestKeyText + publicKey <- Signing.toPublicKey secretKey + sig <- Signing.sign secretKey unsigned + pure (Signing.renderPublicKey publicKey, NarInfo.renderNarInfo unsigned {NarInfo.niSigs = [sig]}) + route narInfoReply narReply path earlier + | path == narInfoPath = narInfoReply earlier + | path == narPath = narReply earlier + | otherwise = Send (httpResponse "500 Internal Server Error" "unexpected request") + +-- | @pkgs/windows/fetchurl.nix@ evaluated from the checkout. The +-- @mirror://@ expansion is what a source derivation records, so a +-- mirrors.nix refresh or a regex edit moves every drvPath built on it; +-- these pin the list against nixpkgs' order and the eval-time errors. +testPkgsFetchurl :: IO [Bool] +testPkgsFetchurl = do + putStrLn "pkgs/fetchurl" + cwd <- Dir.getCurrentDirectory + let fetchurl = "(import " <> nixQuotedPath (cwd "pkgs" "windows" "fetchurl.nix") <> ")" + urlsOf source = "builtins.concatStringsSep \"\\n\" (" <> fetchurl <> " { " <> source <> " sha256 = \"" <> hash <> "\"; }).urls" + failsWith expected result = case result of + Left err + | expected `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected an error naming " <> expected <> ", got: " <> err) + Right val -> Fail ("expected an eval error, got: " <> T.pack (show val)) + sequence + [ runTestIO + "mirror://gnu expands to the https hosts of mirrors.nix, in nixpkgs' order" + cwd + (urlsOf "url = \"mirror://gnu/hello/hello-2.12.3.tar.gz\";") + (mkStr (T.intercalate "\n" (map (<> "hello/hello-2.12.3.tar.gz") gnuHosts))), + runTestIO + "a plain URL in urls passes through beside an expanded one" + cwd + (urlsOf "urls = [ \"https://example.invalid/sed-4.10.tar.xz\" \"mirror://gnu/sed/sed-4.10.tar.xz\" ];") + (mkStr (T.intercalate "\n" ("https://example.invalid/sed-4.10.tar.xz" : map (<> "sed/sed-4.10.tar.xz") gnuHosts))), + runTestM "an unknown mirror site is an eval error naming the recipe's URL" $ + failsWith "fetchurl: unknown mirror site 'nope' in 'mirror://nope/x'" <$> evalNixIO cwd (urlsOf "url = \"mirror://nope/x\";"), + runTestM "a mirror URL with no path is an eval error" $ + failsWith "fetchurl: malformed mirror URL 'mirror://gnu'" <$> evalNixIO cwd (urlsOf "url = \"mirror://gnu\";") + ] + where + hash :: Text + hash = "0d5f60154382fee10b114a1c34e785d8b1f492073ae2d3a6f7b147687b366aa0" + -- The gnu set of pkgs/windows/mirrors.nix without its ftp:// host. + gnuHosts :: [Text] + gnuHosts = + [ "https://ftpmirror.gnu.org/", + "https://ftp.nluug.nl/pub/gnu/", + "https://mirrors.kernel.org/gnu/", + "https://mirror.ibcp.fr/pub/gnu/", + "https://mirror.dogado.de/gnu/", + "https://mirror.tochlab.net/pub/gnu/", + "https://ftp.gnu.org/pub/gnu/" + ] + +-- | @pkgs/windows@'s stage0-pe32 chain, read back as the build driver reads +-- it: every derivation reachable from the seed, the ten links and +-- mescc-tools-extra's thirteen programs. The chain is full-source only if +-- nothing reaches it but the seed and the sources, so the graph's leaves are +-- exactly those six fetches, no derivation takes a plain input source, and +-- each of the thirty commands of stage0-pe32's @x86\/mescc-tools-mini.cmd@, +-- and each of the five steps of every mescc-tools-extra program, is a step run +-- by a program the graph builds. Every program built from C, hex2-new and kaem +-- included, is those five steps with the arguments the .cmd gives kaem. hex0 +-- carries the seed's hash as its own, so the build itself checks that the +-- seed reproduces itself. +-- +-- The bin directories and @test\/data\/run-command.nix@'s writeText and +-- runCommand builds add derivations kaem builds and no leaf, and read nothing +-- but the scripts evaluation writes. Each bin directory's script copies the +-- programs its variables name to @bin\/\.exe@, runCommand runs its +-- script from those directories on a PATH joined with @;@, and a store path +-- in that script is spelled from @NIX_STORE@. +testStage0Pe32Chain :: IO [Bool] +testStage0Pe32Chain = do + putStrLn "pkgs/stage0-pe32" + cwd <- Dir.getCurrentDirectory + storeDir <- evalNixIOStoreDir + fresh <- newEvalState storeDir cwd + -- The package set's fetchurl hands a single URL to , + -- which resolves against the checkout's data directory as the installed + -- binary resolves it against its own. + let st = fresh {esSearchPaths = parseNixPath (TE.encodeUtf8 (T.pack (cwd "data")))} + chain = "(import " <> nixQuotedPath (cwd "pkgs" "windows") <> ").stage0-pe32" + runCommandTests = "import " <> nixQuotedPath (cwd "test" "data" "run-command.nix") + quoted name = "\"" <> name <> "\"" + source = + T.concat + [ "let chain = ", + chain, + "; runs = ", + runCommandTests, + "; in builtins.concatStringsSep \" \" (map (name: chain.${name}.drvPath) [ ", + T.unwords (map quoted ("seed" : links ++ bins)), + " ] ++ map (name: chain.mescc-tools-extra.${name}.drvPath) [ ", + T.unwords (map quoted extras), + " ] ++ map (name: runs.${name}.drvPath) [ ", + T.unwords (map quoted runs), + " ])" + ] + chainAttrs = ("seed" : links) ++ map extraAttr extras + outcome <- case parseNix cwd testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left (T.pack (show err))) + Right expr -> runEvalIO st $ do + value <- eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr + case value of + VStr bytes _ -> do + let rootOf = Map.fromList (zip (("seed" : links ++ bins) ++ map extraAttr extras ++ map runAttr runs) (T.words (bytesText bytes))) + graph <- sessionClosure (mapMaybe (`Map.lookup` rootOf) chainAttrs) + full <- sessionClosure (Map.elems rootOf) + pure (rootOf, graph, full) + other -> throwEvalError ("expected the drvPaths as one string, got " <> typeName other) + writes <- readIORef (esStoreWriteCache st) + case outcome of + Left err -> sequence [runTest instantiates (Fail err)] + Right (rootOf, graph, full) -> do + let derivations = Map.elems graph + fetches = filter ((== fetchurlBuilder) . drvBuilder) derivations + unpacks = filter ((== builtinUnpackBuilder) . drvBuilder) derivations + steps = filter (\drv -> drvBuilder drv `notElem` [fetchurlBuilder, builtinUnpackBuilder]) derivations + leaves = filter (Map.null . drvInputDrvs) derivations + nameOf drv = maybe "" bytesText (Map.lookup "name" (drvEnv drv)) + isFixedOutput drv = not (all (T.null . doHash) (drvOutputs drv)) + outOf drv = [TE.encodeUtf8 (storePathToText defaultStoreDir (doPath o)) | o <- drvOutputs drv, doName o == "out"] + inputsOf drv = mapMaybe ((`Map.lookup` full) . storePathToText defaultStoreDir) (Map.keys (drvInputDrvs drv)) + builtBy attr = Map.lookup attr rootOf >>= (`Map.lookup` full) + builderNamesOf drv = [nameOf input | input <- inputsOf drv, drvBuilder drv `elem` outOf input] + fixedHashOf drv = [(doHashAlgo o, doHash o) | o <- drvOutputs drv, doName o == "out"] + isStep drv = drvBuilder drv `notElem` [fetchurlBuilder, builtinUnpackBuilder] + -- A program's steps, last first: each step after the compile has + -- one input that is a step and not the program it runs. + stepsBack drv = drv : maybe [] stepsBack (listToMaybe [input | input <- inputsOf drv, isStep input, drvBuilder drv `notElem` outOf input]) + -- An argument as the .cmd spells it: the step's own output, which + -- the .drv holds as its placeholder until the build, as $out, + -- another step's output by that step's name, and a file in an + -- unpacked repository as /. + spell drv arg + | bytesText arg == hashPlaceholder "out" = "$out" + | otherwise = + fromMaybe (bytesText arg) $ + listToMaybe ([nameOf input | input <- inputsOf drv, arg `elem` outOf input] ++ mapMaybe (inRepository arg) unpacks) + inRepository arg unpack = do + root <- listToMaybe (outOf unpack) + rest <- BS.stripPrefix (root <> "/") arg + let repo = T.dropEnd 1 (fst (T.breakOnEnd "-" (nameOf unpack))) + pure (repo <> "/" <> bytesText (BS.drop 1 (BS8.dropWhile (/= '/') rest))) + command drv = (nameOf drv, builderNamesOf drv, map (spell drv) (drvArgs drv)) + -- What the bin directories and run-command.nix add to the chain. + added = Map.elems (Map.difference full graph) + fullLeaves = filter (Map.null . drvInputDrvs) (Map.elems full) + variableOf name drv = maybe "" bytesText (Map.lookup name (drvEnv drv)) + outText attr = maybe "" bytesText (builtBy attr >>= listToMaybe . outOf) + -- Each variable of a bin directory that names a program, with the + -- name of the program's derivation. + installs drv = sort [(var, nameOf input) | (var, value) <- Map.toList (drvEnv drv), var /= "builder", input <- inputsOf drv, value `elem` outOf input] + wroteAsText path = fmap snd (Map.lookup (storePathToText defaultStoreDir path) writes) == Just WriteText + runsWith drv = (bytesText (drvBuilder drv), map (spell drv) (drvArgs drv), variableOf "PATH" drv) + scriptOf drv = listToMaybe [input | input <- inputsOf drv, nameOf input == nameOf drv <> "-builder"] + textFile drv = (bytesText (drvBuilder drv), variableOf "PATH" drv, variableOf "passAsFile" drv, variableOf "text" drv, sort (map nameOf (inputsOf drv))) + kaemExe = outText "kaem" <> "/bin/kaem.exe" + extraPath = outText "mescc-tools-extra" <> "/bin" + hello = "${NIX_STORE}/" <> T.drop (T.length defaultStoreDirText + 1) (outText (runAttr "hello")) + sequence + [ runTest instantiates $ + assertEqual "steps, unpacks, fetches" (95, 5, 6) (length steps, length unpacks, length fetches), + runTest "no derivation of the chain takes a plain input source" $ + case [nameOf drv | drv <- derivations, not (null (drvInputSrcs drv))] of + [] -> Pass + named -> Fail ("input sources in: " <> T.intercalate ", " named), + runTest "the chain's leaves are the seed and the five source archives, all fixed-output" $ + assertEqual + "leaves" + (fetchNames, True) + ( sort (map nameOf leaves), + all (\drv -> drvBuilder drv == fetchurlBuilder && isFixedOutput drv) leaves + ), + runTest "each source archive is unpacked from its fetch alone" $ + assertEqual "unpack inputs" (replicate 5 [fetchurlBuilder]) [map drvBuilder (inputsOf drv) | drv <- unpacks], + runTest "every step is an i686-windows derivation" $ + case [nameOf drv | drv <- steps, drvPlatform drv /= I686_Windows] of + [] -> Pass + named -> Fail ("not i686-windows: " <> T.intercalate ", " named), + runTest "each step is run by an input, the program its command runs" $ + assertEqual + "file written, program run" + (sort ([(written, [program]) | (written, program) <- commands] ++ [(written, program) | (_, built) <- extraPrograms, (written, program, _) <- built])) + (sort [(nameOf drv, builderNamesOf drv) | drv <- steps]), + runTest "each program built from C is the five steps that build kaem, with their arguments" $ + assertEqual + "file written, program run, arguments" + (cmdPrograms ++ extraPrograms) + [(attr, maybe [] (map command . reverse . stepsBack) (builtBy attr)) | (attr, _) <- cmdPrograms ++ extraPrograms], + runTest "hex0 is fixed-output to the seed's own hash" $ + case (fixedHashOf <$> builtBy "seed", fixedHashOf <$> builtBy "hex0") of + (Just seedHash@[(_, digest)], Just hex0Hash) + | not (T.null digest) -> assertEqual "hex0's output hash" seedHash hex0Hash + other -> Fail ("expected the seed's fixed-output hash on hex0: " <> T.pack (show other)), + runTest "the bin directories and run-command.nix add ten derivations" $ + assertEqual + "derivations added" + (sort ["kaem", "mescc-tools", "mescc-tools-extra", "hello.txt", "run-command-copies", "run-command-copies-builder", "run-command-fails", "run-command-fails-builder", "run-command-marks", "run-command-marks-builder"]) + (sort (map nameOf added)), + runTest "with them the leaves are still the seed and the five source archives" $ + assertEqual "leaves" fetchNames (sort (map nameOf fullLeaves)), + runTest "they read no input source but the scripts evaluation writes as text" $ + assertEqual + "derivation and its sources, all written as text" + ( [ ("hello.txt", ["write-text.kaem"]), + ("kaem", ["kaem-bin.kaem"]), + ("mescc-tools", ["mescc-tools-bin.kaem"]), + ("mescc-tools-extra", ["mescc-tools-extra-bin.kaem"]), + ("run-command-copies-builder", ["write-text.kaem"]), + ("run-command-fails-builder", ["write-text.kaem"]), + ("run-command-marks-builder", ["write-text.kaem"]) + ], + True + ) + ( sort [(nameOf drv, sort (map spName (drvInputSrcs drv))) | drv <- added, not (null (drvInputSrcs drv))], + all (all wroteAsText . drvInputSrcs) added + ), + runTest "every derivation they add is i686-windows" $ + case [nameOf drv | drv <- added, drvPlatform drv /= I686_Windows] of + [] -> Pass + named -> Fail ("not i686-windows: " <> T.intercalate ", " named), + runTest "kaem lays out each bin directory from the programs its variables name" $ + assertEqual + "bin directory, program run, variable and program" + [ ("kaem", ["kaem.exe"], sort [("chmod", "chmod.exe"), ("cp", "cp.exe"), ("kaem", "kaem.exe"), ("mkdir", "mkdir.exe")]), + ("mescc-tools", ["kaem.exe"], sort [("M1", "M1.exe"), ("M2-Planet", "M2.exe"), ("chmod", "chmod.exe"), ("cp", "cp.exe"), ("hex2", "hex2-new.exe"), ("mkdir", "mkdir.exe")]), + ("mescc-tools-extra", ["kaem.exe"], sort [(name, name <> ".exe") | name <- extras]) + ] + [(attr, maybe [] builderNamesOf (builtBy attr), maybe [] installs (builtBy attr)) | attr <- bins], + runTestM "each bin directory's script copies its programs to bin/.exe and chmods each 555, and writeText's copies the text" $ do + let scriptsOf drv = map (storePathToFilePath storeDir) (drvInputSrcs drv) + scripts <- traverse (traverse BS.readFile . maybe [] scriptsOf . builtBy) (bins ++ [runAttr "hello"]) + pure $ + assertEqual + "scripts" + [[installScript ["kaem"]], [installScript ["M1", "M2-Planet", "hex2"]], [installScript extras], ["cp ${textPath} ${out}\n"]] + (map (map bytesText) scripts), + runTest "runCommand runs its script with kaem from the bin directories, on PATH joined with ';'" $ + assertEqual + "builder, arguments, PATH" + [ (kaemExe, ["--verbose", "--strict", "--file", name <> "-builder"], T.intercalate ";" [outText attr <> "/bin" | attr <- bins]) + | name <- ["run-command-copies", "run-command-fails", "run-command-marks"] + ] + (mapMaybe (fmap runsWith . builtBy . runAttr) ["copies", "fails", "marks"]), + runTest "marks is fixed-output to the NAR hash of its tree with bin/hello executable" $ + assertEqual + "output hash" + (Just [("r:sha256", "d7b2412a32f4ff4be9340e6bbd33e316c64fdf38623ba4e76ed8af570dfaee9a")]) + (fixedHashOf <$> builtBy (runAttr "marks")), + runTest "writeText passes its text as a file, and runCommand's script spells a store path from NIX_STORE" $ + assertEqual + "builder, PATH, passAsFile, text and inputs" + [ (kaemExe, extraPath, "text", "stage0-pe32 runs a kaem script\n", ["kaem", "mescc-tools-extra"]), + ( kaemExe, + extraPath, + "text", + T.unlines ["mkdir -p ${out}/a/b", "cp " <> hello <> " ${out}/a/b/hello.txt", "catm ${out}/twice.txt " <> hello <> " " <> hello], + ["hello.txt", "kaem", "mescc-tools-extra"] + ) + ] + (map textFile (catMaybes [builtBy (runAttr "hello"), builtBy (runAttr "copies") >>= scriptOf])) + ] + where + instantiates :: Text + instantiates = "the chain instantiates: ninety-five steps, five unpacks and six fetches" + fetchurlBuilder :: BS.ByteString + fetchurlBuilder = "builtin:fetchurl" + links :: [Text] + links = ["hex0", "hex1", "hex2", "catm", "M0", "cc_x86", "M2", "M1", "hex2-new", "kaem-unwrapped"] + extras :: [Text] + extras = ["sha256sum", "match", "mkdir", "untar", "ungz", "unbz2", "unxz", "catm", "cp", "chmod", "rm", "replace", "wrap"] + extraAttr :: Text -> Text + extraAttr = ("mescc-tools-extra." <>) + bins :: [Text] + bins = ["kaem", "mescc-tools", "mescc-tools-extra"] + runs :: [Text] + runs = ["hello", "copies", "fails", "marks"] + runAttr :: Text -> Text + runAttr = ("run-command." <>) + -- The script kaem runs to lay out a bin directory of the programs named. + installScript :: [Text] -> Text + installScript names = + T.unlines + ( "${mkdir} -p ${out}/bin" + : concat + [ ["${cp} ${" <> name <> "} ${out}/bin/" <> name <> ".exe", "${chmod} 555 ${out}/bin/" <> name <> ".exe"] + | name <- sort names + ] + ) + fetchNames :: [Text] + fetchNames = sort ["M2-Planet-ee0bf91.tar.gz", "M2libc-13e57eb.tar.gz", "hex0-seed.exe", "mescc-tools-578ac99.tar.gz", "mescc-tools-extra-d1d8146.tar.gz", "stage0-pe32-ff1c2ad.tar.gz"] + -- The steps that build a C program on M2libc's POSIX layer, named for + -- stem: the file each writes, the program it runs and its arguments. + cProgram :: Text -> Text -> [Text] -> [(Text, [Text], [Text])] + cProgram executable stem files = + [ (stem <> ".M1", ["M2.exe"], ["--architecture", "x86", "-D", "__windows__=1"] ++ concatMap (\file -> ["-f", file]) files ++ ["-o", "$out"]), + (stem <> "-0.M1", ["catm.exe"], ["$out", "M2libc/x86/x86_defs.M1", "stage0-pe32/x86/libc-core.M1", "stage0-pe32/x86/libc-full.M1", stem <> ".M1", "stage0-pe32/x86/pe-end-shim.M1"]), + (stem <> ".hex2", ["M0.exe"], [stem <> "-0.M1", "$out"]), + (stem <> "-0.hex2", ["catm.exe"], ["$out", "stage0-pe32/x86/PE32-i386.hex2", "stage0-pe32/x86/ntdll-i386.hex2", stem <> ".hex2"]), + (executable, ["hex2.exe"], [stem <> "-0.hex2", "$out"]) + ] + -- Phase-7's M2libc files, which are what reaches on the + -- x86/windows target and bootstrappable.c, and Phase-8's, which add the + -- string.c that reaches. catm is the one program here that + -- does not include . + libcPosix :: [Text] + libcPosix = map ("M2libc/" <>) (libcBelowString ++ libcAboveString) + libcString :: [Text] + libcString = map ("M2libc/" <>) (libcBelowString ++ ["string.c"] ++ libcAboveString) + libcBelowString :: [Text] + libcBelowString = ["sys/types.h", "stddef.h", "sys/utsname.h", "x86/windows/ntdll.c", "x86/windows/unistd.c", "x86/windows/process.c", "x86/windows/fcntl.c", "fcntl.c", "x86/windows/sys/stat.c", "ctype.c", "stdlib.c"] + libcAboveString :: [Text] + libcAboveString = ["stdarg.h", "stdio.h", "stdio.c", "bootstrappable.c"] + -- The .cmd's two programs built from C and mescc-tools-extra's, by + -- attribute, with the steps that build each. + cmdPrograms :: [(Text, [(Text, [Text], [Text])])] + cmdPrograms = + [ ("hex2-new", cProgram "hex2-new.exe" "hex2_linker" (libcPosix ++ map ("mescc-tools/" <>) ["hex2.h", "hex2_linker.c", "hex2_word.c", "hex2.c"])), + ("kaem-unwrapped", cProgram "kaem.exe" "kaem" (libcString ++ map ("mescc-tools/Kaem/" <>) ["kaem.h", "variable.c", "kaem_globals.c", "kaem.c"])) + ] + extraPrograms :: [(Text, [(Text, [Text], [Text])])] + extraPrograms = + [ (extraAttr name, cProgram (name <> ".exe") name ((if name == "catm" then libcPosix else libcString) ++ ["mescc-tools-extra/" <> name <> ".c"])) + | name <- extras + ] + -- Each command of the .cmd: the file it writes and the program it runs. + commands :: [(Text, Text)] + commands = + [ ("hex0.exe", "hex0-seed.exe"), + ("hex1.exe", "hex0.exe"), + ("hex2.exe", "hex1.exe"), + ("catm.exe", "hex2.exe"), + ("M0.hex2", "catm.exe"), + ("M0.exe", "hex2.exe"), + ("cc_x86-0.hex2", "M0.exe"), + ("cc_x86.hex2", "catm.exe"), + ("cc_x86.exe", "hex2.exe"), + ("M2-0.c", "catm.exe"), + ("M2-0.M1", "cc_x86.exe"), + ("M2-0-0.M1", "catm.exe"), + ("M2-0.hex2", "M0.exe"), + ("M2-0-0.hex2", "catm.exe"), + ("M2.exe", "hex2.exe"), + ("M1-macro.M1", "M2.exe"), + ("M1-macro-0.M1", "catm.exe"), + ("M1-macro.hex2", "M0.exe"), + ("M1-macro-0.hex2", "catm.exe"), + ("M1.exe", "hex2.exe"), + ("hex2_linker.M1", "M2.exe"), + ("hex2_linker-0.M1", "catm.exe"), + ("hex2_linker.hex2", "M0.exe"), + ("hex2_linker-0.hex2", "catm.exe"), + ("hex2-new.exe", "hex2.exe"), + ("kaem.M1", "M2.exe"), + ("kaem-0.M1", "catm.exe"), + ("kaem.hex2", "M0.exe"), + ("kaem-0.hex2", "catm.exe"), + ("kaem.exe", "hex2.exe") + ] + +-- | Every derivation reachable from @roots@ through input derivations, keyed +-- by @.drv@ path, as the evaluation session recorded them. +sessionClosure :: (MonadEval m) => [Text] -> m (Map.Map Text Derivation) +sessionClosure = go Map.empty + where + go seen [] = pure seen + go seen (path : rest) + | Map.member path seen = go seen rest + | otherwise = do + recorded <- lookupSessionDrv path + case recorded of + Nothing -> throwEvalError ("no .drv was recorded for " <> path) + Just drv -> + go (Map.insert path drv seen) (map (storePathToText defaultStoreDir) (Map.keys (drvInputDrvs drv)) ++ rest) + +-- | @pkgs/windows@'s Mes, read back as the build driver reads it: what its +-- source tree, libraries, compiler and C library sources, and +-- @test\/data\/mes.nix@'s checks, add to the closure of the stage0 tools +-- they run on. The rung is full-source only if the leaves it adds are the +-- Mes and NYACC archives and it reads no input source but the scripts +-- evaluation writes. The builder spells a store path with a backslash, +-- which starts an escape in a C or Scheme string, so no script writes a path +-- into Mes's source with replace, and every script that runs Mes sets the +-- paths and sizes it reads in its environment instead. exec-bit is +-- fixed-output to the NAR hash of the files its program makes, with the +-- execute bits their modes set. +testMesWindows :: IO [Bool] +testMesWindows = do + putStrLn "pkgs/mes" + cwd <- Dir.getCurrentDirectory + storeDir <- evalNixIOStoreDir + fresh <- newEvalState storeDir cwd + let st = fresh {esSearchPaths = parseNixPath (TE.encodeUtf8 (T.pack (cwd "data")))} + windows = "(import " <> nixQuotedPath (cwd "pkgs" "windows") <> ")" + checks = "import " <> nixQuotedPath (cwd "test" "data" "mes.nix") + quoted name = "\"" <> name <> "\"" + source = + T.concat + [ "let pkgs = ", + windows, + "; checks = ", + checks, + "; in builtins.concatStringsSep \" \" ([ pkgs.mes.srcPrefix ] ++ map (name: pkgs.stage0-pe32.${name}.drvPath) [ ", + T.unwords (map quoted tools), + " ] ++ map (name: pkgs.mes.${name}.drvPath) [ ", + T.unwords (map quoted mesAttrs), + " ] ++ map (name: checks.${name}.drvPath) [ ", + T.unwords (map quoted checkAttrs), + " ])" + ] + roots = tools ++ map ("mes." <>) mesAttrs ++ map ("checks." <>) checkAttrs + outcome <- case parseNix cwd testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left (T.pack (show err))) + Right expr -> runEvalIO st $ do + value <- eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr + case value of + VStr bytes _ -> case T.words (bytesText bytes) of + prefix : paths -> do + let rootOf = Map.fromList (zip roots paths) + toolGraph <- sessionClosure (mapMaybe (`Map.lookup` rootOf) tools) + full <- sessionClosure (Map.elems rootOf) + pure (prefix, rootOf, toolGraph, full) + [] -> throwEvalError "expected srcPrefix and the drvPaths" + other -> throwEvalError ("expected srcPrefix and the drvPaths as one string, got " <> typeName other) + writes <- readIORef (esStoreWriteCache st) + case outcome of + Left err -> sequence [runTest instantiates (Fail err)] + Right (prefix, rootOf, toolGraph, full) -> do + let added = Map.elems (Map.difference full toolGraph) + nameOf drv = maybe "" bytesText (Map.lookup "name" (drvEnv drv)) + variableOf name drv = maybe "" bytesText (Map.lookup name (drvEnv drv)) + outOf drv = [storePathToText defaultStoreDir (doPath o) | o <- drvOutputs drv, doName o == "out"] + builtBy attr = Map.lookup attr rootOf >>= (`Map.lookup` full) + outText attr = T.concat (maybe [] outOf (builtBy attr)) + fixedHashOf drv = [(doHashAlgo o, doHash o) | o <- drvOutputs drv, doName o == "out"] + inputsOf drv = mapMaybe ((`Map.lookup` full) . storePathToText defaultStoreDir) (Map.keys (drvInputDrvs drv)) + scriptOf drv = listToMaybe [variableOf "text" input | input <- inputsOf drv, nameOf input == nameOf drv <> "-builder"] + isFetch drv = drvBuilder drv == "builtin:fetchurl" + isFixedOutput drv = not (all (T.null . doHash) (drvOutputs drv)) + addedLeaves = filter (Map.null . drvInputDrvs) added + wroteAsText path = fmap snd (Map.lookup (storePathToText defaultStoreDir path) writes) == Just WriteText + runsMes script = any (`T.isInfixOf` script) ["/bin/mes-m2.exe ", "/bin/mes.exe "] + runners = [drv | drv <- added, Just script <- [scriptOf drv], runsMes script] + quote dir = "\"" <> dir <> "\"" + mesEnv = + [ ("MES_ARENA", "20000000"), + ("MES_MAX_ARENA", "20000000"), + ("MES_STACK", "6000000"), + ("MES_PREFIX", prefix), + ("GUILE_LOAD_PATH", T.intercalate ":" (map quote [prefix <> "/mes/module", prefix <> "/module", outText "mes.nyacc" <> "/share/nyacc-1.09.1/module"])), + ("M1", outText "mescc-tools" <> "/bin/M1.exe"), + ("HEX2", outText "mescc-tools" <> "/bin/hex2.exe") + ] + -- What each replace line of a script writes into the file it edits. + replacements script = [snd (T.breakOn "--replace-with" line) | line <- T.lines script, "replace " `T.isPrefixOf` T.stripStart line] + written = concatMap replacements (mapMaybe scriptOf added) + sequence + [ runTest instantiates $ + assertEqual "derivations added" (sort addedNames) (sort (map nameOf added)), + runTest "every derivation it adds but the two fetches is i686-windows" $ + case [nameOf drv | drv <- added, not (isFetch drv), drvPlatform drv /= I686_Windows] of + [] -> Pass + named -> Fail ("not i686-windows: " <> T.intercalate ", " named), + runTest "the leaves it adds are the Mes and NYACC archives, both fetched fixed-output" $ + assertEqual + "leaves added" + (sort ["mes-d9ab4ea.tar.gz", "nyacc-1.09.1.tar.gz"], True) + (sort (map nameOf addedLeaves), all (\drv -> isFetch drv && isFixedOutput drv) addedLeaves), + runTest "it reads no input source but what evaluation writes as text" $ + assertEqual "input sources not written as text" [] [nameOf drv | drv <- added, not (all wroteAsText (drvInputSrcs drv))], + runTest "every script that runs Mes sets its arena, MES_PREFIX, GUILE_LOAD_PATH, M1 and HEX2" $ + assertEqual + "derivation and its environment" + [(name, mesEnv) | name <- sort mesRunners] + (sort [(nameOf drv, [(var, variableOf var drv) | (var, _) <- mesEnv]) | drv <- runners]), + runTest "no script writes a path into Mes's source with replace" $ + assertEqual + "replacements, and those that name a path" + (3, []) + (length written, filter (\with -> "/" `T.isInfixOf` with || "${" `T.isInfixOf` with) written), + runTest "exec-bit is fixed-output to the NAR hash of the files its program makes, open-0755 and chmod-0755 executable" $ + assertEqual + "output hash" + [("r:sha256", Hash.bytesToHexText (sha256Digest (NAR.serialise execBitTree)))] + (maybe [] fixedHashOf (builtBy "checks.exec-bit")) + ] + where + instantiates :: Text + instantiates = "the Mes derivations instantiate, adding thirty-two to the stage0 tools'" + tools :: [Text] + tools = ["kaem", "mescc-tools", "mescc-tools-extra"] + mesAttrs :: [Text] + mesAttrs = ["nyacc", "srcPost", "libs", "compiler", "libc"] + checkAttrs :: [Text] + checkAttrs = ["mes-m2", "mes", "hello", "exec-bit"] + -- Each kaem.runCommand adds its script, written by writeText as + -- -builder; mes-libc-0.27.1 is both the libc MesCC compiles and + -- the sources for TinyCC, as in nixpkgs. + addedNames :: [Text] + addedNames = + ["mes-d9ab4ea.tar.gz", "nyacc-1.09.1.tar.gz", "hello.c", "exec-bit.c"] + ++ concat [[name, name <> "-builder"] | name <- mesRunners ++ ["nyacc-1.09.1", "mes-src-0.27.1", "mes-m2-libs-0.27.1", "mes-libc-0.27.1"]] + mesRunners :: [Text] + mesRunners = + [ "mes-crt1-0.27.1", + "mes-libc-mini-0.27.1", + "mes-libmescc-0.27.1", + "mes-libc-0.27.1", + "mes-libc+tcc-0.27.1", + "mes-0.27.1", + "mes-m2-get-version", + "mes-get-version", + "mes-hello", + "mes-exec-bit" + ] + -- What test/data/mes.nix's exec-bit program makes: three files holding + -- one line, the one open creates with mode 0755 and the one chmod + -- gives 0755 executable, the one open creates with 0644 not. + execBitTree :: NAR.NarEntry + execBitTree = + NAR.NarDirectory + [ ("open-0755", NAR.NarRegular True execBitContents), + ("open-0644", NAR.NarRegular False execBitContents), + ("chmod-0755", NAR.NarRegular True execBitContents) + ] + execBitContents :: BS.ByteString + execBitContents = "written by Mes libc\n" + +testFetchGitTransport :: IO [Bool] +testFetchGitTransport = do + putStrLn "eval/fetchgit-transport" + sequence + [ runTest "allowed schemes pass" $ + assertEqual + "schemes" + [ Right "https://example.com/repo.git", + Right "http://example.com/repo.git", + Right "ssh://git@example.com/repo.git", + Right "git://example.com/repo.git", + Right "file:///srv/repo" + ] + ( map + checkGitUrl + [ "https://example.com/repo.git", + "http://example.com/repo.git", + "ssh://git@example.com/repo.git", + "git://example.com/repo.git", + "file:///srv/repo" + ] + ), + runTest "scheme match is case-insensitive" $ + assertEqual "upper" (Right "HTTPS://example.com/r") (checkGitUrl "HTTPS://example.com/r"), + runTest "scp-like remotes and local paths pass" $ + assertEqual + "plain" + [ Right "git@github.com:owner/repo.git", + Right "user@[::1]:repo", + Right "/srv/repo", + Right "./repo", + Right "C:\\src\\repo" + ] + ( map + checkGitUrl + [ "git@github.com:owner/repo.git", + "user@[::1]:repo", + "/srv/repo", + "./repo", + "C:\\src\\repo" + ] + ), + runTest "helper transports are rejected" $ + let rejected = ["ext::sh -c 'printf x'", "fd::17", "my-helper_2::payload", "::payload"] + in case [url | url <- rejected, either (const False) (const True) (checkGitUrl url)] of + [] -> Pass + slipped -> Fail ("helper urls accepted: " <> T.pack (show slipped)), + runTest "an unknown explicit scheme is rejected" $ + assertLeft "hg scheme" (checkGitUrl "hg://example.com/repo"), + runTest "the empty url is rejected" $ + assertLeft "empty" (checkGitUrl ""), + runTestM "fetchGit refuses a helper transport at eval time" $ do + outcome <- evalNixIO "." "builtins.fetchGit { url = \"ext::printf x\"; }" + pure $ case outcome of + Left err + | "transport" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "helper transport url evaluated", + -- A ref reaching git as an option is command execution: git parses + -- options after the remote name, and --upload-pack names the + -- transport command. The leading-character class is what stops it. + runTest "a ref that git would read as an option is rejected" $ + let rejected = + [ "--upload-pack=touch /tmp/pwned", + "-o", + "--exec=sh", + "", + "branch with spaces", + "semi;colon", + "back\\slash" + ] + in case [ref | ref <- rejected, either (const False) (const True) (checkGitRef ref)] of + [] -> Pass + slipped -> Fail ("refs accepted: " <> T.pack (show slipped)), + runTest "ordinary ref names are accepted" $ + let accepted = ["main", "HEAD", "release/1.0", "v2.3.4", "user/topic-1", "@", "a+b"] + in case [ref | ref <- accepted, either (const True) (const False) (checkGitRef ref)] of + [] -> Pass + refused -> Fail ("refs refused: " <> T.pack (show refused)), + runTest "a rev must be a full SHA-1" $ + let rejected = + [ "--upload-pack=touch /tmp/pwned", + "dcb93b58", + "v1.0", + "main", + "", + T.replicate 40 "g", + T.replicate 41 "a" + ] + in case [rev | rev <- rejected, either (const False) (const True) (checkGitRev rev)] of + [] -> Pass + slipped -> Fail ("revs accepted: " <> T.pack (show slipped)), + runTest "a full SHA-1 is accepted in either case" $ + let accepted = [T.replicate 40 "a", T.replicate 40 "F", "dcb93b58bd982ab64323bac2a8c11b138d6b55e5"] + in case [rev | rev <- accepted, either (const True) (const False) (checkGitRev rev)] of + [] -> Pass + refused -> Fail ("revs refused: " <> T.pack (show refused)), + runTestM "fetchGit refuses an option-shaped ref at eval time" $ do + outcome <- evalNixIO "." "builtins.fetchGit { url = \"/srv/repo\"; ref = \"--upload-pack=id\"; }" + pure $ case outcome of + Left err + | "ref is not a valid git ref name" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "option-shaped ref evaluated" + ] + +-- --------------------------------------------------------------------------- +-- builtins.fetchGit against a real repository +-- --------------------------------------------------------------------------- + +-- | One git command against a fixture repository, identity and signing +-- pinned so no host configuration participates. Nonzero exit throws +-- with git's stderr, failing the calling test loudly. +fixtureGit :: FilePath -> [String] -> IO Text +fixtureGit dir args = do + (code, out, errOut) <- + Proc.readCreateProcessWithExitCode + (Proc.proc "git" (["-C", dir, "-c", "user.name=nova-nix-test", "-c", "user.email=test@nova-nix.invalid", "-c", "commit.gpgsign=false", "-c", "core.autocrlf=false"] ++ args)) + "" + case code of + ExitSuccess -> pure (T.strip (T.pack out)) + ExitFailure n -> fail ("fixture git " ++ unwords args ++ " exited " ++ show n ++ ": " ++ errOut) + +-- | A repository whose history is one commit per given file, oldest +-- first; returns the commit SHAs in that order. SHA wants are enabled +-- up front: a pinned rev that is no branch tip is only fetchable when +-- the serving side allows it, the same opt-in real servers use. +makeGitFixture :: FilePath -> [(FilePath, Text)] -> IO [Text] +makeGitFixture dir files = do + Dir.createDirectoryIfMissing True dir + _ <- fixtureGit dir ["init", "--quiet"] + _ <- fixtureGit dir ["config", "uploadpack.allowAnySHA1InWant", "true"] + mapM commitOne files + where + commitOne (name, contents) = do + BS.writeFile (dir name) (TE.encodeUtf8 contents) + _ <- fixtureGit dir ["add", "-A"] + _ <- fixtureGit dir ["commit", "--quiet", "-m", name] + fixtureGit dir ["rev-parse", "HEAD"] + +-- | 'evalNixIO' against an explicit store directory, for expressions +-- whose evaluation writes store objects. +evalNixIOStore :: StoreDir -> FilePath -> Text -> IO (Either Text NixValue) +evalNixIOStore storeDir baseDir source = case parseNix baseDir testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left (T.pack (show err))) + Right expr -> do + st <- newEvalState storeDir baseDir + runEvalIO st (eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr) + +testFetchGitShallow :: IO [Bool] +testFetchGitShallow = do + tmpBase <- getTemporaryDirectory + let repoDir = tmpBase "nova-nix-test-fetchgit-repo" + tmpStore = tmpBase "nova-nix-test-fetchgit-store" + cacheHome = tmpBase "nova-nix-test-fetchgit-cache" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + urlAttr = "url = \"" <> nixEscape (T.pack repoDir) <> "\"; " + evalFetch extra = evalNixIOStore (StoreDir tmpStore) "." ("builtins.fetchGit { " <> urlAttr <> extra <> "}") + forceRemoveIfExists repoDir + forceRemoveIfExists tmpStore + forceRemoveIfExists cacheHome + -- The fetch cache writes under XdgCache; point it at the scratch area + -- for the duration so the suite never touches the developer's cache. + savedCacheHome <- lookupEnv "XDG_CACHE_HOME" + setEnv "XDG_CACHE_HOME" cacheHome + shas <- makeGitFixture repoDir [("first.txt", "one\n"), ("second.txt", "two\n"), ("third.txt", "three\n")] + results <- + sequence + [ -- Upstream reports revCount 0 under shallow, not an absent + -- attribute and not the fetch depth: observed from + -- nix-instantiate 2.33.2, where '.revCount or "ABSENT"' is 0. + -- The tree itself is depth-independent, so both fetches must + -- agree on narHash and outPath. + runTestM "a shallow fetch reports revCount 0 for the same tree" $ do + fullOutcome <- evalFetch "" + shallowOutcome <- evalFetch "shallow = true; " + pure $ case (fullOutcome, shallowOutcome) of + (Left err, _) -> Fail ("full fetch failed: " <> err) + (_, Left err) -> Fail ("shallow fetch failed: " <> err) + (Right fullVal, Right shallowVal) -> + let fullFields = fetchGitFields fullVal ["revCount", "narHash", "outPath"] + shallowFields = fetchGitFields shallowVal ["revCount", "narHash", "outPath"] + in case (fullFields, shallowFields) of + ([("revCount", VInt 3), ("narHash", fullHash), ("outPath", fullPath)], [("revCount", VInt 0), ("narHash", shallowHash), ("outPath", shallowPath)]) + | fullHash == shallowHash && fullPath == shallowPath -> Pass + | otherwise -> Fail "shallow and full fetches disagree about the tree" + _ -> Fail (T.pack (show (fullFields, shallowFields))), + -- The rev itself is the refspec, so a depth-1 fetch of a rev + -- that is not the branch tip still lands on exactly that rev. + runTestM "a shallow fetch of a pinned rev checks out that rev" $ case shas of + (firstSha : _) -> do + outcome <- evalFetch ("shallow = true; rev = \"" <> firstSha <> "\"; ") + case outcome of + Left err -> pure (Fail err) + Right val -> case fetchGitFields val ["rev", "revCount", "outPath"] of + [("rev", revVal), ("revCount", VInt 0), ("outPath", VPath outText)] + | revVal == mkStr firstSha -> do + let outDir = storeTextToFilePath (StoreDir tmpStore) outText + firstThere <- Dir.doesFileExist (outDir "first.txt") + thirdThere <- Dir.doesFileExist (outDir "third.txt") + pure $ + if firstThere && not thirdThere + then Pass + else Fail "outPath does not hold the pinned rev's tree" + fields -> pure (Fail (T.pack (show fields))) + [] -> pure (Fail "fixture returned no commits"), + -- Pinned and unpinned differ in where counting starts: from the + -- rev, the root commit counts 1 (upstream 2.33.2 agrees), not + -- the branch's 3. + runTestM "a pinned rev fetch counts from the rev" $ case shas of + (firstSha : _) -> do + outcome <- evalFetch ("rev = \"" <> firstSha <> "\"; ") + pure $ case outcome of + Left err -> Fail err + Right val -> case fetchGitFields val ["rev", "revCount"] of + [("rev", revVal), ("revCount", VInt 1)] + | revVal == mkStr firstSha -> Pass + fields -> Fail (T.pack (show fields)) + [] -> pure (Fail "fixture returned no commits") + ] + maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome + forceRemoveIfExists repoDir + forceRemoveIfExists tmpStore + forceRemoveIfExists cacheHome + pure results + +-- | The fetchGit completeness remainder (#77): unsupported attributes +-- refuse, a declared narHash pins the tree on hit and fresh paths +-- alike, allRefs widens the fetch, and a failing fetch leaves no +-- scratch clone behind. +testFetchGitPins :: IO [Bool] +testFetchGitPins = do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-pins-store" + repoDir = tmpBase "nova-nix-test-pins-repo" + cacheHome = tmpBase "nova-nix-test-pins-cache" + urlText = T.concatMap (\c -> if c == '\\' then "\\\\" else T.singleton c) (T.pack repoDir) + evalHere = evalNixIOStore (StoreDir tmpStore) "." + fetchWith extra = evalHere ("builtins.fetchGit { url = \"" <> urlText <> "\"; " <> extra <> "}") + forceRemoveIfExists tmpStore + forceRemoveIfExists repoDir + forceRemoveIfExists cacheHome + savedCacheHome <- lookupEnv "XDG_CACHE_HOME" + setEnv "XDG_CACHE_HOME" cacheHome + shas <- makeGitFixture repoDir [("a.txt", "one\n")] + baseBranch <- fixtureGit repoDir ["rev-parse", "--abbrev-ref", "HEAD"] + _ <- fixtureGit repoDir ["checkout", "-q", "-b", "side"] + BS.writeFile (repoDir "side.txt") (TE.encodeUtf8 "side\n") + _ <- fixtureGit repoDir ["add", "-A"] + _ <- fixtureGit repoDir ["commit", "--quiet", "-m", "side"] + sideSha <- fixtureGit repoDir ["rev-parse", "HEAD"] + _ <- fixtureGit repoDir ["checkout", "-q", T.unpack baseBranch] + results <- + sequence + [ runTestM "an unsupported fetchGit attribute is refused" $ do + outcome <- fetchWith "bogus = 1; " + pure $ case outcome of + Left err + | "attribute 'bogus' not supported" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "an unsupported attribute was silently dropped", + runTestM "a mismatched narHash pin is an error" $ case shas of + (sha : _) -> do + outcome <- fetchWith ("rev = \"" <> sha <> "\"; narHash = \"sha256-" <> T.replicate 43 "A" <> "=\"; ") + pure $ case outcome of + Left err + | "NAR hash mismatch" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "a bogus narHash pin was silently ignored" + [] -> pure (Fail "fixture returned no commits"), + -- The second fetch of the same rev is a cache hit, so a matching + -- pin passing here proves the check runs on the hit path too. + runTestM "a matching narHash pin passes, including on a cache hit" $ case shas of + (sha : _) -> do + first <- fetchWith ("rev = \"" <> sha <> "\"; ") + case first of + Left err -> pure (Fail err) + Right val -> case fetchGitFields val ["narHash"] of + [("narHash", VStr hashBytes _)] -> do + let hash = TE.decodeUtf8Lenient hashBytes + second <- fetchWith ("rev = \"" <> sha <> "\"; narHash = \"" <> hash <> "\"; ") + pure $ case second of + Right _ -> Pass + Left err -> Fail ("a correct pin was refused: " <> err) + other -> pure (Fail (T.pack (show other))) + [] -> pure (Fail "fixture returned no commits"), + runTestM "allRefs finds a rev on an unfetched branch" $ do + outcome <- fetchWith ("rev = \"" <> sideSha <> "\"; allRefs = true; ") + pure $ case outcome of + Left err -> Fail err + Right val -> case fetchGitFields val ["rev"] of + [("rev", revVal)] | revVal == mkStr sideSha -> Pass + other -> Fail (T.pack (show other)), + runTestM "a failing fetch leaves no scratch clone behind" $ do + before <- filter ("nova-nix-fetchgit-" `T.isPrefixOf`) . map T.pack <$> Dir.listDirectory tmpBase + outcome <- evalHere ("builtins.fetchGit { url = \"" <> urlText <> "-no-such-repo\"; }") + after <- filter ("nova-nix-fetchgit-" `T.isPrefixOf`) . map T.pack <$> Dir.listDirectory tmpBase + pure $ case outcome of + Right _ -> Fail "a fetch of a missing repo succeeded" + Left _ + | length after == length before -> Pass + | otherwise -> Fail ("scratch clones leaked: " <> T.pack (show (length after - length before))) + ] + maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome + forceRemoveIfExists tmpStore + forceRemoveIfExists repoDir + forceRemoveIfExists cacheHome + pure results + +-- | String interpolation inside path literals (#178), the construct +-- nixpkgs uses 89 times on modern trees. Every rule here is pinned to +-- nix-instantiate 2.33.2's observed behavior: the result is a path, +-- pieces concatenate with no separator and canonicalize textually, a +-- path segment coerces without a store copy, context is refused, and +-- a trailing slash is a parse error. +testPathInterp :: IO [Bool] +testPathInterp = do + tmpBase <- getTemporaryDirectory + let fixtureDir = tmpBase "nova-nix-test-path-interp" + tmpStore = tmpBase "nova-nix-test-path-interp-store" + forceRemoveIfExists fixtureDir + forceRemoveIfExists tmpStore + Dir.createDirectoryIfMissing True (fixtureDir "sub") + BS.writeFile (fixtureDir "sub" "f.nix") (TE.encodeUtf8 "42") + let evalHere = evalNixIO fixtureDir + baseText = canonPathValue (T.pack fixtureDir) + results <- + sequence + [ runTestM "an interpolated path literal is a path" $ do + outcome <- evalHere "let v = \"sub\"; in builtins.typeOf ./${v}" + pure (assertRightValue outcome (mkStr "path")), + runTestM "a runtime dot-dot canonicalizes textually" $ do + outcome <- evalHere "let v = \"sub/..\"; in toString ./${v}" + pure (assertRightValue outcome (mkStr baseText)), + runTestM "pieces concatenate with no separator, mid-segment included" $ do + outcome <- evalHere "let v = \"a\"; in toString ./pre${v}${v}post" + pure (assertRightValue outcome (mkStr (baseText <> "/preaapost"))), + runTestM "an empty segment after the root is the root" $ do + outcome <- evalHere "toString /${\"\"}" + pure (assertRightValue outcome (mkStr "/")), + runTestM "a dotless relative literal interpolates" $ do + outcome <- evalHere "let v = \"f.nix\"; in toString sub/${v}" + pure (assertRightValue outcome (mkStr (baseText <> "/sub/f.nix"))), + runTestM "a path segment must coerce to a string" $ do + outcome <- evalHere "./${1}" + pure $ case outcome of + Left err + | "cannot coerce an integer to a string" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "an integer segment was accepted", + -- A path INSIDE a path interpolation appends its absolute text + -- with no store copy (string interpolation would copy) - + -- upstream's exact, odd, observable behavior. The expected text + -- goes through the canonicalizer because the separator between + -- the two halves is platform-shaped: on POSIX the inner path's + -- own leading slash serves, on Windows (C:...) the head's slash + -- survives instead. + runTestM "a path segment appends textually without a store copy" $ do + outcome <- evalHere "toString ./${./sub}" + pure (assertRightValue outcome (mkStr (canonPathValue (baseText <> "/" <> baseText <> "/sub")))), + runTestM "a context-carrying segment is refused" $ do + outcome <- evalNixIOStore (StoreDir tmpStore) fixtureDir "./${builtins.toFile \"n\" \"x\"}" + pure $ case outcome of + Left err + | "cannot be appended to a path" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "a store-path segment was accepted", + runTestM "a trailing slash is a parse error" $ do + outcome <- evalHere "let v = \"a\"; in ./sub/${v}/" + pure $ case outcome of + Left err + | "path has a trailing slash" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "a trailing slash parsed", + runTestM "a plain trailing-slash literal is a parse error" $ do + outcome <- evalHere "./sub/" + pure $ case outcome of + Left err + | "path has a trailing slash" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("wrong error: " <> err) + Right _ -> Fail "a trailing slash parsed", + runTestM "import resolves an interpolated dot-dot path" $ do + outcome <- evalHere "let v = \"sub\"; in import ./${v}/../sub/f.nix" + pure (assertRightValue outcome (VInt 42)), + -- An spath followed by /${...} is NOT one literal: it parses as + -- application of the search path to a path, which fails at + -- eval - upstream's exact shape. + runTestM "a search path does not absorb an interpolation" $ do + outcome <- evalHere "let v = \"a\"; in /${v}" + pure $ case outcome of + Left _ -> Pass + Right val -> Fail ("spath absorbed the interpolation: " <> T.pack (show val)) + ] + forceRemoveIfExists fixtureDir + forceRemoveIfExists tmpStore + pure results + where + assertRightValue outcome expected = case outcome of + Right val | val == expected -> Pass + other -> Fail (T.pack (show other)) + +-- | A path reached through an attrset's @outPath@ (or a @__toString@ +-- result) coerces exactly as the same path written directly: copied to +-- the store, with the store path in the string context. The broken +-- shape rendered the raw filesystem path with no copy and no context, +-- so @src = builtins.fetchGit { ... }@ produced empty inputSrcs and a +-- drvPath diverging from upstream, while the @.outPath@ spelling +-- worked. Verified against nix-instantiate 2.33.2: the attrset form's +-- drvPath now matches upstream byte for byte. +testOutPathCoercion :: IO [Bool] +testOutPathCoercion = do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-outpath-store" + srcDir = tmpBase "nova-nix-test-outpath-src" + cacheHome = tmpBase "nova-nix-test-outpath-cache" + repoDir = tmpBase "nova-nix-test-outpath-repo" + -- A RELATIVE path literal resolved against the eval's base dir: an + -- absolute Windows path (C:/...) is not a path literal at all - it + -- matches the URI rule (scheme:rest) and lexes as a string, which + -- correctly never copies. Relative spelling lexes as a path on + -- every platform. + srcLiteral = "./nova-nix-test-outpath-src" :: Text + drvPathWith srcExpr = + "(derivation { name = \"ctx-probe\"; system = \"x86_64-linux\"; " + <> "builder = \"/bin/sh\"; args = [\"-c\" \"echo ok > $out\"]; " + <> "src = " + <> srcExpr + <> "; }).drvPath" + evalHere = evalNixIOStore (StoreDir tmpStore) tmpBase + storeStr result = case result of + Right (VStr s _) -> Just (TE.decodeUtf8Lenient s) + _ -> Nothing + forceRemoveIfExists tmpStore + forceRemoveIfExists srcDir + forceRemoveIfExists cacheHome + forceRemoveIfExists repoDir + Dir.createDirectoryIfMissing True srcDir + BS.writeFile (srcDir "f.txt") (TE.encodeUtf8 "content\n") + savedCacheHome <- lookupEnv "XDG_CACHE_HOME" + setEnv "XDG_CACHE_HOME" cacheHome + gitShas <- makeGitFixture repoDir [("g.txt", "tracked\n")] + results <- + sequence + [ runTestM "an outPath attrset src derives the same drv as its path" $ do + attrForm <- evalHere (drvPathWith ("{ outPath = " <> srcLiteral <> "; }")) + pathForm <- evalHere (drvPathWith srcLiteral) + pure $ case (attrForm, pathForm) of + (Right a, Right b) + | a == b -> Pass + | otherwise -> Fail (T.pack (show (a, b))) + other -> Fail (T.pack (show other)), + runTestM "a fetchGit src derives the same drv as its outPath" $ case gitShas of + (sha : _) -> do + let fetch = "builtins.fetchGit { url = \"" <> T.concatMap (\c -> if c == '\\' then "\\\\" else T.singleton c) (T.pack repoDir) <> "\"; rev = \"" <> sha <> "\"; }" + attrForm <- evalHere (drvPathWith fetch) + outPathForm <- evalHere (drvPathWith ("(" <> fetch <> ").outPath")) + pure $ case (attrForm, outPathForm) of + (Right a, Right b) + | a == b -> Pass + | otherwise -> Fail (T.pack (show (a, b))) + other -> Fail (T.pack (show other)) + [] -> pure (Fail "fixture returned no commits"), + -- Text-only assertions here and below: a source copy is + -- materialized by the build driver, not by a bare eval, so the + -- observable at eval time is the store-path spelling. The two + -- drvPath tests above cover the context end (an uncontexted src + -- would derive a different drv). + runTestM "interpolating an outPath attrset coerces to its store path" $ do + outcome <- evalHere ("\"${ { outPath = " <> srcLiteral <> "; } }\"") + pure $ case storeStr outcome of + Just text | isCanonicalStoreText text -> Pass + _ -> Fail (T.pack (show outcome)), + runTestM "a __toString path result coerces to its store path" $ do + outcome <- evalHere ("\"${ { __toString = self: " <> srcLiteral <> "; } }\"") + pure $ case storeStr outcome of + Just text | isCanonicalStoreText text -> Pass + _ -> Fail (T.pack (show outcome)), + runTestM "adding an outPath attrset to a string coerces to its store path" $ do + outcome <- evalHere ("\"src: \" + { outPath = " <> srcLiteral <> "; }") + pure $ case storeStr outcome of + Just text | Just rest <- T.stripPrefix "src: " text, isCanonicalStoreText rest -> Pass + _ -> Fail (T.pack (show outcome)), + runTestM "toJSON of an outPath attrset is its store path" $ do + outcome <- evalHere ("builtins.toJSON { outPath = " <> srcLiteral <> "; }") + pure $ case storeStr outcome of + Just text + | Just inner <- T.stripPrefix "\"" text >>= T.stripSuffix "\"", + isCanonicalStoreText inner -> + Pass + _ -> Fail (T.pack (show outcome)) + ] + maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome + forceRemoveIfExists tmpStore + forceRemoveIfExists srcDir + forceRemoveIfExists cacheHome + forceRemoveIfExists repoDir + pure results + +testScratchDirs :: IO [Bool] +testScratchDirs = do + putStrLn "eval/scratch-dirs" + st <- newEvalState platformStoreDir "." + sequence + [ runTestM "scratch dirs are distinct, real, and removable" $ do + createdA <- runEvalIO st (createScratchDir "nova-nix-test-scratch-") + createdB <- runEvalIO st (createScratchDir "nova-nix-test-scratch-") + case (createdA, createdB) of + (Right dirA, Right dirB) + | dirA == dirB -> pure (Fail "two scratch dirs share a name") + | otherwise -> do + existedA <- Dir.doesDirectoryExist (T.unpack dirA) + existedB <- Dir.doesDirectoryExist (T.unpack dirB) + removed <- runEvalIO st (removeScratchDir dirA >> removeScratchDir dirB) + goneA <- not <$> Dir.doesDirectoryExist (T.unpack dirA) + goneB <- not <$> Dir.doesDirectoryExist (T.unpack dirB) + pure $ case removed of + Left err -> Fail ("removeScratchDir failed: " <> err) + Right () + | existedA && existedB && goneA && goneB -> Pass + | otherwise -> Fail "scratch dir lifecycle out of order" + (Left err, _) -> pure (Fail ("createScratchDir failed: " <> err)) + (_, Left err) -> pure (Fail ("createScratchDir failed: " <> err)), + runTestM "scratch names carry the requested prefix" $ do + created <- runEvalIO st (createScratchDir "nova-nix-test-scratch-") + case created of + Left err -> pure (Fail ("createScratchDir failed: " <> err)) + Right dir -> do + removed <- runEvalIO st (removeScratchDir dir) + pure $ case removed of + Left err -> Fail ("removeScratchDir failed: " <> err) + Right () + | "nova-nix-test-scratch-" `T.isInfixOf` dir -> Pass + | otherwise -> Fail ("prefix missing from: " <> dir) + ] + +testNarKnownAnswer :: IO [Bool] +testNarKnownAnswer = do + putStrLn "nar/known-answer" + sequence + [ runTest "serialise matches the hand-written spec vector" $ + if NAR.serialise narSpecTree == narSpecVector + then Pass + else Fail "NAR encoder no longer matches the spec byte layout", + runTest "deserialise reads the spec vector back" $ + case NAR.deserialise narSpecVector of + Right entry + | NAR.serialise entry == narSpecVector -> Pass + | otherwise -> Fail "spec vector round-trips to different bytes" + Left err -> Fail ("spec vector rejected: " <> T.pack err), + -- The empty-input SHA-256 in nix-base32: pins digest, alphabet, and + -- bit order against the value real Nix computes. + runTest "sha256 empty formats to the known nix-base32 vector" $ + assertEqual + "nix32-empty" + "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" + (CHash.formatNixHash (CHash.hashBytes BS.empty)), + -- addToStore must record exactly the hash of the spec bytes for the + -- same tree, or interop with every real cache silently breaks. + runTestM "addToStore records the externally-computed NAR hash" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-nar-vector-src" + tmpStore = tmpBase "nova-nix-test-nar-vector-store" + forceRemoveIfExists srcDir + forceRemoveIfExists tmpStore + createDirectoryIfMissing True srcDir + createDirectoryIfMissing True tmpStore + BS.writeFile (srcDir "data.txt") "hello\n" + store <- openStore (StoreDir tmpStore) + let sp = StorePath (T.replicate 32 "e") "nar-vector" + addToStore store srcDir sp Nothing [] + recorded <- queryPathInfo (stDB store) sp + closeStore store + forceRemoveIfExists tmpStore + let expected = CHash.formatNixHash (CHash.hashBytes narSpecFileVector) + pure $ case recorded of + Just info -> assertEqual "recorded NarHash" expected (piNarHash info) + Nothing -> Fail "path not registered" + ] + +-- | store delete: row-and-tree removal with referrer refusal. The raw +-- basename channel exists for rows the current name rules reject; the +-- legacy-row case plants one over SQL exactly as a pre-name-rules store +-- carries it. +testStoreDelete :: IO [Bool] +testStoreDelete = do + putStrLn "store/delete" + withTempStore $ \store -> do + let sd = stDir store + basenameOf sp = spHash sp <> "-" <> spName sp + dep = StorePath (T.replicate 32 "a") "del-dep" + user = StorePath (T.replicate 32 "b") "del-user" + sequence + [ runTestM "referenced path is refused with its referrers listed" $ do + registerPaths + (stDB store) + [ PathRegistration dep "sha256:d" 1 Nothing [], + PathRegistration user "sha256:u" 1 Nothing [dep] + ] + outcome <- deleteStorePathRaw store (basenameOf dep) + stillValid <- isValid store dep + pure $ case outcome of + Left err + | "referenced by" `T.isInfixOf` err, + T.pack (storePathToFilePath sd user) `T.isInfixOf` err, + stillValid -> + Pass + | otherwise -> Fail ("wrong refusal: " <> err) + Right removed -> Fail ("deleted a referenced path: " <> T.pack (show removed)), + runTestM "a reference chain deletes leaf-first" $ do + userGone <- deleteStorePathRaw store (basenameOf user) + depGone <- deleteStorePathRaw store (basenameOf dep) + depValid <- isValid store dep + userValid <- isValid store user + pure $ case (userGone, depGone) of + (Right _, Right _) + | not depValid && not userValid -> Pass + | otherwise -> Fail "rows survived deletion" + other -> Fail ("chain deletion failed: " <> T.pack (show other)), + runTestM "a registered row without a tree deletes (repair case)" $ do + let ghost = StorePath (T.replicate 32 "c") "del-ghost" + registerPath (stDB store) (PathRegistration ghost "sha256:g" 1 Nothing []) + outcome <- deleteStorePathRaw store (basenameOf ghost) + pure $ case outcome of + Right removed + | doRowRemoved removed && not (doTreeRemoved removed) -> Pass + | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) + Left err -> Fail err, + runTestM "an unregistered tree deletes (repair case)" $ do + let strayBase = T.replicate 32 "d" <> "-del-stray" + treePath = unStoreDir sd T.unpack strayBase + createDirectoryIfMissing True treePath + TIO.writeFile (treePath "junk.txt") "stray" + outcome <- deleteStorePathRaw store strayBase + gone <- not <$> Dir.doesPathExist treePath + pure $ case outcome of + Right removed + | not (doRowRemoved removed), doTreeRemoved removed, gone -> Pass + | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) + Left err -> Fail err, + runTestM "a read-only registered tree deletes fully" $ do + let solid = StorePath (T.replicate 32 "e") "del-solid" + treePath = storePathToFilePath sd solid + registerPath (stDB store) (PathRegistration solid "sha256:s" 1 Nothing []) + createDirectoryIfMissing True treePath + TIO.writeFile (treePath "data.txt") "content" + setReadOnly treePath + outcome <- deleteStorePathRaw store (basenameOf solid) + gone <- not <$> Dir.doesPathExist treePath + stillValid <- isValid store solid + pure $ case outcome of + Right removed + | doRowRemoved removed, doTreeRemoved removed, gone, not stillValid -> Pass + | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) + Left err -> Fail err, + runTestM "a self-referencing path deletes" $ do + let selfp = StorePath (T.replicate 32 "f") "del-self" + registerPath (stDB store) (PathRegistration selfp "sha256:f" 1 Nothing [selfp]) + outcome <- deleteStorePathRaw store (basenameOf selfp) + pure (assertEqual "self delete" (Right (DeleteOutcome True False)) outcome), + runTestM "a target with neither row nor tree is an error" $ do + outcome <- deleteStorePathRaw store (T.replicate 32 "9" <> "-del-nothing") + pure $ case outcome of + Left err | "not in this store" `T.isInfixOf` err -> Pass + other -> Fail ("expected not-in-store, got: " <> T.pack (show other)), + runTestM "a legacy row the validator rejects deletes by raw text" $ do + let legacyBase = T.replicate 32 "g" <> "-old~marker" + treePath = unStoreDir sd T.unpack legacyBase + legacyPathText = T.pack treePath + conn <- SQL.open (unStoreDir sd metaDirName dbFileName) + SQL.execute + conn + "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) VALUES (?, ?, 0, NULL, 0)" + (legacyPathText, "sha256:legacy" :: T.Text) + SQL.close conn + createDirectoryIfMissing True treePath + TIO.writeFile (treePath "seed.txt") "epoch" + let resolved = resolveDeleteTarget sd legacyPathText + outcome <- either (pure . Left) (deleteStorePathRaw store) resolved + remaining <- queryAllValidPaths (stDB store) + gone <- not <$> Dir.doesPathExist treePath + pure $ case outcome of + Right removed + | doRowRemoved removed, doTreeRemoved removed, gone, legacyPathText `notElem` remaining -> Pass + | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) + Left err -> Fail err, + runTest "resolveDeleteTarget accepts bare, store-dir, platform, and canonical spellings" $ + let nameBase = T.replicate 32 "h" <> "-name" + spellings = + [ nameBase, + T.pack (unStoreDir sd T.unpack nameBase), + T.pack (unStoreDir platformStoreDir) <> "\\" <> nameBase, + defaultStoreDirText <> "/" <> nameBase + ] + in assertEqual "all resolve" (replicate 4 (Right nameBase)) (map (resolveDeleteTarget sd) spellings), + runTest "resolveDeleteTarget refuses traversal shapes" $ + let refused = + [ ".nova-nix", + "..", + ".", + "", + T.pack (unStoreDir sd) <> "/", + "/somewhere/else/" <> T.replicate 32 "h" <> "-name", + T.replicate 32 "h" <> "-na:me" + ] + in case [t | t <- refused, either (const False) (const True) (resolveDeleteTarget sd t)] of + [] -> Pass + accepted -> Fail ("accepted: " <> T.pack (show accepted)), + -- Lock files are never deleted (the Nix.Store.Lock design), but + -- names like flake.lock are legal store-path names, so only the + -- registration rows can tell a lock file from a store object: + -- an unregistered lock-shaped file refuses, a registered object + -- of the same shape deletes, and lock-shaped junk whose + -- stripped prefix is not a store basename deletes as junk. + runTestM "delete refuses an unregistered lock file by name" $ do + let guarded = StorePath (T.replicate 32 "j") "del-guard" + lockBase = basenameOf guarded <> ".lock" + lockPath = storePathToFilePath sd guarded <> ".lock" + TIO.writeFile lockPath "" + outcome <- deleteStorePathRaw store lockBase + survived <- Dir.doesPathExist lockPath + pure $ case outcome of + Left err + | "never deleted" `T.isInfixOf` err -> + if survived then Pass else Fail "lock file removed despite refusal" + | otherwise -> Fail ("wrong refusal: " <> err) + Right _ -> Fail "unregistered lock file was deleted", + runTestM "delete removes a registered store object named like a lock file" $ do + let object = StorePath (T.replicate 32 "k") "flake.lock" + objectPath = storePathToFilePath sd object + registerPath (stDB store) (PathRegistration object "sha256:m" 1 Nothing []) + TIO.writeFile objectPath "pinned inputs" + outcome <- deleteStorePathRaw store (basenameOf object) + gone <- not <$> Dir.doesPathExist objectPath + pure $ case outcome of + Right removed + | doRowRemoved removed, doTreeRemoved removed, gone -> Pass + | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) + Left err -> Fail ("registered .lock-named object refused: " <> err), + runTestM "delete removes lock-shaped junk with no store-shaped prefix" $ do + let junkName = "not-a-store-path.lock" + junkPath = unStoreDir sd T.unpack junkName + TIO.writeFile junkPath "debris" + outcome <- deleteStorePathRaw store junkName + gone <- not <$> Dir.doesPathExist junkPath + pure $ case outcome of + Right removed + | doTreeRemoved removed, gone -> Pass + | otherwise -> Fail ("wrong outcome: " <> T.pack (show removed)) + Left err -> Fail ("lock-shaped junk refused: " <> err), + -- Deletion and substitution contend on one per-path lock: a + -- delete must wait while another handle holds the path's lock - + -- otherwise it can tear a tree out between a substituter's + -- on-disk recheck and its registration commit - and proceed + -- once the holder releases. + runTestM "delete waits for a held path lock and proceeds on release" $ do + let guarded = StorePath (T.replicate 32 "i") "del-locked" + treePath = storePathToFilePath sd guarded + registerPath (stDB store) (PathRegistration guarded "sha256:l" 1 Nothing []) + createDirectoryIfMissing True treePath + TIO.writeFile (treePath "data.txt") "guarded" + holder <- acquirePathLock sd guarded + done <- newEmptyMVar + _ <- forkIO (deleteStorePathRaw store (basenameOf guarded) >>= putMVar done) + early <- timeout deleteLockProbeMicros (takeMVar done) + releasePathLock holder + outcome <- timeout raceWatchdogMicros (takeMVar done) + gone <- not <$> Dir.doesPathExist treePath + pure $ case (early, outcome) of + (Just finished, _) -> + Fail ("delete ignored the held lock: " <> T.pack (show finished)) + (Nothing, Just (Right removed)) + | doRowRemoved removed, doTreeRemoved removed, gone -> Pass + | otherwise -> Fail ("wrong outcome after release: " <> T.pack (show removed)) + (Nothing, other) -> + Fail ("delete never completed after release: " <> T.pack (show other)), + -- The eval-side materializer joins the same protocol (#21): its + -- check-then-act must wait while another handle holds the + -- path's lock - unlocked, the loser's removePathForcibly could + -- delete the tree the winner had just registered - and proceed + -- once the holder releases. + runTestM "materializeEvalSources waits for a held path lock" $ do + srcDir <- ( "nova-nix-test-mat-lock-src") <$> getTemporaryDirectory + forceRemoveIfExists srcDir + createDirectoryIfMissing True srcDir + TIO.writeFile (srcDir "f.txt") "locked source" + -- The address the source's content derives, as evaluation + -- would name it: a restore refuses any other. + entry <- NAR.serialiseFromPath srcDir + case makeFixedOutputPath "mat-locked" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right guarded -> do + let spText = storePathToText defaultStoreDir guarded + holder <- acquirePathLock sd guarded + done <- newEmptyMVar + _ <- forkIO (materializeEvalSources store (Map.singleton (T.pack srcDir) spText) >>= putMVar done) + early <- timeout deleteLockProbeMicros (takeMVar done) + releasePathLock holder + outcome <- timeout raceWatchdogMicros (takeMVar done) + registered <- isValid store guarded + forceRemoveIfExists srcDir + pure $ case (early, outcome) of + (Just _, _) -> Fail "materialize ignored the held lock" + (Nothing, Just ()) + | registered -> Pass + | otherwise -> Fail "proceeded after release but never registered" + (Nothing, Nothing) -> Fail "materialize never completed after release" + ] + +-- | The collector's pure core: the reachability walk over the references +-- map, and the sweep plan over the valid set, the live set, and the store +-- directory's entries. No store is opened. +testGcPure :: IO [Bool] +testGcPure = do + putStrLn "store/gc-pure" + let sd = StoreDir "/s" + at name = T.pack (unStoreDir sd name) + refs = referencesMap [(at "a", at "b"), (at "b", at "c"), (at "d", at "c"), (at "e", at "e")] + hashOf c = T.unpack (T.replicate 32 c) + liveName = hashOf "a" <> "-gc-live" + deadOnDisk = hashOf "b" <> "-gc-dead" + deadNoTree = hashOf "c" <> "-gc-ghost" + stale = hashOf "d" <> "-gc-stale" + nix32Alphabet = "0123456789abcdfghijklmnpqrsvwxyz" :: String + sequence + [ runTest "reachableFrom closes over references transitively" $ + assertEqual "closure" (Set.fromList [at "a", at "b", at "c"]) (reachableFrom refs [at "a"]), + runTest "reachableFrom leaves paths the roots do not reach out" $ + assertEqual "d alone" (Set.fromList [at "c", at "d"]) (reachableFrom refs [at "d"]), + runTest "reachableFrom terminates on a cycle and a self-reference" $ + assertEqual + "cycle, self" + (Set.fromList [at "x", at "y"], Set.singleton (at "e")) + (reachableFrom (referencesMap [(at "x", at "y"), (at "y", at "x")]) [at "x"], reachableFrom refs [at "e"]), + runTest "reachableFrom keeps a root the map does not know as a dead end" $ + assertEqual "unknown root" (Set.singleton (at "z")) (reachableFrom refs [at "z"]), + runTest "reachableFrom of no roots is empty" $ + assertEqual "no roots" Set.empty (reachableFrom refs []), + -- Dead rows go whether or not a tree exists; every directory entry + -- that is not live goes too (a dead tree, a stale build, junk, a + -- dead path's lock file), while the live path, its lock file and + -- the metadata directory stay. + runTest "sweepPlan unregisters dead rows and removes every entry that is not live, keeping a live path's lock file" $ + let valid = Set.fromList [at liveName, at deadOnDisk, at deadNoTree] + live = Set.fromList [at liveName] + entries = map T.pack [liveName, liveName <> ".lock", deadOnDisk, deadOnDisk <> ".lock", metaDirName, stale, stale <> ".lock", "junk-file"] + in assertEqual + "plan" + SweepPlan + { spDeadRows = sort [at deadOnDisk, at deadNoTree], + spTrees = sort [at deadOnDisk, at (deadOnDisk <> ".lock"), at stale, at (stale <> ".lock"), at "junk-file"] + } + (sweepPlan sd valid live entries), + runTest "sweepPlan removes a dead registered object named like a live path's lock file" $ + let lockNamed = liveName <> ".lock" + valid = Set.fromList [at liveName, at lockNamed] + live = Set.fromList [at liveName] + in assertEqual + "plan" + SweepPlan {spDeadRows = [at lockNamed], spTrees = [at lockNamed]} + (sweepPlan sd valid live (map T.pack [liveName, lockNamed])), + runTest "parseStorePathPrefix names the path for itself, a trailing separator and anything beneath, and nothing outside" $ + let sp = StorePath (T.replicate 32 "a") "gc-live" + dirText = T.pack (unStoreDir sd) + named = map (parseStorePathPrefix sd) [at liveName, at liveName <> "/", at liveName <> "/bin/tool", at liveName <> "\\bin"] + unnamed = map (parseStorePathPrefix sd) [dirText, dirText <> "/", "/elsewhere/" <> T.pack liveName, dirText <> "/not-a-store-path"] + in assertEqual "prefixes" (replicate 4 (Just sp), replicate 4 Nothing) (named, unnamed), + runTest "showFreedBytes renders upstream's two-place MiB" $ + assertEqual "MiB" ["0.00 MiB", "1.00 MiB", "1.50 MiB"] (map showFreedBytes [0, 1048576, 1572864]), + runTest "gcSummaryLine is upstream's PrintFreed line" $ + assertEqual "summary" "2 store paths deleted, 1.00 MiB freed" (gcSummaryLine (GcResults [at "a", at "b"] 1048576)), + runTest "indirectRootRecordName is a nix-base32 digest keyed by the link path" $ + let name = indirectRootRecordName "/home/u/result" + in if length name == 52 && all (`elem` nix32Alphabet) name && name /= indirectRootRecordName "/home/u/result-2" + then Pass + else Fail ("unexpected record name: " <> T.pack name) + ] + +-- | Garbage collection end to end against a temp store: a rooted closure +-- survives and the orphan goes, the rooted path and what it reaches +-- cannot be deleted, one directory keys one store however it is +-- spelled while a foreign spelling is refused, a removed root lets the +-- closure go, a dead cycle sweeps, a dead path's lock file goes with it, +-- a second open handle holds the collector off, a failed lease renewal +-- leaves a closable handle, and an out-link root behaves as nix-build's +-- result link does. +testStoreGC :: IO [Bool] +testStoreGC = do + putStrLn "store/gc" + canLink <- symlinksAvailable + tmpBase <- getTemporaryDirectory + let linkDir = tmpBase "nova-nix-test-gc-links" + outLink = linkDir "result" + Dir.removePathForcibly linkDir + createDirectoryIfMissing True linkDir + withTempStore $ \store -> do + let sd = stDir store + basenameOf sp = spHash sp <> "-" <> spName sp + pathText sp = T.pack (storePathToFilePath sd sp) + lockOf sp = storePathToFilePath sd sp <> ".lock" + plant sp bytes = do + let tree = storePathToFilePath sd sp + createDirectoryIfMissing True tree + BS.writeFile (tree "data") bytes + dep = StorePath (T.replicate 32 "a") "gc-dep" + top = StorePath (T.replicate 32 "b") "gc-top" + orphan = StorePath (T.replicate 32 "c") "gc-orphan" + rootFile = gcRootsDir sd T.unpack (basenameOf top) + registerTrio = do + mapM_ (uncurry plant) [(dep, "dep"), (top, "top!"), (orphan, "orphan bytes")] + registerPaths + (stDB store) + [ PathRegistration dep "sha256:d" 1 Nothing [], + PathRegistration top "sha256:t" 1 Nothing [dep], + PathRegistration orphan "sha256:o" 1 Nothing [] + ] + -- A refused collection is a failure of the test, not a result. + collect = collectGarbage store >>= either (throwIO . userError . T.unpack) pure + permanent <- + sequence + [ -- A regular file named like the path, under gcroots: upstream's + -- own permanent-root form, the one that needs no symlink. + runTestM "a permanent root keeps its closure and the orphan is swept" $ do + registerTrio + createDirectoryIfMissing True (gcRootsDir sd) + BS.writeFile rootFile "" + results <- collect + validity <- mapM (isValid store) [dep, top, orphan] + orphanGone <- not <$> Dir.doesPathExist (storePathToFilePath sd orphan) + topKept <- Dir.doesPathExist (storePathToFilePath sd top "data") + pure $ + if results == GcResults [pathText orphan] 12 && validity == [True, True, False] && orphanGone && topKept + then Pass + else Fail ("wrong sweep: " <> T.pack (show (results, validity, orphanGone, topKept))), + runTestM "delete refuses the rooted path with upstream's words" $ do + outcome <- deleteStorePathRaw store (basenameOf top) + stillValid <- isValid store top + pure $ case outcome of + Left err + | "since it is still alive" `T.isInfixOf` err, pathText top `T.isInfixOf` err, stillValid -> Pass + | otherwise -> Fail ("wrong refusal: " <> err) + Right removed -> Fail ("deleted a rooted path: " <> T.pack (show removed)), + runTestM "delete refuses a path the root reaches through references" $ do + outcome <- deleteStorePathRaw store (basenameOf dep) + pure $ case outcome of + Left err | "since it is still alive" `T.isInfixOf` err -> Pass + other -> Fail ("expected the liveness refusal, got: " <> T.pack (show other)), + runTestM "findRoots reports the permanent root under its own path" $ do + roots <- findRoots store + pure (assertEqual "roots" [GcRoot rootFile (pathText top)] roots), + -- One directory keys one set of rows however it is spelled: the + -- handle canonicalises the spelling at open, so a second handle + -- opened through '.', '..' and a trailing separator (and, when + -- the temp store shares the working directory's drive, through + -- a relative path) is the same store with the same root. + runTestM "openStore keys the store by one spelling of its directory" $ do + cwd <- Dir.getCurrentDirectory + let dotted = unStoreDir sd "." "zig" ".." <> [pathSeparator] + relative = + [ joinPath (replicate (length (splitDirectories cwd) - 1) "..") dropDrive (unStoreDir sd) + | takeDrive cwd == takeDrive (unStoreDir sd) + ] + spellings = dotted : relative + inspect spelling = do + other <- openStore (StoreDir spelling) + roots <- findRoots other + closeStore other + pure (stDir other, roots) + outcomes <- mapM inspect spellings + pure (assertEqual "spellings" (map (const (sd, [GcRoot rootFile (pathText top)])) spellings) outcomes), + -- A row keyed under another spelling of the directory would + -- compare as dead; the collector and the checked delete refuse + -- instead of sweeping, and nothing changes. + runTestM "a collection and a checked delete refuse a database keyed under another spelling" $ do + let foreignRow = "/elsewhere/" <> T.replicate 32 "z" <> "-gc-foreign" + conn <- SQL.open (unStoreDir sd metaDirName dbFileName) + SQL.execute + conn + "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) VALUES (?, ?, 0, NULL, 0)" + (foreignRow, "sha256:z" :: T.Text) + collected <- collectGarbage store + deleted <- deleteStorePathRaw store (basenameOf dep) + SQL.execute conn "DELETE FROM ValidPaths WHERE path = ?" (SQL.Only foreignRow) + SQL.close conn + validity <- mapM (isValid store) [dep, top, orphan] + topKept <- Dir.doesPathExist (storePathToFilePath sd top "data") + pure $ case (collected, deleted) of + (Left gcErr, Left delErr) + | "another spelling" `T.isInfixOf` gcErr, + "another spelling" `T.isInfixOf` delErr, + validity == [True, True, False], + topKept -> + Pass + other -> Fail ("expected both refusals, got: " <> T.pack (show (other, validity, topKept))), + -- Upstream reports an entry it cannot read and carries on; a + -- directory with no permissions is the reproducible case, and + -- one that lists anyway (root, or Windows, where permissions + -- do not forbid a listing) proves nothing and is skipped. + runTestM "an unreadable entry under gcroots is reported and skipped" $ do + let locked = gcRootsDir sd "locked" + unlock = do + Dir.setPermissions locked (Dir.setOwnerReadable True (Dir.setOwnerSearchable True (Dir.setOwnerWritable True Dir.emptyPermissions))) + Dir.removePathForcibly locked + createDirectoryIfMissing True locked + Dir.setPermissions locked Dir.emptyPermissions + readable <- try (Dir.listDirectory locked) :: IO (Either SomeException [FilePath]) + -- Restored on every exit: a walk that throws here would + -- otherwise leave the directory unreadable for every later + -- root walk in the group. + roots <- findRoots store `finally` unlock + case readable of + Right _ -> Pass <$ putStrLn " SKIP an empty-permission directory is readable here" + Left _ -> pure (assertEqual "roots" [GcRoot rootFile (pathText top)] roots), + runTestM "removing the root lets the closure go in one sweep" $ do + Dir.removeFile rootFile + results <- collect + remaining <- queryAllValidPaths (stDB store) + depGone <- not <$> Dir.doesPathExist (storePathToFilePath sd dep) + pure $ + if gcrDeleted results == [pathText dep, pathText top] && null remaining && depGone + then Pass + else Fail ("closure survived: " <> T.pack (show (results, remaining, depGone))), + -- Cross-output references run both ways between the outputs of + -- one derivation, and no order of one-row deletes gets through + -- that; the batch delete does. + runTestM "a dead reference cycle is swept" $ do + let out = StorePath (T.replicate 32 "d") "gc-cycle-out" + dev = StorePath (T.replicate 32 "e") "gc-cycle-dev" + mapM_ (uncurry plant) [(out, "o"), (dev, "d")] + registerPaths + (stDB store) + [ PathRegistration out "sha256:x" 1 Nothing [dev], + PathRegistration dev "sha256:y" 1 Nothing [out] + ] + results <- collect + remaining <- queryAllValidPaths (stDB store) + pure (assertEqual "swept" ([pathText out, pathText dev], []) (gcrDeleted results, remaining)), + -- Every entry that is not live goes, a dead path's lock file + -- with it; a live path's lock file is the one lock file the + -- protocol keeps, and it goes once the path does. + runTestM "a dead path's lock file is swept with it and a live path's stays until the path goes" $ do + registerTrio + BS.writeFile rootFile "" + let stale = StorePath (T.replicate 32 "f") "gc-stale" + plant stale "stale" + BS.writeFile (lockOf stale) "" + BS.writeFile (lockOf top) "" + first <- collect + staleGone <- not <$> Dir.doesPathExist (storePathToFilePath sd stale) + staleLockGone <- not <$> Dir.doesPathExist (lockOf stale) + topLockKept <- Dir.doesPathExist (lockOf top) + Dir.removeFile rootFile + second <- collect + topLockGone <- not <$> Dir.doesPathExist (lockOf top) + remaining <- queryAllValidPaths (stDB store) + pure $ + if gcrDeleted first == sort [pathText orphan, pathText stale, T.pack (lockOf stale)] + && staleGone + && staleLockGone + && topLockKept + && gcrDeleted second == sort [pathText dep, pathText top, T.pack (lockOf top)] + && topLockGone + && null remaining + then Pass + else Fail ("wrong sweep: " <> T.pack (show (first, staleGone, staleLockGone, topLockKept, second, topLockGone, remaining))), + -- Every open handle holds the collector lock shared; the + -- collector needs it exclusive, so it waits for the other + -- handle to close and runs the moment it does. + runTestM "collectGarbage waits for another open handle to close" $ do + other <- openStore sd + done <- newEmptyMVar + _ <- forkIO (collect >>= putMVar done) + early <- timeout deleteLockProbeMicros (takeMVar done) + closeStore other + outcome <- timeout raceWatchdogMicros (takeMVar done) + pure $ case (early, outcome) of + (Just _, _) -> Fail "collector ignored the other handle's lease" + (Nothing, Just _) -> Pass + (Nothing, Nothing) -> Fail "collector never ran after the other handle closed", + -- A renewal that fails must not leave the handle without a + -- lease slot, or closeStore waits forever. The lock file is + -- replaced by a directory while the exclusive lock is held, so + -- the shared re-acquire cannot open it; Windows forbids + -- replacing a held file, so the case is POSIX-only. + runTestM "withCollectorLock leaves a closable handle when the lease cannot be renewed" $ + if SI.os == "mingw32" + then Pass <$ putStrLn " SKIP a held lock file cannot be replaced on Windows" + else do + let renewalStore = tmpBase "nova-nix-test-gc-renewal" + Dir.removePathForcibly renewalStore + other <- openStore (StoreDir renewalStore) + let lockPath = gcLockFilePath (stDir other) + swapped <- try (withCollectorLock other (Dir.removeFile lockPath >> Dir.createDirectory lockPath)) + closed <- timeout raceWatchdogMicros (closeStore other) + Dir.removePathForcibly renewalStore + pure $ case (swapped :: Either SomeException (), closed) of + (Left _, Just ()) -> Pass + (Right (), _) -> Fail "renewal succeeded against a directory" + (Left _, Nothing) -> Fail "closeStore hung after a failed renewal" + ] + linked <- + if not canLink + then do + putStrLn " SKIP out-link roots need symlink privilege" + pure [] + else + sequence + [ runTestM "an out-link root keeps the closure until the link is removed" $ do + registerTrio + rooted <- addOutLinkRoot store outLink top + case rooted of + Left err -> pure (Fail err) + Right link -> do + let record = autoRootsDir sd indirectRootRecordName link + recordThere <- Dir.doesFileExist record + roots <- findRoots store + first <- collect + Dir.removePathForcibly link + second <- collect + recordGone <- not <$> Dir.doesFileExist record + remaining <- queryAllValidPaths (stDB store) + pure $ + if roots == [GcRoot link (pathText top)] + && recordThere + && gcrDeleted first == [pathText orphan] + && gcrDeleted second == [pathText dep, pathText top] + && recordGone + && null remaining + then Pass + else Fail ("out-link root misbehaved: " <> T.pack (show (roots, recordThere, first, second, recordGone, remaining))), + -- upstream's findRoots takes toStorePath of the target, so a + -- link into a store path's subtree, or to the path with a + -- trailing separator, roots the path. + runTestM "a symlink root into a store path's subtree or with a trailing separator roots the path" $ do + plant top "top" + registerPath (stDB store) (PathRegistration top "sha256:t" 1 Nothing []) + let subLink = gcRootsDir sd "sub" + slashLink = gcRootsDir sd "slash" + Dir.createFileLink (storePathToFilePath sd top "data") subLink + Dir.createDirectoryLink (storePathToFilePath sd top <> [pathSeparator]) slashLink + roots <- findRoots store + mapM_ Dir.removePathForcibly [subLink, slashLink] + pure (assertEqual "roots" [GcRoot slashLink (pathText top), GcRoot subLink (pathText top)] roots), + -- upstream dedups through a set keyed by (link, path); an + -- operator's symlink to the out-link and the out-link's own + -- record name the same root. + runTestM "findRoots lists one link once when two records name it" $ do + rooted <- addOutLinkRoot store outLink top + case rooted of + Left err -> pure (Fail err) + Right link -> do + let mine = gcRootsDir sd "mine" + Dir.createFileLink link mine + roots <- findRoots store + mapM_ Dir.removePathForcibly [mine, link] + pure (assertEqual "roots" [GcRoot link (pathText top)] roots), + -- upstream's addPermRoot canonPaths the link and makeSymlink + -- creates its parents; a '..' that lands inside the store is + -- refused as inside. + runTestM "addOutLinkRoot collapses .. and creates missing parents, and .. cannot spell a link into the store" $ do + let expectedLink = T.unpack (canonPath (T.pack (linkDir "deep" "result"))) + dotted = linkDir "deep" "down" ".." "result" + insideViaDotDot = takeDirectory (unStoreDir sd) takeFileName linkDir ".." takeFileName (unStoreDir sd) "result" + collapsed <- addOutLinkRoot store dotted top + target <- Dir.getSymbolicLinkTarget expectedLink + recorded <- BS.readFile (autoRootsDir sd indirectRootRecordName expectedLink) + inside <- addOutLinkRoot store insideViaDotDot top + pure $ case (collapsed, inside) of + (Right link, Left insideErr) + | link == expectedLink, + target == storePathToFilePath sd top, + recorded == TE.encodeUtf8 (T.pack link), + "in the Nix store is forbidden" `T.isInfixOf` insideErr -> + Pass + other -> Fail ("wrong outcomes: " <> T.pack (show (other, target, recorded))), + -- upstream's addPermRoot: an existing store link is replaced, + -- anything else at the name is refused, and a link inside + -- the store is refused. + runTestM "addOutLinkRoot replaces a store link and refuses a file or a link inside the store" $ do + let replaceLink = linkDir "replace" + plainFile = linkDir "plain" + Dir.createFileLink (storePathToFilePath sd orphan) replaceLink + replaced <- addOutLinkRoot store replaceLink top + target <- Dir.getSymbolicLinkTarget replaceLink + BS.writeFile plainFile "not a link" + clobber <- addOutLinkRoot store plainFile top + inside <- addOutLinkRoot store (unStoreDir sd "result") top + pure $ case (replaced, clobber, inside) of + (Right _, Left clobberErr, Left insideErr) + | target == storePathToFilePath sd top, + "already exists" `T.isInfixOf` clobberErr, + "in the Nix store is forbidden" `T.isInfixOf` insideErr -> + Pass + other -> Fail ("wrong outcomes: " <> T.pack (show (other, target))) + ] + Dir.removePathForcibly linkDir + pure (permanent ++ linked) + +testStoreOps :: IO [Bool] +testStoreOps = do + putStrLn "store/ops" + withTempStore $ \store -> do + let sd = stDir store + sequence + [ -- computeClosure emits references before referrers (deps-first): + -- phase-2 narinfo publication then never announces a path whose + -- references are not yet visible. The dep is shared by both + -- roots and must precede both. + runTestM "computeClosure orders references first" $ do + let dep = StorePath "llllllllllllllllllllllllllllllll" "cl-dep" + p1 = StorePath "mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm" "cl-p1" + p2 = StorePath "nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn" "cl-p2" + registerPaths + (stDB store) + [ PathRegistration dep "sha256:cd" 1 Nothing [], + PathRegistration p1 "sha256:c1" 2 Nothing [dep], + PathRegistration p2 "sha256:c2" 3 Nothing [dep] + ] + result <- computeClosure store [p1, p2] + pure (assertEqual "closure order" (Right [dep, p1, p2]) result), + -- materializeEvalSources adoption is verified: a partial tree left + -- at the destination by an interrupted restore must be cleared + -- and restored again, never registered as-is. + runTestM "materializeEvalSources restores over a mismatched tree" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-adopt-src" + removeIfExists srcDir + createDirectoryIfMissing True srcDir + TIO.writeFile (srcDir "data.txt") "real content" + entry <- NAR.serialiseFromPath srcDir + case makeFixedOutputPath "nova-nix-test-adopt-src" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let spText = storePathToText defaultStoreDir sp + dest = storePathToFilePath (stDir store) sp + -- Fake an interrupted earlier copy: wrong partial content. + removeIfExists dest + createDirectoryIfMissing True dest + TIO.writeFile (dest "data.txt") "partial garbage" + materializeEvalSources store (Map.fromList [(T.pack srcDir, spText)]) + adopted <- TIO.readFile (dest "data.txt") + registered <- isValid store sp + removeIfExists srcDir + pure $ + if adopted == "real content" && registered + then Pass + else Fail ("expected re-copied content, got: " <> adopted), + -- Evaluation hashes a source well before the build driver + -- restores it. A source edited in between no longer reproduces + -- the address evaluation gave it, so it is refused and nothing + -- is left at the path, rather than its new bytes being sealed + -- and registered under the old address (#235). + runTestM "materializeEvalSources refuses a source changed since evaluation" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-changed-src" + removeIfExists srcDir + createDirectoryIfMissing True srcDir + TIO.writeFile (srcDir "data.txt") "evaluated content" + entry <- NAR.serialiseFromPath srcDir + case makeFixedOutputPath "nova-nix-test-changed-src" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let spText = storePathToText defaultStoreDir sp + dest = storePathToFilePath (stDir store) sp + forceRemoveIfExists dest + TIO.writeFile (srcDir "data.txt") "edited after evaluation" + outcome <- try (materializeEvalSources store (Map.fromList [(T.pack srcDir, spText)])) + registered <- isValid store sp + leftBehind <- Dir.doesPathExist dest + removeIfExists srcDir + pure $ case outcome of + Right () -> Fail "registered a source that changed after evaluation" + Left (e :: IOException) + | not ("changed after evaluation hashed it" `T.isInfixOf` T.pack (ioeGetErrorString e)) -> + Fail ("unexpected refusal: " <> T.pack (show e)) + | registered || leftBehind -> + Fail ("refused, but registered " <> T.pack (show registered) <> ", tree left " <> T.pack (show leftBehind)) + | otherwise -> Pass, + -- The registrar's half of the eval-write pair: content that does + -- not re-derive its store path under the recorded scheme must be + -- refused loudly, never registered valid under a hash its bytes + -- do not have and then sealed read-only. + runTestM "materializeEvalStoreWrites refuses content that does not reproduce its path" $ do + let goodBytes = TE.encodeUtf8 "the full flat content" + case makeFixedOutputPath "flat-verify" "sha256" "flat" (sha256Digest goodBytes) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let spText = storePathToText defaultStoreDir sp + dest = storePathToFilePath (stDir store) sp + removeIfExists dest + BS.writeFile dest (TE.encodeUtf8 "the full") + outcome <- try (materializeEvalStoreWrites store (Map.fromList [(spText, ([], WriteFlat))])) + stillInvalid <- not <$> isValid store sp + removeIfExists dest + pure $ case (outcome :: Either SomeException ()) of + Left _ | stillInvalid -> Pass + Left _ -> Fail "refused but registered anyway" + Right () -> Fail "registered a truncated write as valid", + runTestM "materializeEvalStoreWrites registers content that reproduces its path" $ do + let goodBytes = TE.encodeUtf8 "registered text content" + refs = [] + case makeTextPath "text-verify" (sha256Digest goodBytes) refs of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let spText = storePathToText defaultStoreDir sp + dest = storePathToFilePath (stDir store) sp + removeIfExists dest + BS.writeFile dest goodBytes + materializeEvalStoreWrites store (Map.fromList [(spText, (refs, WriteText))]) + registered <- isValid store sp + pure (assertEqual "registered" True registered), + -- A tree that DOES reproduce its store path is adopted untouched. + -- The source is deleted before the call: adoption never reads it, + -- so a wrongful re-copy attempt throws and fails the test. + runTestM "materializeEvalSources adopts a matching tree untouched" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-adopt-ok" + removeIfExists srcDir + createDirectoryIfMissing True srcDir + TIO.writeFile (srcDir "data.txt") "same bytes" + entry <- NAR.serialiseFromPath srcDir + case makeFixedOutputPath "nova-nix-test-adopt-ok" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let spText = storePathToText defaultStoreDir sp + dest = storePathToFilePath (stDir store) sp + removeIfExists dest + createDirectoryIfMissing True dest + TIO.writeFile (dest "data.txt") "same bytes" + removeIfExists srcDir + materializeEvalSources store (Map.fromList [(T.pack srcDir, spText)]) + registered <- isValid store sp + pure (if registered then Pass else Fail "matching tree was not adopted and registered"), + -- scanReferences finds the canonical /nix/store text eval injects + -- into builder envs, independent of the platform store dir (the + -- bare hash is the needle, matching upstream Nix). + runTestM "scanReferences finds canonical ref" $ do + tmpBase <- getTemporaryDirectory + let scanDir = tmpBase "nova-nix-test-scan" + removeIfExists scanDir + createDirectoryIfMissing True scanDir + let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" + refString = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-dep1" + BS.writeFile (scanDir "output.txt") (TE.encodeUtf8 (T.pack ("hello " <> refString <> " world"))) + refs <- scanReferences [candidate] scanDir + removeIfExists scanDir + pure $ + if candidate `elem` refs + then Pass + else Fail ("expected to find ref, got: " <> T.pack (show refs)), + -- scanReferences finds a Windows-form embedding too + runTestM "scanReferences finds windows-form ref" $ do + tmpBase <- getTemporaryDirectory + let scanDir = tmpBase "nova-nix-test-scan-win" + removeIfExists scanDir + createDirectoryIfMissing True scanDir + let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" + refString = "C:\\nix\\store\\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-dep1" + BS.writeFile (scanDir "output.txt") (TE.encodeUtf8 (T.pack ("exec " <> refString))) + refs <- scanReferences [candidate] scanDir + removeIfExists scanDir + pure $ + if candidate `elem` refs + then Pass + else Fail ("expected to find ref, got: " <> T.pack (show refs)), + -- scanReferences misses non-matching + runTestM "scanReferences misses non-match" $ do + tmpBase <- getTemporaryDirectory + let scanDir = tmpBase "nova-nix-test-scan2" + removeIfExists scanDir + createDirectoryIfMissing True scanDir + let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" + BS.writeFile (scanDir "output.txt") "no store paths here" + refs <- scanReferences [candidate] scanDir + removeIfExists scanDir + pure (assertEqual "no refs" [] refs), + -- scanReferences ignores partial match + runTestM "scanReferences ignores partial" $ do + tmpBase <- getTemporaryDirectory + let scanDir = tmpBase "nova-nix-test-scan3" + removeIfExists scanDir + createDirectoryIfMissing True scanDir + let candidate = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "dep1" + -- Only 20 chars of hash - should not match the 32-char needle + partialRef = "/nix/store/aaaaaaaaaaaaaaaaaaaa" + BS.writeFile (scanDir "output.txt") (TE.encodeUtf8 (T.pack partialRef)) + refs <- scanReferences [candidate] scanDir + removeIfExists scanDir + pure (assertEqual "no partial refs" [] refs), + runTestM "rewriteBytes agrees with a substring replacement model" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} $ + QC.forAll (QC.listOf (QC.elements [97, 98, 99])) $ \bytes -> + let input = BS.pack bytes + model = T.replace "bc" "aa" (T.replace "ab" "cc" (TE.decodeUtf8 input)) + in TE.decodeUtf8 (rewriteBytes [("ab", "cc"), ("bc", "aa")] input) QC.=== model + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))), + runTest "rewriteBytes leaves bytes alone when nothing matches" $ + assertEqual "no match" "clean bytes" (rewriteBytes [("zz", "yy")] "clean bytes"), + runTest "rewriteBytes ignores an empty needle" $ + assertEqual "empty needle" "bytes" (rewriteBytes [("", "x")] "bytes"), + runTestM "rewriteStoreHashes reaches contents, entry names and read-only files" $ do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-rewrite-tree" + forceRemoveIfExists dir + createDirectoryIfMissing True (dir "sub") + BS.writeFile (dir "sub" "file") "path /nix/store/aaaa-dep/bin" + BS.writeFile (dir "clean") "nothing here" + BS.writeFile (dir "aaaa-named") "x" + readOnly <- Dir.getPermissions (dir "sub" "file") + Dir.setPermissions (dir "sub" "file") (Dir.setOwnerWritable False readOnly) + rewriteStoreHashes [("aaaa", "bbbb")] dir + contents <- BS.readFile (dir "sub" "file") + stillReadOnly <- not . Dir.writable <$> Dir.getPermissions (dir "sub" "file") + renamed <- Dir.doesFileExist (dir "bbbb-named") + oldName <- Dir.doesFileExist (dir "aaaa-named") + forceRemoveIfExists dir + pure (assertEqual "rewrite" ("path /nix/store/bbbb-dep/bin", True, True, False) (contents, stillReadOnly, renamed, oldName)), + runTestM "rewriteStoreHashes reaches a directory named for a hash" $ do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-rewrite-named-dir" + forceRemoveIfExists dir + createDirectoryIfMissing True (dir "aaaa-sub") + BS.writeFile (dir "aaaa-sub" "file") "see aaaa" + rewriteStoreHashes [("aaaa", "bbbb")] dir + contents <- BS.readFile (dir "bbbb-sub" "file") + forceRemoveIfExists dir + pure (assertEqual "nested contents" "see bbbb" contents), + runTestM "rewriteStoreHashes refuses to overwrite an entry" $ do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-rewrite-collision" + forceRemoveIfExists dir + createDirectoryIfMissing True dir + BS.writeFile (dir "aaaa-x") "scratch" + BS.writeFile (dir "bbbb-x") "final" + outcome <- try (rewriteStoreHashes [("aaaa", "bbbb")] dir) + survivor <- BS.readFile (dir "bbbb-x") + forceRemoveIfExists dir + pure $ case (outcome :: Either IOException (), survivor) of + (Left _, "final") -> Pass + other -> Fail (T.pack (show other)), + runTestM "scanReferences finds a hash held only in an entry name" $ do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-scan-entry-name" + candidate = StorePath "cccccccccccccccccccccccccccccccc" "dep" + forceRemoveIfExists dir + createDirectoryIfMissing True (dir "share") + BS.writeFile (dir "share" "cccccccccccccccccccccccccccccccc-dep") "" + refs <- scanReferences [candidate] dir + forceRemoveIfExists dir + pure (assertEqual "entry name" [candidate] refs), + -- A relative target: Windows normalises the separators of a rooted one. + runTestM "rewriteStoreHashes rewrites a symlink target, in a read-only directory too" $ do + canLink <- symlinksAvailable + if not canLink + then pure Pass + else do + tmpBase <- getTemporaryDirectory + let dir = tmpBase "nova-nix-test-rewrite-link" + forceRemoveIfExists dir + createDirectoryIfMissing True (dir "sub") + Dir.createFileLink "aaaa-dep" (dir "sub" "link") + frozen <- Dir.getPermissions (dir "sub") + Dir.setPermissions (dir "sub") (Dir.setOwnerWritable False frozen) + outcome <- try (rewriteStoreHashes [("aaaa", "bbbb")] dir) + target <- Dir.getSymbolicLinkTarget (dir "sub" "link") + Dir.setPermissions (dir "sub") (Dir.setOwnerWritable True frozen) + forceRemoveIfExists dir + pure $ case outcome :: Either IOException () of + Left err -> Fail (T.pack (show err)) + Right () -> assertEqual "link target" "bbbb-dep" target, + -- addToStore moves dir + registers in DB + runTestM "addToStore moves + registers" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-add-src" + removeIfExists srcDir + createDirectoryIfMissing True srcDir + writeFile (srcDir "hello.txt") "hello world" + let sp = StorePath "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" "addtest" + addToStore store srcDir sp Nothing [] + valid <- isValid store sp + exists <- pathExists store sp + pure $ + if valid && exists + then Pass + else Fail ("valid=" <> T.pack (show valid) <> " exists=" <> T.pack (show exists)), + -- addToStore sets read-only + runTestM "addToStore sets read-only" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-add-ro" + removeIfExists srcDir + createDirectoryIfMissing True srcDir + writeFile (srcDir "data.txt") "data" + let sp = StorePath "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy" "rotest" + addToStore store srcDir sp Nothing [] + let destFile = storePathToFilePath sd sp "data.txt" + perms <- getPermissions destFile + pure $ + if not (writable perms) + then Pass + else Fail "expected read-only but file is writable", + -- setReadOnly works on a plain directory + runTestM "setReadOnly makes dir read-only" $ do + tmpBase <- getTemporaryDirectory + let roDir = tmpBase "nova-nix-test-readonly" + removeIfExists roDir + createDirectoryIfMissing True roDir + writeFile (roDir "f.txt") "content" + setReadOnly roDir + dirPerms <- getPermissions roDir + filePerms <- getPermissions (roDir "f.txt") + -- Cleanup: restore writable so removeIfExists works + Dir.setPermissions roDir (Dir.setOwnerWritable True dirPerms) + Dir.setPermissions (roDir "f.txt") (Dir.setOwnerWritable True filePerms) + removeIfExists roDir + pure $ + if not (writable dirPerms) && not (writable filePerms) + then Pass + else + Fail + ( "dir writable=" + <> T.pack (show (writable dirPerms)) + <> " file writable=" + <> T.pack (show (writable filePerms)) + ), + -- pathExists true after addToStore + runTestM "pathExists after addToStore" $ do + tmpBase <- getTemporaryDirectory + let srcDir = tmpBase "nova-nix-test-exists" + removeIfExists srcDir + createDirectoryIfMissing True srcDir + writeFile (srcDir "x.txt") "x" + let sp = StorePath "wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww" "existstest" + addToStore store srcDir sp Nothing [] + exists <- pathExists store sp + pure (assertEqual "exists" True exists) + ] + +-- | Store walks treat a symlink as a leaf. Each fixture plants a link +-- the walk must not follow - out of the tree or back into it (a cycle) - +-- and asserts the walk neither reads nor mutates through the link, and +-- still terminates. +testSymlinkWalksIO :: IO [Bool] +testSymlinkWalksIO = do + putStrLn "store/symlink-walks" + canLink <- symlinksAvailable + if not canLink + then do + putStrLn " SKIP cannot create symlinks here (Windows needs Developer Mode or elevation)" + pure [] + else + sequence + [ -- A link out of the tree must not have the read-only bit + -- pushed through to its target. + runTestM "setReadOnly does not mark link targets outside the tree" $ do + tmpBase <- getTemporaryDirectory + let base = tmpBase "nova-nix-test-ro-links" + outside = base "outside" + tree = base "tree" + Dir.removePathForcibly base + createDirectoryIfMissing True outside + createDirectoryIfMissing True tree + BS.writeFile (outside "victim.txt") "victim" + BS.writeFile (tree "inside.txt") "inside" + Dir.createFileLink (outside "victim.txt") (tree "file-link") + Dir.createDirectoryLink outside (tree "dir-link") + setReadOnly tree + victimWritable <- writable <$> getPermissions (outside "victim.txt") + insideWritable <- writable <$> getPermissions (tree "inside.txt") + Dir.removePathForcibly base + pure $ + if victimWritable && not insideWritable + then Pass + else + Fail + ( "victim writable=" + <> T.pack (show victimWritable) + <> " inside writable=" + <> T.pack (show insideWritable) + ), + -- A link cycle must not recurse the walk forever. + runTestM "setReadOnly terminates on a link cycle" $ do + tmpBase <- getTemporaryDirectory + let tree = tmpBase "nova-nix-test-ro-cycle" + Dir.removePathForcibly tree + createDirectoryIfMissing True (tree "sub") + BS.writeFile (tree "sub" "f.txt") "f" + Dir.createDirectoryLink tree (tree "sub" "loop") + outcome <- timeout walkWatchdogMicros (setReadOnly tree) + marked <- writable <$> getPermissions (tree "sub" "f.txt") + Dir.removePathForcibly tree + pure $ case outcome of + Nothing -> Fail "walk did not terminate on a link cycle" + Just () + | marked -> Fail "regular file next to the cycle link was not marked read-only" + | otherwise -> Pass, + -- The reference scan reads a link's TARGET STRING (the NAR + -- carries it) and never the bytes behind the link. + runTestM "scanReferences scans link targets, not linked bytes" $ do + tmpBase <- getTemporaryDirectory + let base = tmpBase "nova-nix-test-scan-links" + outside = base "outside" + scanDir = base "tree" + inTargetHash = T.replicate 32 "a" + outsideHash = T.replicate 32 "b" + inTarget = StorePath inTargetHash "dep1" + outsideOnly = StorePath outsideHash "dep2" + Dir.removePathForcibly base + createDirectoryIfMissing True outside + createDirectoryIfMissing True scanDir + -- outsideOnly's hash exists only in file bytes OUTSIDE the + -- tree, reachable through a link; inTarget's exists only in + -- a link's target string. + BS.writeFile + (outside "secret.txt") + (TE.encodeUtf8 ("/nix/store/" <> outsideHash <> "-dep2")) + Dir.createFileLink (outside "secret.txt") (scanDir "spy-link") + Dir.createFileLink + ("/nix/store/" <> T.unpack inTargetHash <> "-dep1/bin/tool") + (scanDir "dep-link") + Dir.createDirectoryLink scanDir (scanDir "loop") + found <- timeout walkWatchdogMicros (scanReferences [inTarget, outsideOnly] scanDir) + Dir.removePathForcibly base + pure $ case found of + Nothing -> Fail "scan did not terminate on a link cycle" + Just refs -> assertEqual "scanned refs" [inTarget] refs, + -- copyPathInto replicates every link kind, so the NAR bytes - + -- and the hash a cache signs - are identical whether an output + -- was renamed or copied across volumes. + runTestM "copyPathInto replicates links and preserves NAR bytes" $ do + tmpBase <- getTemporaryDirectory + let base = tmpBase "nova-nix-test-copy-links" + src = base "src" + dest = base "dest" + Dir.removePathForcibly base + createDirectoryIfMissing True (src "subdir") + BS.writeFile (src "file.txt") "payload" + BS.writeFile (src "subdir" "inner.txt") "inner" + Dir.createFileLink "file.txt" (src "rel-link") + Dir.createDirectoryLink "subdir" (src "dir-link") + Dir.createFileLink "missing.txt" (src "dangling") + copyPathInto src dest + relIsLink <- Dir.pathIsSymbolicLink (dest "rel-link") + relTarget <- Dir.getSymbolicLinkTarget (dest "rel-link") + dirIsLink <- Dir.pathIsSymbolicLink (dest "dir-link") + danglingIsLink <- Dir.pathIsSymbolicLink (dest "dangling") + srcNarHash <- CHash.formatNixHash . CHash.hashBytes . NAR.serialise <$> NAR.serialiseFromPath src + destNarHash <- CHash.formatNixHash . CHash.hashBytes . NAR.serialise <$> NAR.serialiseFromPath dest + Dir.removePathForcibly base + pure $ + if relIsLink && dirIsLink && danglingIsLink && relTarget == "file.txt" + then assertEqual "copied NAR hash" srcNarHash destNarHash + else + Fail + ( "rel-link/dir-link/dangling as links: " + <> T.pack (show (relIsLink, dirIsLink, danglingIsLink)) + <> ", rel target: " + <> T.pack (show relTarget) + ) + ] + +-- | Pure ordering for the store's symlink second pass: each link +-- follows the pending links its target resolves at or through, and +-- cycle members fall out at the end in input order. +testLinkOrdering :: IO [Bool] +testLinkOrdering = do + putStrLn "store/link-ordering" + let root = "out" + -- The fixtures are ASCII: one path unit per character, both ways, + -- on every platform. + osPath = OP.pack . map OP.unsafeFromChar + fromOsPath = map OP.toChar . OP.unpack + orderedLinks pending = map (fromOsPath . fst) (orderLinks [(osPath link, osPath target) | (link, target) <- pending]) + sequence + [ runTest "chain orders targets first" $ + let pending = [(root "l1", "l2"), (root "l2", "l3"), (root "l3", "real")] + in assertEqual + "chain" + [root "l3", root "l2", root "l1"] + (orderedLinks pending), + runTest "already-ordered chain is stable" $ + let pending = [(root "l3", "real"), (root "l2", "l3"), (root "l1", "l2")] + in assertEqual + "stable" + [root "l3", root "l2", root "l1"] + (orderedLinks pending), + runTest "link through a linked directory follows it" $ + let pending = [(root "a", "dirlink/x"), (root "dirlink", "realdir")] + in assertEqual + "through-dir" + [root "dirlink", root "a"] + (orderedLinks pending), + runTest "parent-relative target orders after its link" $ + let pending = [(root "sub" "l", "../other"), (root "other", "real")] + in assertEqual + "dotdot" + [root "other", root "sub" "l"] + (orderedLinks pending), + runTest "cycle members keep input order at the end" $ + let pending = [(root "a", "b"), (root "b", "a"), (root "c", "real")] + in assertEqual + "cycle" + [root "c", root "a", root "b"] + (orderedLinks pending), + runTest "self-target link survives to the fallback" $ + assertEqual + "self" + [root "x"] + (orderedLinks [(root "x", "x")]), + runTestM "long chain orders in linear time" $ do + -- 20000 links each targeting the next: the ready-set rounds + -- this replaced were quadratic here. + let chain = + [ (root ("l" <> show i), "l" <> show (i + 1)) + | i <- [1 :: Int .. 20000] + ] + ++ [(root "l20001", "real")] + complete = length (orderedLinks chain) == length chain + outcome <- timeout walkWatchdogMicros (evaluate complete) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "ordering dropped links" + Nothing -> Fail "ordering did not return promptly" + ] + +-- --------------------------------------------------------------------------- +-- Tests: fromATerm + Derivation Output Population (Phase 2, Batch 3) +-- --------------------------------------------------------------------------- + +-- | A simple test derivation for round-trip testing. +simpleTestDrv :: Derivation +simpleTestDrv = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "hello-1.0", + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/nix/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-bash-5.2/bin/bash", + drvArgs = ["-e", "/nix/store/cccccccccccccccccccccccccccccccc-stdenv/setup"], + drvEnv = Map.fromList [("name", "hello-1.0"), ("system", "x86_64-linux")] + } + +-- | A complex test derivation with multiple outputs, input drvs, and input srcs. +complexTestDrv :: Derivation +complexTestDrv = + Derivation + { drvOutputs = + [ DerivationOutput "dev" (StorePath "dddddddddddddddddddddddddddddddd" "pkg-2.0-dev") "" "", + DerivationOutput "out" (StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "pkg-2.0") "" "" + ], + drvInputDrvs = + Map.fromList + -- Hash fixtures stay inside the nix-base32 alphabet (no e o u t): + -- fromATerm parses these through parseStorePath, which now + -- charset-checks the hash component. + [ (StorePath "cccccccccccccccccccccccccccccccc" "dep1.drv", ["out"]), + (StorePath "ffffffffffffffffffffffffffffffff" "dep2.drv", ["lib", "out"]) + ], + drvInputSrcs = [StorePath "gggggggggggggggggggggggggggggggg" "source.tar.gz"], + drvPlatform = Aarch64_Darwin, + drvBuilder = "/nix/store/hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh-bash/bin/bash", + drvArgs = ["-e", "build.sh"], + drvEnv = + Map.fromList + [ ("buildInputs", "/nix/store/cccccccccccccccccccccccccccccccc-dep1"), + ("name", "pkg-2.0"), + ("out", "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-pkg-2.0"), + ("system", "aarch64-darwin") + ] + } + +testFromATerm :: IO [Bool] +testFromATerm = do + putStrLn "derivation/fromATerm" + sequence + [ -- Round-trip: simple derivation + runTest "fromATerm round-trip simple" $ + assertEqual "simple round-trip" (Right simpleTestDrv) (fromATerm (toATerm simpleTestDrv)), + -- Round-trip: complex derivation + runTest "fromATerm round-trip complex" $ + assertEqual "complex round-trip" (Right complexTestDrv) (fromATerm (toATerm complexTestDrv)), + -- A .drv read from disk is input: an output name that violates the + -- store-name rules (here a traversal shape that would later join + -- the build dir) must refuse at parse. + runTest "fromATerm rejects a traversal-shaped output name" $ + let evil = + simpleTestDrv + { drvOutputs = + [DerivationOutput "../evil" (StorePath (T.replicate 32 "a") "pkg") "" ""] + } + in case fromATerm (toATerm evil) of + Left _ -> Pass + Right _ -> Fail "parsed a drv with a traversal output name", + -- drv4: the modulo-substitution section merges input-drv entries that + -- share a modulo-hash key, unioning their output-name sets, so it is + -- byte-identical to the already-merged form. (Just subs replaces the + -- whole input-drv section, so simpleTestDrv's own inputs are irrelevant.) + runTest "inputDrvsSubst merges equal modulo keys" $ + assertEqual + "subst-merge" + (toATermForHash False (Just [("00000000", ["dev", "out"])]) simpleTestDrv) + (toATermForHash False (Just [("00000000", ["out"]), ("00000000", ["dev"])]) simpleTestDrv), + runTest "inputDrvsSubst unions and dedups merged out-names" $ + assertEqual + "subst-union" + (toATermForHash False (Just [("aabbccdd", ["dev", "out"])]) simpleTestDrv) + (toATermForHash False (Just [("aabbccdd", ["out"]), ("aabbccdd", ["out", "dev"])]) simpleTestDrv), + -- Distinct keys are untouched: still one entry each, ascending by key. + runTest "inputDrvsSubst preserves distinct keys in order" $ + assertEqual + "subst-distinct" + (toATermForHash False (Just [("00000000", ["out"]), ("11111111", ["out"])]) simpleTestDrv) + (toATermForHash False (Just [("11111111", ["out"]), ("00000000", ["out"])]) simpleTestDrv), + -- Round-trip: empty derivation (no outputs, no inputs, no args, no env) + runTest "fromATerm round-trip empty" $ + let emptyDrv = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/true", + drvArgs = [], + drvEnv = Map.empty + } + in assertEqual "empty round-trip" (Right emptyDrv) (fromATerm (toATerm emptyDrv)), + -- Reject empty string + runTest "fromATerm rejects empty" $ + assertLeft "empty" (fromATerm ""), + -- Reject malformed + runTest "fromATerm rejects malformed" $ + assertLeft "malformed" (fromATerm "NotADerivation"), + -- Reject truncated + runTest "fromATerm rejects truncated" $ + assertLeft "truncated" (fromATerm "Derive(["), + -- Escaping round-trip: strings with special chars + runTest "fromATerm escaping round-trip" $ + let escapeDrv = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "esc-test", + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = X86_64_Linux, + drvBuilder = "/bin/bash", + drvArgs = ["-c", "echo \"hello\nworld\""], + drvEnv = Map.fromList [("msg", "line1\nline2\ttab\\slash")] + } + in assertEqual "escape round-trip" (Right escapeDrv) (fromATerm (toATerm escapeDrv)), + -- A non-standard escape keeps the byte and drops the backslash, + -- matching upstream's .drv string parser. + runTest "fromATerm drops the backslash on a non-standard escape" $ + let aterm = "Derive([(\"out\",\"/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x\",\"\",\"\")],[],[],\"x86_64-linux\",\"/bin/sh\",[],[(\"k\",\"a\\xb\")])" + in assertRight "nonstandard escape" (fromATerm aterm) $ \drv -> + assertEqual "escape dropped" (Just "axb") (Map.lookup "k" (drvEnv drv)), + -- writeDrv writes correct ATerm + runTestM "writeDrv writes correct ATerm" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-writeDrv" + removeIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let sp = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" "test.drv" + destFile = storePathToFilePath (stDir store) sp + writeDrv store simpleTestDrv sp + contents <- BS.readFile destFile + closeStore store + removeIfExists tmpStore + pure (assertEqual "writeDrv content" (toATerm simpleTestDrv) contents), + -- The .drv closure registers as store objects: a row for every + -- recipe plus edges to its input sources and input .drvs, so an + -- output reference scan that names an input .drv resolves instead + -- of failing the registration batch. + runTestM "writeDrvClosure registers recipes with their references" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-drv-closure" + sd = StoreDir tmpStore + removeIfExists tmpStore + store <- openStore sd + let srcSp = StorePath "gggggggggggggggggggggggggggggggg" "source.tar.gz" + drvASp = StorePath "cccccccccccccccccccccccccccccccc" "dep1.drv" + drvBSp = StorePath "dddddddddddddddddddddddddddddddd" "top.drv" + drvB = + simpleTestDrv + { drvInputDrvs = Map.fromList [(drvASp, ["out"])], + drvInputSrcs = [srcSp] + } + -- The source row registers first, as in the build driver, where + -- materializeEvalSources precedes the closure write. + registerPath (stDB store) (PathRegistration srcSp "sha256:0" 0 Nothing []) + writeDrvClosure + store + ( Map.fromList + [ (storePathToText defaultStoreDir drvASp, toATerm simpleTestDrv), + (storePathToText defaultStoreDir drvBSp, toATerm drvB) + ] + ) + validA <- isValid store drvASp + validB <- isValid store drvBSp + refsB <- queryReferences (stDB store) drvBSp + closeStore store + removeIfExists tmpStore + let expectedRefs = + sort + [ T.pack (storePathToFilePath sd drvASp), + T.pack (storePathToFilePath sd srcSp) + ] + pure $ + if not validA + then Fail "input .drv not registered" + else + if not validB + then Fail "root .drv not registered" + else assertEqual "drv references" expectedRefs (sort refsB), + -- The recorded derivation populates drvOutputs. These three read the + -- Derivation the session records, which only the IO evaluator keeps. + runTestM "derivationStrict populates drvOutputs" $ do + tmpBase <- getTemporaryDirectory + result <- evalDerivationIO tmpBase "derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }" + pure $ assertRight "drvOutputs" result $ \drv -> + case drvOutputs drv of + [] -> Fail "drvOutputs is empty" + (firstOut : _) -> + if doName firstOut == "out" + then Pass + else Fail ("first output name: " <> doName firstOut), + -- The .drv lists outputs sorted by name, as upstream writes them; the + -- declared order lives in the value's outputs and all. + runTestM "derivationStrict multi-output" $ do + tmpBase <- getTemporaryDirectory + result <- evalDerivationIO tmpBase "derivation { name = \"multi\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [\"out\" \"dev\"]; }" + pure $ assertRight "multi-output" result $ \drv -> + let names = map doName (drvOutputs drv) + in if names == ["dev", "out"] + then Pass + else Fail ("output names: " <> T.pack (show names)), + -- The .drv env carries the output paths ($out, ...) and the build + -- attributes, and no "drvPath" key - matching C++ Nix, which never + -- writes one. + runTestM "derivationStrict populates drvEnv" $ do + tmpBase <- getTemporaryDirectory + result <- evalDerivationIO tmpBase "derivation { name = \"test\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }" + pure $ assertRight "drvEnv" result $ \drv -> + case (Map.lookup "out" (drvEnv drv), Map.lookup "name" (drvEnv drv)) of + (Just op, Just "test") + | "/nix/store/" `BS.isPrefixOf` op -> Pass + _ -> Fail ("drvEnv keys: " <> T.pack (show (Map.toList (drvEnv drv)))) + ] + +-- --------------------------------------------------------------------------- +-- Tests: Builder (Phase 2, Batch 4) +-- --------------------------------------------------------------------------- + +-- | The @.drv@ path a builder test hands 'buildDerivation'. Only a failure +-- message that names the derivation reads it. +testDrvPath :: StorePath +testDrvPath = StorePath (T.replicate 32 "d") "test-build.drv" + +-- | Create a minimal Derivation for builder tests. +-- The shell path is discovered once via 'findTestShell' and threaded through. +-- All scripts are POSIX shell - bash is used on every platform. +mkTestBuildDrv :: Text -> StorePath -> Text -> Derivation +mkTestBuildDrv shell outSP script = + Derivation + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = outSP, + doHashAlgo = "", + doHash = "" + } + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", TE.encodeUtf8 script], + drvEnv = Map.fromList [("name", "test-build"), ("system", TE.encodeUtf8 (platformToText currentPlatform))] + } + +-- | 'mkTestBuildDrv' with a fixed-output spec: registration must +-- re-verify the placed bytes against the declared digest. +mkFixedOutputDrv :: Text -> StorePath -> Text -> Text -> Text -> Derivation +mkFixedOutputDrv shell outSP script algoField hexDigest = + (mkTestBuildDrv shell outSP script) + { drvOutputs = + [ DerivationOutput + { doName = "out", + doPath = outSP, + doHashAlgo = algoField, + doHash = hexDigest + } + ] + } + +testBuilder :: IO [Bool] +testBuilder = do + putStrLn "builder" + shell <- findTestShell + sequence + [ -- Build simple script that writes to $out + runTestM "build simple script" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder1" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa1" "simple-test" + drv = mkTestBuildDrv shell outSP "mkdir -p $out && echo hello > $out/result.txt" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder1-tmp"} + result <- buildDerivation config store drv testDrvPath + closeStore store + let ret = case result of + BuildSuccess sp -> assertEqual "success path" outSP sp + BuildFailure msg code -> Fail ("build failed (" <> T.pack (show code) <> "): " <> msg) + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + -- Build with specific file content + runTestM "build writes file content" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder2" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" "content-test" + drv = mkTestBuildDrv shell outSP "mkdir -p $out && echo 'test content 42' > $out/data.txt" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder2-tmp"} + result <- buildDerivation config store drv testDrvPath + ret <- case result of + BuildSuccess _ -> do + let dataFile = storePathToFilePath (stDir store) outSP "data.txt" + content <- TIO.readFile dataFile + pure $ + if T.strip content == "test content 42" + then Pass + else Fail ("unexpected content: " <> content) + BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + -- Missing builder fails + runTestM "missing builder fails" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder3" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "cccccccccccccccccccccccccccccccc" "fail-test" + drv = + Derivation + { drvOutputs = [DerivationOutput "out" outSP "" ""], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = "/nonexistent/builder", + drvArgs = [], + drvEnv = Map.empty + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder3-tmp"} + result <- buildDerivation config store drv testDrvPath + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure _ _ -> Pass + BuildSuccess _ -> Fail "expected failure for missing builder", + -- Exit failure returns error code + runTestM "exit failure returns error code" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder4" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "dddddddddddddddddddddddddddddddd" "exitfail" + drv = mkTestBuildDrv shell outSP "exit 42" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder4-tmp"} + result <- buildDerivation config store drv testDrvPath + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure _ code -> if code == 42 then Pass else Fail ("expected code 42, got " <> T.pack (show code)) + BuildSuccess _ -> Fail "expected failure", + -- A builder that THROWS (nonexistent executable) must not leak the + -- deterministic build dir: stale contents would fake an archive + -- collision on the next builtin:unpack run of the same drv. + runTestM "crashed build removes its build dir" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-leak" + tmpBuild = tmpBase "nova-nix-test-builder-leak-tmp" + forceRemoveIfExists tmpStore + forceRemoveIfExists tmpBuild + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "pppppppppppppppppppppppppppppppp" "leaktest" + drv = mkTestBuildDrv (T.pack (tmpBase "no-such-builder.exe")) outSP "unused" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBuild} + result <- buildDerivation config store drv testDrvPath + leftovers <- do + exists <- doesDirectoryExist tmpBuild + if exists then Dir.listDirectory tmpBuild else pure [] + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists tmpBuild + pure $ case result of + BuildFailure _ _ + | null leftovers -> Pass + | otherwise -> Fail ("build dir leaked: " <> T.pack (show leftovers)) + BuildSuccess _ -> Fail "expected failure for a nonexistent builder", + -- A derivation carrying __json is built as upstream builds one: its + -- attributes, outputs included, arrive as .attrs.json and .attrs.sh + -- and none of them as a variable. The builder copies both files + -- out, finding $out where a structured builder must, in the files. + runTestM "structured attributes reach the builder as .attrs.json and .attrs.sh" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-structured" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "ssssssssssssssssssssssssssssssss" "structured" + outText = T.pack (storePathToFilePath (stDir store) outSP) + attrs = + "{\"greeting\":\"it's\",\"list\":[\"a\",1,true,null],\"nested\":{\"k\":\"v\"},\"outputs\":[\"out\"],\"self\":\"" + <> hashPlaceholder "out" + <> "/bin\"}" + script = + T.unlines + [ "probe=\"${out-unset}|${__json-unset}|${greeting-unset}\"", + "out=$(sed -n \"/^declare -A outputs=/s/.*\\['out'\\]='\\([^']*\\)'.*/\\1/p\" \"$NIX_ATTRS_SH_FILE\")", + "mkdir \"$out\" && cp \"$NIX_ATTRS_JSON_FILE\" \"$out/attrs.json\" && cp \"$NIX_ATTRS_SH_FILE\" \"$out/attrs.sh\" && printf '%s' \"$probe\" > \"$out/env\"" + ] + drv = + (mkTestBuildDrv shell outSP script) + { drvEnv = Map.fromList [("__json", TE.encodeUtf8 attrs), ("out", "/nix/store/ssssssssssssssssssssssssssssssss-structured")] + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-structured-tmp"} + jsonPath = "\"" <> T.replace "\\" "\\\\" outText <> "\"" + expectedJson = + "{\"greeting\":\"it's\",\"list\":[\"a\",1,true,null],\"nested\":{\"k\":\"v\"},\"outputs\":{\"out\":" + <> jsonPath + <> "},\"self\":" + <> T.dropEnd 1 jsonPath + <> "/bin\"}" + expectedShell = + T.concat + [ "declare greeting='it'\\''s'\n", + "declare -a list=('a' 1 1 '' )\n", + "declare -A nested=(['k']='v' )\n", + "declare -A outputs=(['out']='" <> outText <> "' )\n", + "declare self='" <> outText <> "/bin'\n" + ] + result <- buildDerivation config store drv testDrvPath + ret <- case result of + BuildSuccess _ -> do + let outDir = storePathToFilePath (stDir store) outSP + json <- BS.readFile (outDir "attrs.json") + shellText <- BS.readFile (outDir "attrs.sh") + probe <- BS.readFile (outDir "env") + pure $ + assertEqual "attrs.json" (TE.encodeUtf8 expectedJson) json + `andThen` assertEqual "attrs.sh" (TE.encodeUtf8 expectedShell) shellText + `andThen` assertEqual "no attribute is a variable" "unset|unset|unset" probe + BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + -- An attribute passAsFile names arrives as upstream's file in the + -- build directory, named by fooPath: its store path and placeholder + -- rewritten as a variable's would be, its other bytes as they are, + -- invalid UTF-8 included. Neither it nor a name with no attribute + -- behind it is a variable. + runTestM "passAsFile attributes reach the builder as files in the build directory" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-passasfile" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "gggggggggggggggggggggggggggggggg" "passasfile" + outDir = storePathToFilePath (stDir store) outSP + dep = "/dddddddddddddddddddddddddddddddd-dep" + value = "\xff " <> TE.encodeUtf8 ("/nix/store" <> dep <> " " <> hashPlaceholder "out") + expected = "\xff " <> TE.encodeUtf8 (T.pack (unStoreDir (stDir store)) <> dep <> " " <> T.pack outDir) + script = "mkdir \"$out\" && cp \"$fooPath\" \"$out/foo\" && printf '%s|%s|%s' \"${foo-unset}\" \"${missingPath-unset}\" \"$fooPath\" > \"$out/env\"" + base = mkTestBuildDrv shell outSP script + drv = base {drvEnv = Map.union (Map.fromList [("foo", value), ("passAsFile", "foo missing")]) (drvEnv base)} + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-passasfile-tmp"} + fooFile = bcTmpDir config T.unpack (spHash outSP) ".attr-1bp7cri8hplaz6hbz0v4f0nl44rl84q1sg25kgwqzipzd1mv89ic" + result <- buildDerivation config store drv testDrvPath + ret <- case result of + BuildSuccess _ -> do + contents <- BS.readFile (outDir "foo") + probe <- BS.readFile (outDir "env") + pure $ + assertEqual "file contents" expected contents + `andThen` assertEqual "variables" (TE.encodeUtf8 ("unset|unset|" <> T.pack fooFile)) probe + BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + -- Output at expected path + runTestM "output at expected store path" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder5" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "cccccccccccccccccccccccccccccccc" "pathtest" + drv = mkTestBuildDrv shell outSP "mkdir -p $out && touch $out/marker" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder5-tmp"} + result <- buildDerivation config store drv testDrvPath + ret <- case result of + BuildSuccess _ -> do + let expectedDir = storePathToFilePath (stDir store) outSP + exists <- doesDirectoryExist expectedDir + pure $ if exists then Pass else Fail "output dir doesn't exist at expected path" + BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + -- A leftover tree at the output path that is NOT valid in the DB has + -- unknowable integrity (interrupted earlier run); the build replaces + -- it with the fresh output - upstream's delete-then-move - clearing + -- read-only marks rather than adopting stale bytes. + runTestM "stale leftover output is replaced by the fresh build" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-stale" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq" "staletest" + drv = mkTestBuildDrv shell outSP "mkdir -p $out && echo fresh > $out/data.txt" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-stale-tmp"} + targetPath = storePathToFilePath (stDir store) outSP + -- Fake the interrupted run: stale read-only content at the output's + -- store location, never registered. + createDirectoryIfMissing True targetPath + TIO.writeFile (targetPath "data.txt") "stale" + setReadOnly targetPath + result <- buildDerivation config store drv testDrvPath + content <- TIO.readFile (targetPath "data.txt") + registered <- isValid store outSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildSuccess _ + | T.strip content == "fresh" && registered -> Pass + | otherwise -> Fail ("expected fresh registered content, got: " <> content) + BuildFailure msg code -> Fail ("build failed (" <> T.pack (show code) <> "): " <> msg), + -- Path registered in DB after build + runTestM "path registered in DB" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder6" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "ffffffffffffffffffffffffffffffff" "dbtest" + drv = mkTestBuildDrv shell outSP "mkdir -p $out && touch $out/file" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder6-tmp"} + result <- buildDerivation config store drv testDrvPath + ret <- case result of + BuildSuccess _ -> do + valid <- isValid store outSP + pure $ if valid then Pass else Fail "path not valid in DB after build" + BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + -- Multiple outputs + runTestM "multiple outputs" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder7" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "ggggggggggggggggggggggggggggggg1" "multi" + devSP = StorePath "ggggggggggggggggggggggggggggggg2" "multi-dev" + drv = + Derivation + { drvOutputs = + [ DerivationOutput "out" outSP "" "", + DerivationOutput "dev" devSP "" "" + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", "mkdir -p $out && echo lib > $out/lib.txt && mkdir -p $dev && echo headers > $dev/include.h"], + drvEnv = Map.fromList [("name", "multi")] + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder7-tmp"} + result <- buildDerivation config store drv testDrvPath + ret <- case result of + BuildSuccess _ -> do + outExists <- doesDirectoryExist (storePathToFilePath (stDir store) outSP) + devExists <- doesDirectoryExist (storePathToFilePath (stDir store) devSP) + pure $ + if outExists && devExists + then Pass + else Fail ("out exists=" <> T.pack (show outExists) <> " dev exists=" <> T.pack (show devExists)) + BuildFailure msg code -> pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure ret, + runTestM "partial rebuild failure preserves a valid sibling output" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-partial-valid" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "ggggggggggggggggggggggggggggggg3" "partial-main" + devSP = StorePath "ggggggggggggggggggggggggggggggg4" "partial-dev" + mkDrv script = + Derivation + { drvOutputs = + [ DerivationOutput "out" outSP "" "", + DerivationOutput "dev" devSP "" "" + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", script], + drvEnv = Map.fromList [("name", "partial-valid")] + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-partial-valid-tmp"} + devPath = storePathToFilePath (stDir store) devSP + initial <- buildDerivation config store (mkDrv "mkdir -p $out $dev && echo main > $out/value && echo keep > $dev/value") testDrvPath + deleted <- deleteStorePathRaw store (spHash outSP <> "-" <> spName outSP) + rebuilt <- buildDerivation config store (mkDrv "mkdir -p $out && echo partial > $out/value && exit 1") testDrvPath + devOnDisk <- Dir.doesPathExist devPath + devValid <- isValid store devSP + devContents <- if devOnDisk then T.strip <$> TIO.readFile (devPath "value") else pure "" + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + let deletedFirst = either (const False) (\outcome -> doRowRemoved outcome && doTreeRemoved outcome) deleted + pure $ case (initial, rebuilt) of + (BuildSuccess _, BuildFailure _ _) + | deletedFirst && devOnDisk && devValid && devContents == "keep" -> Pass + | otherwise -> Fail "failed partial rebuild removed or changed its valid sibling output" + _ -> Fail "partial rebuild test setup did not reach the expected states", + -- The shape the reviewer's blocker had: a package with a dev output + -- has ONE builder writing both, so a partial rebuild hands that + -- builder a $dev that is valid, registered and sealed read-only. + -- Writing there has to work and must not disturb what is registered. + runTestM "partial rebuild writes both outputs and leaves the valid one alone" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-partial-both" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "ggggggggggggggggggggggggggggggg5" "both-main" + devSP = StorePath "ggggggggggggggggggggggggggggggg6" "both-dev" + mkDrv script = + Derivation + { drvOutputs = + [ DerivationOutput "out" outSP "" "", + DerivationOutput "dev" devSP "" "" + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", script], + drvEnv = Map.fromList [("name", "partial-both")] + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-partial-both-tmp"} + devPath = storePathToFilePath (stDir store) devSP + outPath = storePathToFilePath (stDir store) outSP + -- Both outputs, every time, as a real multi-output builder does. + writeBoth v = "mkdir -p $out $dev && echo " <> v <> " > $out/value && echo " <> v <> " > $dev/value" + initial <- buildDerivation config store (mkDrv (writeBoth "first")) testDrvPath + deleted <- deleteStorePathRaw store (spHash outSP <> "-" <> spName outSP) + rebuilt <- buildDerivation config store (mkDrv (writeBoth "second")) testDrvPath + outContents <- T.strip <$> TIO.readFile (outPath "value") + devContents <- T.strip <$> TIO.readFile (devPath "value") + devValid <- isValid store devSP + outValid <- isValid store outSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + let deletedFirst = either (const False) (\outcome -> doRowRemoved outcome && doTreeRemoved outcome) deleted + pure $ case (initial, rebuilt) of + (BuildSuccess _, BuildSuccess _) + | not deletedFirst -> Fail "partial rebuild setup did not delete the first output" + -- The valid sibling keeps the bytes its NarHash describes: the + -- builder wrote to a scratch path, not to it. + | devContents /= "first" -> Fail ("valid sibling was overwritten: " <> devContents) + | outContents /= "second" -> Fail ("rebuilt output has the wrong contents: " <> outContents) + | not (outValid && devValid) -> Fail "both outputs should be valid after the rebuild" + | otherwise -> Pass + (_, BuildFailure msg _) -> Fail ("a builder writing both outputs failed the rebuild: " <> msg) + _ -> Fail "partial rebuild test setup did not reach the expected states", + -- The scratch path is discarded after the build, so an output that + -- records it would be left naming nothing. The hash is rewritten to + -- the sibling's final one, as upstream rewrites it. + runTestM "an output recording a valid sibling's scratch path names the sibling" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-scratch-leak" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "ggggggggggggggggggggggggggggggg7" "leak-main" + devSP = StorePath "ggggggggggggggggggggggggggggggg8" "leak-dev" + mkDrv script = + Derivation + { drvOutputs = + [ DerivationOutput "out" outSP "" "", + DerivationOutput "dev" devSP "" "" + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", script], + drvEnv = Map.fromList [("name", "scratch-leak")] + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-scratch-leak-tmp"} + devPath = storePathToFilePath (stDir store) devSP + outPath = storePathToFilePath (stDir store) outSP + initial <- buildDerivation config store (mkDrv "mkdir -p $out $dev && echo first > $out/value && echo first > $dev/value") testDrvPath + deleted <- deleteStorePathRaw store (spHash outSP <> "-" <> spName outSP) + -- \$dev now names a scratch path, and the builder bakes it into $out + -- the way a compiler driver or a libtool archive would. + rebuilt <- buildDerivation config store (mkDrv "mkdir -p $out $dev && echo $dev > $out/recorded && echo first > $dev/value") testDrvPath + devContents <- T.strip <$> TIO.readFile (devPath "value") + recorded <- T.strip <$> TIO.readFile (outPath "recorded") + devValid <- isValid store devSP + outValid <- isValid store outSP + references <- queryReferences (stDB store) outSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + let deletedFirst = either (const False) (\outcome -> doRowRemoved outcome && doTreeRemoved outcome) deleted + pure $ case (initial, rebuilt) of + (BuildSuccess _, BuildSuccess _) + | not deletedFirst -> Fail "scratch-leak setup did not delete the first output" + | not (outValid && devValid) -> Fail "both outputs should be valid after the rebuild" + | devContents /= "first" -> Fail ("valid sibling was overwritten: " <> devContents) + | recorded /= T.pack devPath -> Fail ("the output did not name the sibling: " <> recorded) + | map (T.takeEnd (T.length (spName devSP))) references /= [spName devSP] -> Fail ("expected only the sibling as a reference: " <> T.pack (show references)) + | otherwise -> Pass + (_, BuildFailure msg _) -> Fail ("the rebuild failed: " <> msg) + _ -> Fail "scratch-leak test setup did not reach the expected states", + -- Builder succeeds but doesn't create $out, so the build fails + runTestM "missing output fails build" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-noout" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiiii" "nooutput" + drv = mkTestBuildDrv shell outSP "echo 'forgot to create output'" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-noout-tmp"} + result <- buildDerivation config store drv testDrvPath + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure msg _ -> + if T.isInfixOf "outputs missing" msg + then Pass + else Fail ("expected 'outputs missing' error, got: " <> msg) + BuildSuccess _ -> Fail "expected failure when builder doesn't create $out", + runTestM "missing sibling output cleans produced orphan" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-partial-missing" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiii1" "partial-output" + devSP = StorePath "iiiiiiiiiiiiiiiiiiiiiiiiiiiiiii2" "missing-output" + drv = + Derivation + { drvOutputs = + [ DerivationOutput "out" outSP "" "", + DerivationOutput "dev" devSP "" "" + ], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = TE.encodeUtf8 shell, + drvArgs = ["-c", "mkdir -p $out && echo orphan > $out/value"], + drvEnv = Map.fromList [("name", "partial-missing")] + } + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-partial-missing-tmp"} + outPath = storePathToFilePath (stDir store) outSP + devPath = storePathToFilePath (stDir store) devSP + result <- buildDerivation config store drv testDrvPath + outOnDisk <- Dir.doesPathExist outPath + devOnDisk <- Dir.doesPathExist devPath + outValid <- isValid store outSP + devValid <- isValid store devSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure msg _ + | "outputs missing" `T.isInfixOf` msg && not outOnDisk && not devOnDisk && not outValid && not devValid -> Pass + | otherwise -> Fail ("missing-output failure left store state behind: " <> msg) + BuildSuccess _ -> Fail "partial-output builder unexpectedly succeeded", + -- File output (not directory) should succeed + runTestM "file output succeeds" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder-fileout" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjj" "fileout" + drv = mkTestBuildDrv shell outSP "echo 'I am a file output' > $out" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-builder-fileout-tmp"} + result <- buildDerivation config store drv testDrvPath + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildSuccess sp -> assertEqual "file output path" outSP sp + BuildFailure msg code -> Fail ("file output build failed (" <> T.pack (show code) <> "): " <> msg), + -- Cleanup after failure + runTestM "cleanup after failure" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-builder8" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let outSP = StorePath "hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh" "cleantest" + drv = mkTestBuildDrv shell outSP "exit 1" + tmpDir = tmpBase "nova-nix-test-builder8-tmp" + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpDir} + _ <- buildDerivation config store drv testDrvPath + -- Build dir should be cleaned up + let buildDir = tmpDir T.unpack (spHash outSP) + buildDirExists <- doesDirectoryExist buildDir + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists tmpDir + pure $ if not buildDirExists then Pass else Fail "build dir not cleaned up after failure", + -- Fixed-output: registration re-checks the placed bytes + runTestM "fixed-output flat output verifies and registers" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-fo1" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let payload = "fixed output payload\n" + digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" payload) + outSP = StorePath "ffffffffffffffffffffffffffffff01" "fo-flat-good" + drv = mkFixedOutputDrv shell outSP "printf 'fixed output payload\\n' > $out" "sha256" digest + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo1-tmp"} + result <- buildDerivation config store drv testDrvPath + registered <- isValid store outSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildSuccess _ + | registered -> Pass + | otherwise -> Fail "built but not registered valid" + BuildFailure msg code -> Fail ("expected success (" <> T.pack (show code) <> "): " <> msg), + -- The impureEnvVars carve-out (#185): a fixed-output derivation's + -- listed ambient variables reach the scrubbed build, an absent + -- listed name arrives as the EMPTY STRING (present, not omitted, + -- upstream's value_or("")), and everything else stays scrubbed. + runTestM "impureEnvVars reach a fixed-output build, absent names as empty" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-impure1" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + setEnv "NOVA_TEST_IMPURE" "proxy-ok" + unsetEnv "NOVA_TEST_ABSENT" + let payload = "fixed output payload\n" + digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" payload) + outSP = StorePath "ffffffffffffffffffffffffffffff03" "fo-impure-env" + script = "[ \"$NOVA_TEST_IMPURE\" = \"proxy-ok\" ] && [ \"${NOVA_TEST_ABSENT+set}\" = \"set\" ] && [ -z \"$NOVA_TEST_ABSENT\" ] && printf 'fixed output payload\\n' > $out" + baseDrv = mkFixedOutputDrv shell outSP script "sha256" digest + drv = baseDrv {drvEnv = Map.insert "impureEnvVars" "NOVA_TEST_IMPURE NOVA_TEST_ABSENT" (drvEnv baseDrv)} + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-impure1-tmp"} + result <- buildDerivation config store drv testDrvPath + unsetEnv "NOVA_TEST_IMPURE" + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildSuccess _ -> Pass + BuildFailure msg code -> Fail ("carve-out did not reach the build (" <> T.pack (show code) <> "): " <> msg), + runTestM "impureEnvVars are ignored for a non-fixed-output build" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-impure2" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + setEnv "NOVA_TEST_IMPURE" "must-not-leak" + let outSP = StorePath "ffffffffffffffffffffffffffffff04" "impure-scrubbed" + script = "[ -z \"${NOVA_TEST_IMPURE-}\" ] && echo ok > $out" + baseDrv = mkTestBuildDrv shell outSP script + drv = baseDrv {drvEnv = Map.insert "impureEnvVars" "NOVA_TEST_IMPURE" (drvEnv baseDrv)} + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-impure2-tmp"} + result <- buildDerivation config store drv testDrvPath + unsetEnv "NOVA_TEST_IMPURE" + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildSuccess _ -> Pass + BuildFailure msg code -> Fail ("ambient leaked into a non-fixed-output build (" <> T.pack (show code) <> "): " <> msg), + runTestM "fixed-output flat mismatch fails and removes the output" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-fo2" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" "expected content\n") + outSP = StorePath "ffffffffffffffffffffffffffffff02" "fo-flat-bad" + drv = mkFixedOutputDrv shell outSP "printf 'tampered content\\n' > $out" "sha256" digest + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo2-tmp"} + result <- buildDerivation config store drv testDrvPath + registered <- isValid store outSP + onDisk <- Dir.doesPathExist (storePathToFilePath (stDir store) outSP) + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure msg _ + | "hash mismatch" `T.isInfixOf` msg && not registered && not onDisk -> Pass + | otherwise -> + Fail + ( "wrong failure shape (valid=" + <> T.pack (show registered) + <> ", onDisk=" + <> T.pack (show onDisk) + <> "): " + <> msg + ) + BuildSuccess _ -> Fail "mismatched fixed output registered", + runTestM "fixed-output recursive tree verifies against its NAR hash" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-fo3" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let tree = NAR.NarDirectory [("data.txt", NAR.NarRegular False "inner bytes\n")] + digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" (NAR.serialise tree)) + outSP = StorePath "ffffffffffffffffffffffffffffff03" "fo-rec-good" + drv = mkFixedOutputDrv shell outSP "mkdir -p $out && printf 'inner bytes\\n' > $out/data.txt" "r:sha256" digest + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo3-tmp"} + result <- buildDerivation config store drv testDrvPath + registered <- isValid store outSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildSuccess _ + | registered -> Pass + | otherwise -> Fail "built but not registered valid" + BuildFailure msg code -> Fail ("expected success (" <> T.pack (show code) <> "): " <> msg), + runTestM "fixed-output recursive mismatch fails the build" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-fo4" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let tree = NAR.NarDirectory [("data.txt", NAR.NarRegular False "declared bytes\n")] + digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" (NAR.serialise tree)) + outSP = StorePath "ffffffffffffffffffffffffffffff04" "fo-rec-bad" + drv = mkFixedOutputDrv shell outSP "mkdir -p $out && printf 'other bytes\\n' > $out/data.txt" "r:sha256" digest + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo4-tmp"} + result <- buildDerivation config store drv testDrvPath + registered <- isValid store outSP + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure msg _ + | "hash mismatch" `T.isInfixOf` msg && not registered -> Pass + | otherwise -> Fail ("wrong failure shape: " <> msg) + BuildSuccess _ -> Fail "mismatched fixed output registered", + runTestM "fixed-output flat mode rejects a directory output" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-fo5" + forceRemoveIfExists tmpStore + store <- openStore (StoreDir tmpStore) + let digest = maybe "" Hash.bytesToHexText (Hash.rawHashWithAlgo "sha256" "whatever\n") + outSP = StorePath "ffffffffffffffffffffffffffffff05" "fo-flat-dir" + drv = mkFixedOutputDrv shell outSP "mkdir -p $out && printf 'x' > $out/f" "sha256" digest + config = (defaultBuildConfig (stDir store)) {bcTmpDir = tmpBase "nova-nix-test-fo5-tmp"} + result <- buildDerivation config store drv testDrvPath + closeStore store + forceRemoveIfExists tmpStore + forceRemoveIfExists (bcTmpDir config) + pure $ case result of + BuildFailure msg _ + | "directory" `T.isInfixOf` msg -> Pass + | otherwise -> Fail ("wrong failure: " <> msg) + BuildSuccess _ -> Fail "directory output passed a flat fixed-output check" + ] + +-- --------------------------------------------------------------------------- +-- Tests: CLI Integration (Phase 2, Batch 5) +-- --------------------------------------------------------------------------- + +-- | A tree holding a reserved device stem, a colon and a trailing dot, +-- names POSIX holds and Windows does not, in the order a sorted listing +-- gives them. The colon follows more than one letter: bsdtar, which +-- fetchTarball's extraction runs on macOS, drops a one-letter prefix +-- such as @a:@ as a drive letter once @--strip-components@ has exposed +-- it. +reservedNameFiles :: [(FilePath, BS.ByteString)] +reservedNameFiles = [("aux.c", "device\n"), ("dot.", "dot\n"), ("key:value", "colon\n")] + +-- | Where upstream stores 'reservedNameFiles' as a coerced source +-- directory named @src@ (nix-instantiate 2.33.2, @"${./src}"@) and as +-- the tree of a fetchTarball (with @--store 'local?root=...'@, which +-- holds it under exactly these names). +reservedNameSourcePath, reservedNameTarballPath :: StorePath +reservedNameSourcePath = StorePath "42hs0hrpla9b23iz9p3nj0px0np0jv6f" "src" +reservedNameTarballPath = StorePath "rlwykawmqrmdiq4xmcr4rf2zxf6y9k09" "source" + +-- | End-to-end: eval .nix source, extract derivation, build, verify output. +evalAndBuild :: StoreDir -> Text -> IO (Either Text (BuildResult, Store)) +evalAndBuild storeDir source = do + case parseNix testBaseDir testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left ("parse error: " <> T.pack (show err))) + Right expr -> do + -- The SAME store the build below is given. Evaluating against the + -- platform default while building elsewhere is what let a store dir + -- honored on writes but not on reads pass the whole suite. + st <- newEvalState storeDir "." + evalResult <- runEvalIO st $ do + val <- eval (builtinEnv unrestrictedPolicy (esTimestamp st) (esSearchPaths st)) expr + -- What the CLI driver does: force drvPath, which runs + -- derivationStrict (so a missing required attr surfaces as an eval + -- error) and records the .drv the build reads back by that path. + case val of + VAttrs attrs | Just thunk <- attrSetLookup "drvPath" attrs -> do + pathVal <- force thunk + case pathVal of + VStr pathBytes _ -> lookupSessionDrv (bytesText pathBytes) + _ -> pure Nothing + _ -> pure Nothing + case evalResult of + Left err -> pure (Left ("eval error: " <> err)) + Right Nothing -> pure (Left "result is not a derivation") + Right (Just drv) -> do + store <- openStore storeDir + tmpBase <- getTemporaryDirectory + let config = (defaultBuildConfig storeDir) {bcTmpDir = tmpBase "nova-nix-e2e-tmp"} + -- What the CLI driver does before building, in the same + -- order: eval has no store DB handle, so anything it wrote + -- is registered here or not at all. Skipping it made this + -- harness unable to see a whole class of driver bug. + sourceCache <- readIORef (esSourcePathCache st) + storeWrites <- readIORef (esStoreWriteCache st) + materializeEvalSources store sourceCache + materializeEvalStoreWrites store storeWrites + result <- buildDerivation config store drv testDrvPath + pure (Right (result, store)) + +testE2E :: IO [Bool] +testE2E = do + putStrLn "cli/e2e" + shell <- findTestShell + sequence + [ -- End-to-end: eval -> build a simple derivation + runTestM "e2e eval -> build" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-e2e1" + forceRemoveIfExists tmpStore + -- Build the Nix source with the discovered shell path. + -- Nix strings use \\ for literal backslash, \" for literal quote. + let nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + e2eSource = + T.concat + [ "derivation { name = \"e2e-test\"; system = builtins.currentSystem; ", + "builder = \"" <> nixEscape shell <> "\"; ", + "args = [\"-c\" \"mkdir -p $out && echo e2e > $out/e2e.txt\"]; }" + ] + result <- evalAndBuild (StoreDir tmpStore) e2eSource + ret <- case result of + Left err -> pure (Fail err) + Right (BuildSuccess _, store) -> do + closeStore store + pure Pass + Right (BuildFailure msg code, store) -> do + closeStore store + pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + forceRemoveIfExists tmpStore + forceRemoveIfExists (tmpBase "nova-nix-e2e-tmp") + pure ret, + -- Every eval-time store writer must register, not only toFile: an + -- unrecorded write reaches drvInputSrcs and the build dies with + -- "path '...' is not valid". + runTestM "e2e eval-time store writes register as derivation inputs" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-e2e-inputs" + srcDir = tmpBase "nova-nix-test-e2e-inputs-src" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + drvWith srcExpr = + T.concat + [ "derivation { name = \"inputs-test\"; system = builtins.currentSystem; ", + "builder = \"" <> nixEscape shell <> "\"; ", + "args = [\"-c\" \"echo ok > $out\"]; ", + "src = " <> srcExpr <> "; }" + ] + forceRemoveIfExists tmpStore + forceRemoveIfExists srcDir + Dir.createDirectoryIfMissing True srcDir + writeFile (srcDir "f.txt") "content\n" + let cases = + [ ("toFile", "builtins.toFile \"note\" \"text\""), + -- A path LITERAL, not a string, so it must be spelled the + -- way the evaluator spells path values: the lexer rejects a + -- backslash, and a native Windows temp dir is full of them. + -- Through 'canonPathValue' rather than a separator replace, + -- because a backslash is an ordinary file-name character on + -- POSIX and only a separator on Windows. + ("path", "builtins.path { path = " <> canonPathValue (T.pack srcDir) <> "; name = \"sd\"; }") + ] + outcomes <- + mapM + ( \(label, expr) -> do + result <- evalAndBuild (StoreDir tmpStore) (drvWith expr) + pure (label, result) + ) + cases + let failures = + [ label <> ": " <> reason + | (label, result) <- outcomes, + Just reason <- + [ case result of + Left err -> Just err + Right (BuildFailure msg _, _) -> Just msg + Right (BuildSuccess _, _) -> Nothing + ] + ] + mapM_ + ( \(_, result) -> case result of + Right (_, store) -> closeStore store + Left _ -> pure () + ) + outcomes + forceRemoveIfExists tmpStore + forceRemoveIfExists srcDir + pure $ case failures of + [] -> Pass + errs -> Fail (T.intercalate "; " errs), + -- POSIX holds names Windows reserves, and upstream stores them as + -- their bytes there (#84). A coerced source and a fetchTarball + -- tree holding a device stem, a colon and a trailing dot restore + -- with exactly those names, under the paths upstream computes + -- for them ('reservedNameSourcePath'), as the raw copy they + -- replace stored them (#235). + runTestM "e2e sources holding names Windows reserves restore with their names" $ + if SI.os == "mingw32" + then Pass <$ putStrLn " SKIP a Windows volume cannot hold these names" + else do + tmpBase <- getTemporaryDirectory + environment <- getEnvironment + let root = tmpBase "nova-nix-test-e2e-names" + srcDir = root "src" + stage = root "stage" + tarball = root "names.tar.gz" + tmpStore = tmpBase "nova-nix-test-e2e-names-store" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + source = + T.concat + [ "derivation { name = \"names\"; system = builtins.currentSystem; ", + "builder = \"" <> nixEscape shell <> "\"; ", + "args = [\"-c\" \"echo ok > $out\"]; ", + "srcs = [ " <> canonPathValue (T.pack srcDir) <> " ", + "(builtins.fetchTarball \"file://" <> nixEscape (T.pack tarball) <> "\") ]; }" + ] + -- bsdtar would otherwise add AppleDouble entries for + -- any extended attributes the files carry. + tarProcess = + (Proc.proc "tar" ["-czf", tarball, "-C", stage, "top"]) + { Proc.env = Just (("COPYFILE_DISABLE", "1") : environment) + } + writeTree dir = do + createDirectoryIfMissing True dir + mapM_ (\(name, bytes) -> BS.writeFile (dir name) bytes) reservedNameFiles + storedAs store sp = do + let dest = storePathToFilePath (stDir store) sp + present <- doesDirectoryExist dest + if not present + then pure (Just (spName sp <> ": no tree at " <> T.pack dest)) + else do + names <- sort <$> Dir.listDirectory dest + contents <- traverse (BS.readFile . (dest )) names + valid <- isValid store sp + pure $ + if valid && zip names contents == reservedNameFiles + then Nothing + else Just (spName sp <> " valid " <> T.pack (show valid) <> ", stored as " <> T.pack (show (zip names contents))) + forceRemoveIfExists root + forceRemoveIfExists tmpStore + writeTree srcDir + writeTree (stage "top") + (tarCode, _, tarErr) <- Proc.readCreateProcessWithExitCode tarProcess "" + verdict <- case tarCode of + ExitFailure n -> pure (Fail ("tar exited " <> T.pack (show n) <> ": " <> T.pack tarErr)) + ExitSuccess -> do + built <- evalAndBuild (StoreDir tmpStore) source + case built of + Left err -> pure (Fail err) + Right (BuildFailure msg _, store) -> Fail msg <$ closeStore store + Right (BuildSuccess _, store) -> do + problems <- catMaybes <$> traverse (storedAs store) [reservedNameSourcePath, reservedNameTarballPath] + closeStore store + pure (if null problems then Pass else Fail (T.intercalate "; " problems)) + forceRemoveIfExists root + forceRemoveIfExists tmpStore + pure verdict, + -- The writer half of the eval-write pair: an interrupted earlier + -- run's truncated file at a toFile path must be rewritten, not + -- adopted on bare existence (adopting it used to register such a file + -- valid under the full content's hash, seal it read-only, and let a + -- build consume it). + runTestM "a truncated pre-existing toFile write is rewritten, not adopted" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-tofile-verify" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + goodText = "the full intended content" :: Text + goodBytes = TE.encodeUtf8 goodText + forceRemoveIfExists tmpStore + case makeTextPath "note" (sha256Digest goodBytes) [] of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let dest = storePathToFilePath (StoreDir tmpStore) sp + Dir.createDirectoryIfMissing True (takeDirectory dest) + BS.writeFile dest (TE.encodeUtf8 "the full") + let expr = + "derivation { name = \"tofile-verify\"; system = builtins.currentSystem; " + <> "builder = \"" + <> nixEscape shell + <> "\"; " + <> "args = [\"-c\" \"echo ok > $out\"]; " + <> "src = builtins.toFile \"note\" \"" + <> goodText + <> "\"; }" + result <- evalAndBuild (StoreDir tmpStore) expr + rewritten <- BS.readFile dest + outcome <- case result of + Left err -> pure (Fail err) + Right (BuildFailure msg _, store) -> closeStore store >> pure (Fail msg) + Right (BuildSuccess _, store) -> do + registered <- isValid store sp + closeStore store + pure $ + if rewritten == goodBytes && registered + then Pass + else Fail "adopted the truncated file instead of rewriting it" + forceRemoveIfExists tmpStore + pure outcome, + -- Same guarantee for the tree writer behind builtins.path: a + -- corrupted partial tree at the computed path is cleared and + -- re-unpacked, never adopted. + runTestM "a corrupted pre-existing builtins.path tree is re-copied, not adopted" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-path-verify" + srcDir = tmpBase "nova-nix-test-path-verify-src" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + forceRemoveIfExists tmpStore + forceRemoveIfExists srcDir + Dir.createDirectoryIfMissing True srcDir + BS.writeFile (srcDir "f.txt") (TE.encodeUtf8 "real content\n") + entry <- NAR.serialiseFromPath srcDir + case makeFixedOutputPath "sd" "sha256" "recursive" (sha256Digest (NAR.serialise entry)) of + Left err -> pure (Fail ("test store path rejected: " <> T.pack (show err))) + Right sp -> do + let dest = storePathToFilePath (StoreDir tmpStore) sp + Dir.createDirectoryIfMissing True dest + BS.writeFile (dest "f.txt") (TE.encodeUtf8 "partial garbage") + let expr = + "derivation { name = \"path-verify\"; system = builtins.currentSystem; " + <> "builder = \"" + <> nixEscape shell + <> "\"; " + <> "args = [\"-c\" \"echo ok > $out\"]; " + <> "src = builtins.path { path = " + <> canonPathValue (T.pack srcDir) + <> "; name = \"sd\"; }; }" + result <- evalAndBuild (StoreDir tmpStore) expr + outcome <- case result of + Left err -> pure (Fail err) + Right (BuildFailure msg _, store) -> closeStore store >> pure (Fail msg) + Right (BuildSuccess _, store) -> do + -- Strict bytes: a lazy read here holds the file open past + -- the cleanup below, and Windows refuses to delete it. + adopted <- BS.readFile (dest "f.txt") + registered <- isValid store sp + closeStore store + pure $ + if adopted == TE.encodeUtf8 "real content\n" && registered + then Pass + else Fail ("adopted the corrupted tree: " <> T.pack (show adopted)) + forceRemoveIfExists tmpStore + forceRemoveIfExists srcDir + pure outcome, + -- The build path joins the per-path lock protocol (#119, #121) that + -- delete, materialize and register already used. Lock files persist + -- by design, so the one guarding the output is the observable + -- evidence the build took it; without it two concurrent builds share + -- a build directory and interleave into one tree. + runTestM "e2e a build takes its output's path lock" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-e2e-lock" + nixEscape = T.concatMap (\c -> if c == '\\' then "\\\\" else if c == '"' then "\\\"" else T.singleton c) + lockSource = + T.concat + [ "derivation { name = \"lock-test\"; system = builtins.currentSystem; ", + "builder = \"" <> nixEscape shell <> "\"; ", + "args = [\"-c\" \"echo locked > $out\"]; }" + ] + forceRemoveIfExists tmpStore + result <- evalAndBuild (StoreDir tmpStore) lockSource + ret <- case result of + Left err -> pure (Fail err) + Right (BuildFailure msg code, store) -> do + closeStore store + pure (Fail ("build failed (" <> T.pack (show code) <> "): " <> msg)) + Right (BuildSuccess sp, store) -> do + closeStore store + let outPath = storePathToFilePath (StoreDir tmpStore) sp + locked <- Dir.doesFileExist (outPath <> ".lock") + pure $ + if locked + then Pass + else Fail "no lock file beside the built output" + forceRemoveIfExists tmpStore + forceRemoveIfExists (tmpBase "nova-nix-e2e-tmp") + pure ret, + -- Parse error produces Left + runTestM "e2e parse error" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-e2e2" + forceRemoveIfExists tmpStore + result <- evalAndBuild (StoreDir tmpStore) "{{ invalid nix" + forceRemoveIfExists tmpStore + pure $ case result of + Left msg -> + if "parse error" `T.isInfixOf` msg + then Pass + else Fail ("expected parse error, got: " <> msg) + Right _ -> Fail "expected error but got success", + -- Eval error produces Left + runTestM "e2e eval error" $ do + tmpBase <- getTemporaryDirectory + let tmpStore = tmpBase "nova-nix-test-e2e3" + forceRemoveIfExists tmpStore + result <- evalAndBuild (StoreDir tmpStore) "derivation { }" + forceRemoveIfExists tmpStore + pure $ case result of + Left msg -> + if "error" `T.isInfixOf` T.toLower msg + then Pass + else Fail ("expected eval error, got: " <> msg) + Right _ -> Fail "expected error but got success", + -- E2E with subprocess: nova-nix eval on a .nix file + runTestM "e2e nova-nix eval subprocess" $ do + tmpBase <- getTemporaryDirectory + let tmpDir = tmpBase "nova-nix-test-e2e-sub" + nixFile = tmpDir "test.nix" + forceRemoveIfExists tmpDir + createDirectoryIfMissing True tmpDir + writeFile nixFile "1 + 2" + -- Run nova-nix eval via Process + (exitCode, stdoutStr, stderrStr) <- + Proc.readCreateProcessWithExitCode + (Proc.proc "cabal" ["run", "nova-nix", "--", "eval", nixFile]) + "" + forceRemoveIfExists tmpDir + pure $ case exitCode of + ExitSuccess -> + let nonEmpty = filter (not . T.null) (T.lines (T.pack stdoutStr)) + lastLine = case reverse nonEmpty of + (l : _) -> Just l + [] -> Nothing + in if lastLine == Just "3" + then Pass + else Fail ("expected 3 as last line, got: " <> T.pack stdoutStr) + ExitFailure code -> + Fail ("nova-nix eval failed (" <> T.pack (show code) <> "): stderr=" <> T.pack stderrStr) + ] + +-- | Exercise the real CLI: testing 'execWrapperConfig' alone cannot catch +-- a sub-parser that never passes the option to it. The foreign builder is +-- deliberately "-c", so only launching it through the shell can succeed. +testExecWrapperCLI :: IO [Bool] +testExecWrapperCLI = do + putStrLn "cli/exec-wrapper" + shell <- findTestShell + tmpBase <- getTemporaryDirectory + ambient <- getEnvironment + let root = tmpBase "nova-nix-test-cli-wrapper" + system = platformToText (if currentPlatform == X86_64_Windows then X86_64_Linux else X86_64_Windows) + wrapper = ["--exec-wrapper", T.unpack (system <> "=" <> shell)] + otherWrapper = ["--exec-wrapper", T.unpack (platformToText currentPlatform <> "=" <> shell)] + source = + "derivation { name = \"cli-wrapper\"; system = \"" + <> T.unpack system + <> "\"; builder = \"-c\"; args = [\"printf wrapped > \\\"$out\\\"\"]; }" + target = ["--expr", source] + isolatedEnv = + ("NIX_CONFIG", "substituters =\ntrusted-public-keys =\n") + : ("XDG_CONFIG_HOME", root "config") + : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME"]) ambient + runCLI args = + Proc.readCreateProcessWithExitCode + ((Proc.proc "cabal" (["run", "-v0", "nova-nix", "--"] ++ args)) {Proc.env = Just isolatedEnv}) + "" + buildCases = + [ ("before build", wrapper ++ ["build"] ++ target), + ("before target", ["build"] ++ wrapper ++ target), + ("after target", ["build"] ++ target ++ wrapper), + ("repeated across build", otherWrapper ++ ["build"] ++ target ++ wrapper) + ] + errorCases = + [ ("missing value", ["build"] ++ target ++ ["--exec-wrapper"], "--exec-wrapper requires a value"), + ("malformed spec", ["build"] ++ target ++ ["--exec-wrapper", "invalid"], "--exec-wrapper expects SYSTEM=PATH, got: invalid"), + ("duplicate system", wrapper ++ ["build"] ++ target ++ wrapper, "--exec-wrapper names " <> system <> " twice"), + ("missing launcher", ["build"] ++ target ++ ["--exec-wrapper", T.unpack system ++ "=" ++ (root "missing-launcher")], "does not exist") + ] + bracket_ + (forceRemoveIfExists root >> createDirectoryIfMissing True root) + (forceRemoveIfExists root) + ( do + builds <- + mapM + ( \(label, args) -> runTestM ("CLI wrapper " <> label) $ do + (code, out, err) <- runCLI (args ++ ["--store", root T.unpack label]) + case (code, reverse (filter (not . null) (lines out))) of + (ExitSuccess, path : _) -> assertEqual "wrapped output" "wrapped" <$> BS.readFile path + _ -> pure (Fail ("CLI failed: " <> T.pack (show code) <> "; stdout=" <> T.pack out <> "; stderr=" <> T.pack err)) + ) + buildCases + errors <- + mapM + ( \(label, args, expected) -> runTestM ("CLI wrapper " <> label) $ do + (code, _, err) <- runCLI args + pure $ + if code /= ExitSuccess && expected `T.isInfixOf` T.pack err + then Pass + else Fail ("expected failure containing " <> expected <> ", got " <> T.pack (show (code, err))) + ) + errorCases + pure (builds ++ errors) + ) + +-- | A failure no command handles prints as upstream's handleExceptions +-- prints one, a single @error:@ line and exit status 1, not GHC's +-- "Uncaught exception" report. A derivation whose context names a path +-- the store never registered meets the store's refusal while its @.drv@ +-- is written, before anything builds. +testUncaughtIOFailureCLI :: IO [Bool] +testUncaughtIOFailureCLI = do + putStrLn "cli/uncaught-io-failure" + tmpBase <- getTemporaryDirectory + ambient <- getEnvironment + let root = tmpBase "nova-nix-test-cli-io-failure" + missing :: String + missing = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-gone" + source = + "derivation { name = \"unregistered\"; system = builtins.currentSystem; builder = \"/bin/sh\"; dep = builtins.appendContext \"\" { \"" + <> missing + <> "\" = { path = true; }; }; }" + isolatedEnv = + ("NIX_CONFIG", "substituters =\ntrusted-public-keys =\n") + : ("XDG_CONFIG_HOME", root "config") + : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME"]) ambient + bracket_ + (forceRemoveIfExists root >> createDirectoryIfMissing True root) + (forceRemoveIfExists root) + ( do + (code, _, err) <- + Proc.readCreateProcessWithExitCode + ((Proc.proc "cabal" ["run", "-v0", "nova-nix", "--", "build", "--expr", source, "--store", root "store"]) {Proc.env = Just isolatedEnv}) + "" + sequence + [ runTest "uncaught I/O failure exits 1" (assertEqual "exit code" (ExitFailure 1) code), + runTest "uncaught I/O failure prints upstream's error line" $ + assertEqual "stderr" ["error: path '" <> missing <> "' is not valid"] (map (filter (/= '\r')) (lines err)) + ] + ) + +-- --------------------------------------------------------------------------- +-- Tests: Phase 4 - search paths, dynamic keys, directory import +-- --------------------------------------------------------------------------- + +testPhase4 :: IO [Bool] +testPhase4 = do + putStrLn "phase4/search-paths" + sequence + [ -- parseNixPath tests + runTest "parseNixPath empty" $ + assertEqual "empty" [] (parseNixPath ""), + runTest "parseNixPath single" $ + let result = parseNixPath "nixpkgs=/home/user/nixpkgs" + in case result of + [thunk] | Just (VAttrs m) <- readThunkValue thunk -> + case (attrSetLookup "prefix" m >>= readThunkValue, attrSetLookup "path" m >>= readThunkValue) of + (Just (VStr "nixpkgs" _), Just (VStr "/home/user/nixpkgs" _)) -> Pass + _ -> Fail "wrong prefix/path" + _ -> Fail ("expected one entry, got " <> T.pack (show (length result))), + runTest "parseNixPath multiple" $ + assertEqual "count" 2 (length (parseNixPath "nixpkgs=/nix:custom=/opt")), + runTest "parseNixPath channel entry" $ + let result = parseNixPath "nixpkgs=channel:nixos-24.11" + in case result of + [thunk] | Just (VAttrs m) <- readThunkValue thunk -> + case (attrSetLookup "prefix" m >>= readThunkValue, attrSetLookup "path" m >>= readThunkValue) of + (Just (VStr "nixpkgs" _), Just (VStr "channel:nixos-24.11" _)) -> Pass + _ -> Fail "wrong prefix/path for channel" + _ -> Fail ("expected one entry, got " <> T.pack (show (length result))), + runTest "splitNixPath drive letters and separators" $ + assertEqual + "split" + ["nixpkgs=C:\\nixpkgs", "custom=/opt/custom", "C:/x"] + (splitNixPath "nixpkgs=C:\\nixpkgs:custom=/opt/custom:C:/x"), + runTest "splitNixPath splits a Unix-style absolute path list" $ + assertEqual "split-unix" ["/foo", "/bar"] (splitNixPath "/foo:/bar"), + runTest "splitNixPath splits a Unix entry after a drive entry" $ + assertEqual "split-mixed" ["C:\\a", "/foo"] (splitNixPath "C:\\a:/foo"), + runTest "splitNixPath keeps a URL entry whole" $ + assertEqual + "split-url" + ["nixpkgs=https://example.com/nixpkgs.tar.gz", "custom=/opt"] + (splitNixPath "nixpkgs=https://example.com/nixpkgs.tar.gz:custom=/opt"), + runTest "splitNixPath keeps a channel entry whole" $ + assertEqual + "split-channel" + ["channel:nixos-24.11", "/foo"] + (splitNixPath "channel:nixos-24.11:/foo"), + runTest "splitNixPath keeps a prefixed channel entry whole" $ + assertEqual + "split-channel-prefixed" + ["nixpkgs=channel:nixos-24.11", "/foo"] + (splitNixPath "nixpkgs=channel:nixos-24.11:/foo"), + runTest "splitNixPath keeps a flake entry whole" $ + assertEqual "split-flake" ["flake:nixpkgs", "/foo"] (splitNixPath "flake:nixpkgs:/foo"), + runTest "splitNixPath keeps every listed scheme whole" $ + assertEqual + "split-schemes" + ["http://h/a", "https://h/b", "file:///c", "channel://d", "git://h/e", "s3://b/f", "ssh://h/g"] + (splitNixPath "http://h/a:https://h/b:file:///c:channel://d:git://h/e:s3://b/f:ssh://h/g"), + runTest "splitNixPath splits an unlisted scheme at its colon" $ + assertEqual "split-unlisted" ["foo", "//x", "/bar"] (splitNixPath "foo://x:/bar"), + runTest "splitNixPath drops empty entries" $ + assertEqual "split-empties" ["a", "b"] (splitNixPath "a::b:"), + runTest "splitNixPath drops leading empty entries" $ + assertEqual "split-leading-empties" ["x"] (splitNixPath "::x"), + runTest "splitNixPath matches a scheme case-sensitively" $ + assertEqual "split-scheme-case" ["HTTP", "//x", "/y"] (splitNixPath "HTTP://x:/y"), + runTest "splitNixPath judges the scheme after the last = of the entry" $ + assertEqual "split-last-equals" ["a=b=https://x", "/y"] (splitNixPath "a=b=https://x:/y"), + runTest "splitNixPath splits a URL port after the host" $ + assertEqual "split-port" ["https://example.com", "8080/x"] (splitNixPath "https://example.com:8080/x"), + runTest "splitNixPath absorbs one run after a channel entry" $ + assertEqual "split-one-run" ["channel:channel", "x"] (splitNixPath "channel:channel:x"), + runTest "splitNixPath keeps a bare channel colon" $ + assertEqual "split-channel-bare" ["channel:", "foo"] (splitNixPath "channel::foo"), + runTest "isNixPathPseudoUrl: channel, flake and the listed schemes are fetched" $ + assertEqual + "pseudo" + [True, True, True, True, True] + (map isNixPathPseudoUrl ["channel:nixos-24.11", "channel:", "flake:nixpkgs", "https://example.com/x.tar.gz", "file:///c"]), + runTest "isNixPathPseudoUrl: a path, an unlisted scheme, a drive and a bare word are not" $ + assertEqual "not-pseudo" [False, False, False, False] (map isNixPathPseudoUrl ["/foo", "foo://x", "C:/x", "channel"]), + runTest "splitNixPath drops a trailing empty entry" $ + assertEqual "split-trail" ["a"] (splitNixPath "a:"), + runTestM "splitNixPath long entry splits in linear time" $ do + let entry = TE.encodeUtf8 (T.replicate 2000000 "p") + split = splitNixPath ("first:" <> entry) == ["first", entry] + outcome <- timeout walkWatchdogMicros (evaluate split) + pure $ case outcome of + Just True -> Pass + Just False -> Fail "wrong split for a long entry" + Nothing -> Fail "split did not return promptly", + runTest "parseNixPath plain path" $ + let result = parseNixPath "/some/path" + in case result of + [thunk] | Just (VAttrs m) <- readThunkValue thunk -> + case (attrSetLookup "prefix" m >>= readThunkValue, attrSetLookup "path" m >>= readThunkValue) of + (Just (VStr "" _), Just (VStr "/some/path" _)) -> Pass + _ -> Fail "wrong prefix/path for plain" + _ -> Fail "expected one entry", + -- ESearchPath desugars to __findFile __nixPath "name" during resolution + runTest "parse " $ + assertParse "search path" "" (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "nixpkgs"])), + runTest "parse " $ + assertParse "search path with subpath" "" (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "nixpkgs/lib"])), + -- ESearchPath eval (should fail in pure mode since no search paths) + runTest "eval fails without path" $ + assertEvalFail "search path not found" "", + -- Dynamic attribute keys + runTest "dynamic key basic" $ + assertEval "dynamic key" "{ ${\"hello\"} = 42; }.hello" (VInt 42), + runTest "dynamic key from let" $ + assertEval "dynamic key let" "let name = \"x\"; in { ${name} = 1; }.x" (VInt 1), + runTest "dynamic key in select" $ + assertEval "dynamic key select" "let s = { x = 10; }; in s.${\"x\"}" (VInt 10), + runTest "dynamic key in hasAttr" $ + assertEval "dynamic key hasAttr" "let s = { x = 10; }; in s ? ${\"x\"}" (VBool True), + runTest "dynamic key hasAttr missing" $ + assertEval "dynamic key hasAttr missing" "let s = { x = 10; }; in s ? ${\"y\"}" (VBool False), + -- has-attr checks presence of the terminal attribute without + -- forcing its value, matching upstream laziness. + runTest "hasAttr does not force the final attribute" $ + assertEval "hasattr-lazy" "{ a = builtins.throw \"boom\"; } ? a" (VBool True), + runTest "hasAttr path does not force the terminal attribute" $ + assertEval "hasattr-path-lazy" "{ a = { b = builtins.throw \"boom\"; }; } ? a.b" (VBool True), + -- A null dynamic key in select or has-attr is a type error, as + -- upstream; it is not treated as an absent attribute. + runTest "null dynamic select key is a type error" $ + assertEvalFail "sel-null-key" "({ x = 1; }).${null}", + runTest "null dynamic hasAttr key is a type error" $ + assertEvalFail "has-null-key" "{ x = 1; } ? ${null}", + -- inherit inside a rec set with a dynamic key resolves against the + -- enclosing scope, never the rec set's own binding. + runTest "inherit in a dynamic-keyed rec set resolves outward" $ + assertEval "dyn-rec-inherit" "let v = 42; in (rec { ${\"d\"} = 1; inherit v; }).v" (VInt 42), + -- Dynamic attr inside string interpolation (the ${name} must not + -- prematurely close the outer interpolation) + runTest "dynamic key in string interp" $ + assertEval "dynamic key interp" "let s = { x = 10; }; in \"${toString s.${\"x\"}}\"" (VStr "10" mempty) + ] + +testPhase4IO :: IO [Bool] +testPhase4IO = do + putStrLn "phase4/directory-import" + tmpDir <- getTemporaryDirectory + let testDir = tmpDir "nova-nix-phase4-test" + subDir = testDir "mypkg" + defaultNix = subDir "default.nix" + -- Create temp directory structure + createDirectoryIfMissing True subDir + TIO.writeFile defaultNix "42" + results <- + sequence + [ -- Directory import: import ./dir resolves to ./dir/default.nix + runTestM "import directory" $ do + result <- evalNixIO testDir ("import " <> T.pack "./mypkg") + pure $ case result of + Right (VInt 42) -> Pass + Right other -> Fail ("expected VInt 42, got " <> T.pack (show other)) + Left err -> Fail ("eval error: " <> err), + -- Search path with --nix-path equivalent (populated nixPath) + runTestM "search path with populated nixPath" $ do + st <- newEvalState platformStoreDir testDir + let nixPaths = parseNixPath (TE.encodeUtf8 ("mypkg=" <> T.pack subDir)) + env = builtinEnv unrestrictedPolicy (esTimestamp st) nixPaths + result <- runEvalIO st (eval env (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "mypkg"]))) + pure $ case result of + Right (VPath _) -> Pass + Right other -> Fail ("expected VPath, got " <> T.pack (show other)) + Left err -> Fail ("eval error: " <> err) + ] + -- Cleanup + removeDirectoryRecursive testDir + pure results + +-- | @builtins.toJSON@ of a path uses copy-to-store coercion (upstream +-- value-to-json.cc serializes paths with @copyToStore = true@): the JSON +-- text is the quoted source store path and the result carries its +-- context. EvalIO-only: PureEval has no store-path computation. +testToJSONPathIO :: IO [Bool] +testToJSONPathIO = do + putStrLn "eval/tojson-path-io" + tmpDir <- getTemporaryDirectory + let testDir = tmpDir "nova-nix-tojson-path-test" + createDirectoryIfMissing True testDir + TIO.writeFile (testDir "data.txt") "payload\n" + results <- + sequence + [ runTestM "toJSON of a path is its quoted store path with context" $ do + result <- evalNixIO testDir "builtins.toJSON ./data.txt" + pure $ case result of + Right (VStr json ctx) -> + if "\"/nix/store/" `BS.isPrefixOf` json + && "-data.txt\"" `BS.isSuffixOf` json + && ctx /= emptyContext + then Pass + else Fail ("expected a quoted store path with context, got " <> bytesText json) + Right other -> Fail ("expected VStr, got " <> T.pack (show other)) + Left err -> Fail ("eval error: " <> err) + ] + removeDirectoryRecursive testDir + pure results + +-- --------------------------------------------------------------------------- +-- Arena lifecycle guard (C FFI) +-- --------------------------------------------------------------------------- + +-- | The argument that turns this executable into the child of +-- 'testArenaGuard'. The child reaches the C layer with no 'arenaInit', +-- which the suite cannot do in its own process: 'main' brackets every +-- group, and a destroy-then-reinit cycle would invalidate the arena +-- pointers that process-lifetime CAFs already hold (#19). +arenaGuardChildFlag :: String +arenaGuardChildFlag = "--arena-guard-child" + +-- | One way a library user reaches the C layer, with what the child must +-- report for it. +data ArenaGuardPath = ArenaGuardPath + { -- | The child's argument. + guardName :: !String, + -- | The suite's name for the case. + guardClaim :: !Text, + -- | What the child must report. + guardOutcome :: !GuardOutcome, + -- | The child's body, run with no 'arenaInit' of its own. + guardAction :: !(IO ()) + } + +-- | What a guard child must report for its path. +data GuardOutcome + = -- | 'ArenaNotInitialized', naming this C entry point. + RefusedAt !Text + | -- | No exception: the path needs no arena. + Served + +-- | The line a guard child prints when its path raised nothing. +servedLine :: String +servedLine = "served without an exception" + +-- | The paths a library user reaches the C layer by. The first C call +-- of each of the first four lands in a different sub-arena, and the +-- fifth runs a full init .. destroy cycle first, so both ends of the +-- window are covered. The last two read the shared @null@, @true@ and +-- @false@ thunks, which must be valid in every window: were they arena +-- cells behind a process-lifetime CAF, forcing one outside the window +-- would poison it with 'ArenaNotInitialized' for every later arena, and +-- forcing one inside an arena would leave it pointing into memory the +-- next 'arenaDestroy' frees, a use-after-free the ASan job reports. +arenaGuardPaths :: [ArenaGuardPath] +arenaGuardPaths = + [ noArena "compile" "nn_bc_emit" evalIssueProgram, + noArena "thunk" "nn_thunk_new_computed_int" (void (evaluate (unThunk (evaluated (VInt 1))))), + noArena "symbol" "nn_symbol_intern" (void (evaluate (unThunk (evaluated (mkStr "a"))))), + noArena "env" "nn_env_alloc_slots" (void (evaluate (fst (buildCSlots [evaluated (VInt 1)])))), + noArena "after-destroy" "nn_bc_emit" (bracket_ arenaInit arenaDestroy (pure ()) >> evalIssueProgram), + ArenaGuardPath + { guardName = "constants-outside-window", + guardClaim = "the null, true and false thunks read correctly before arenaInit and in a later arena", + guardOutcome = Served, + guardAction = readConstants >> bracket_ arenaInit arenaDestroy readConstants + }, + ArenaGuardPath + { guardName = "constants-across-cycles", + guardClaim = "the null, true and false thunks read correctly across two init .. destroy cycles", + guardOutcome = Served, + guardAction = bracket_ arenaInit arenaDestroy readConstants >> bracket_ arenaInit arenaDestroy readConstants + } + ] + where + noArena name site = ArenaGuardPath name ("no arena: " <> T.pack name <> " raises ArenaNotInitialized at " <> site) (RefusedAt site) + -- The program from #206, forced to its result. + evalIssueProgram = case parseNix "/tmp" (SourceText "") "let x = 5; in x * 2 + 1" of + Left err -> throwIO (ErrorCall (show err)) + Right expr -> void (evaluate (runPureEval (eval (builtinEnv unrestrictedPolicy 0 []) expr))) + -- Read through the IO accessors: a pure read of a constant is itself + -- a constant GHC may share between the cycles, and the second would + -- then read nothing. A wrong cell is a broken outcome rather than the + -- guard under test, so it leaves the child by another exception. + readConstants = do + found <- mapM (readCell . unThunk . evaluated) [VNull, VBool True, VBool False] + unless (found == [(ThunkComputed, ValueNull, 0), (ThunkComputed, ValueBool, 1), (ThunkComputed, ValueBool, 0)]) $ + throwIO (ErrorCall ("the constants read back as " ++ show found)) + readCell ptr = (,,) <$> cthunkState ptr <*> cthunkValueTag ptr <*> cthunkGetBool ptr + +-- | Child body: run one path with no arena and print what it raised, or +-- 'servedLine'. Exit 0 either way; a segfault, a sanitizer report or +-- any other exception type surfaces as the process's own exit code. +arenaGuardChild :: String -> IO () +arenaGuardChild name = case [guardAction path | path <- arenaGuardPaths, guardName path == name] of + [action] -> do + outcome <- try action + putStrLn $ case outcome of + Left (err :: CStatusError) -> displayException err + Right () -> servedLine + _ -> hPutStrLn stderr ("unknown arena guard path: " ++ name) >> exitWith (ExitFailure 2) + +-- | @builtins.storePath@ resolves a path's symlinks unless the path is +-- itself a store path (primops.cc at 2.24.9), so a link outside the store +-- into it names its target. The links dangle on a runner with no store, +-- which upstream resolves the same way; Windows needs symlink privilege. +testStorePathLinksIO :: IO [Bool] +testStorePathLinksIO = do + putStrLn "eval/storepath-links-io" + canLink <- symlinksAvailable + if not canLink || SI.os == "mingw32" + then [] <$ putStrLn " SKIP needs POSIX symlinks" + else do + tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory + let dir = tmpBase "nova-nix-test-storepath-links" + target = "/nix/store/00000000000000000000000000000000-x" + through name = "builtins.storePath (/. + " <> nixQuotedPath (dir name) <> ")" + Dir.removePathForcibly dir + createDirectoryIfMissing True dir + Dir.createFileLink target (dir "path") + Dir.createFileLink (target <> "/bin") (dir "sub") + results <- + sequence + [ runTestIO "a link into the store names the store path" dir (through "path") (VStr (TE.encodeUtf8 (T.pack target)) (Context.plainContext (StorePath "00000000000000000000000000000000" "x"))), + runTestIO "a link to a subpath names the subpath" dir (through "sub") (VStr (TE.encodeUtf8 (T.pack (target <> "/bin"))) (Context.plainContext (StorePath "00000000000000000000000000000000" "x"))) + ] + Dir.removePathForcibly dir + pure results + +-- | A derivation attribute carrying another's drvPath brings that .drv's +-- whole closure into inputSrcs and inputDrvs, as upstream's +-- derivationStrict does (primops.cc at 2.24.9). Each drvPath is +-- nix-instantiate 2.24.9's. +testDeepContextClosureIO :: IO [Bool] +testDeepContextClosureIO = do + putStrLn "eval/deep-context-closure-io" + tmpBase <- getTemporaryDirectory + let plain name rest = "derivation { name = \"" <> name <> "\"; system = \"x\"; builder = \"/bin/sh\"; " <> rest <> "}" + drvPathOf bindings body = "builtins.unsafeDiscardStringContext (let " <> bindings <> " in " <> body <> ").drvPath" + a = "a = " <> plain "a" "" <> ";" + m = "m = " <> plain "m" "dep = a; " <> ";" + t = "t = " <> plain "t" "dep = m; " <> ";" + sequence + [ runTestIO "a drvPath brings its own .drv into inputSrcs" tmpBase (drvPathOf a (plain "b" "x = \"${a.drvPath}\"; ")) (mkStr "/nix/store/r3pz4ykyxg5s9f08fafcksw6bxfds40r-b.drv"), + runTestIO "a drvPath brings the .drv files it depends on" tmpBase (drvPathOf (a <> " " <> m) (plain "b" "x = \"${m.drvPath}\"; ")) (mkStr "/nix/store/00pfjcd57v5dd5j4w4zmsp3s8lcpv6wg-b.drv"), + runTestIO "the closure is followed to its end" tmpBase (drvPathOf (a <> " " <> m <> " " <> t) (plain "b" "x = \"${t.drvPath}\"; ")) (mkStr "/nix/store/f480ldqci72g5miaywmhljjlw1fg1y4i-b.drv") + ] + +-- | Run as a child, evaluate one expression under the IO evaluator, which +-- writes traces and warnings to stderr as it goes, then write its failure +-- to the same stream, so the parent reads them in the order they came. +evalChildFlag :: String +evalChildFlag = "--eval-child" + +evalChild :: String -> IO () +evalChild source = do + result <- evalNixIO "." (T.pack source) + either (\err -> hPutStrLn stderr ("error: " <> T.unpack err)) (const (pure ())) result + +-- | Evaluate the source in a child process running 'evalChild' and +-- compare the lines it wrote to stderr with the expected ones. +emits :: Text -> Text -> [Text] -> IO Bool +emits label source expected = runTestM label $ do + self <- getExecutablePath + (_, _, err) <- Proc.readCreateProcessWithExitCode (Proc.proc self [evalChildFlag, T.unpack source]) "" + pure (assertEqual label expected (T.lines (T.pack err))) + +-- | @deepSeq@, @trace@ and @warn@ finish with their first argument before +-- they force their second (primops.cc at 2.24.9), however the second +-- arrives. Each expected stream is nix-instantiate 2.24.9's: its trace +-- and warning lines, then the final error line. +testFirstArgumentOrderIO :: IO [Bool] +testFirstArgumentOrderIO = do + putStrLn "eval/first-argument-order-io" + sequence + [ emits "trace prints before its second argument fails" "builtins.trace \"hi\" (throw \"b\")" ["trace: hi", "error: b"], + emits "warn warns before its second argument fails" "builtins.warn \"w\" (throw \"b\")" ["evaluation warning: w", "error: b"], + emits "deepSeq forces its first argument deeply before its second" "builtins.deepSeq { a = throw \"a\"; } (throw \"b\")" ["error: a"], + emits "deepSeq applied to one argument first forces it on the second" "let f = builtins.deepSeq { a = throw \"a\"; }; in f (throw \"b\")" ["error: a"], + emits "deepSeq mapped over a list forces its first argument first" "builtins.elemAt (map (builtins.deepSeq { a = throw \"a\"; }) [ (throw \"b\") ]) 0" ["error: a"], + emits "trace inside deepSeq sees the forced value" "let x = { a = 1 + 1; }; in builtins.deepSeq x (builtins.trace x 1)" ["trace: { a = 2; }"] + ] + +-- | Without @trace-verbose@, upstream binds @builtins.traceVerbose@ to +-- @prim_second@ (primops.cc at 2.24.9), which forces and returns its +-- second argument and never forces its first, whether it is applied +-- directly, through a partial application, or to an element a +-- higher-order builtin passes unforced. The pure cases evaluate under +-- the default policy; the streams are what an IO evaluation writes to +-- stderr, where a trace would go. +testTraceVerboseOff :: IO [Bool] +testTraceVerboseOff = do + putStrLn "eval/trace-verbose-off" + sequence + [ runTest "traceVerbose returns its second argument without forcing its first" $ + assertEval "direct" "builtins.traceVerbose (throw \"a\") 1" (VInt 1), + runTest "traceVerbose applied to one argument is a partial application, its argument unforced" $ + assertEvalError + "partial" + "{} // builtins.traceVerbose (throw \"a\")" + "expected a set but found the partially applied built-in function 'traceVerbose': \x00ABpartially applied primop traceVerbose\x00BB", + runTest "traceVerbose's partial application mapped over a list leaves its argument unforced" $ + assertEval "mapped" "builtins.elemAt (map (builtins.traceVerbose (throw \"a\")) [ 1 ]) 0" (VInt 1), + runTest "traceVerbose given an unforced list element as its first argument leaves it unforced" $ + assertEval "unforced-element" "builtins.foldl' (acc: builtins.traceVerbose) 0 [ (throw \"a\") ] 5" (VInt 5), + runTest "traceVerbose forces its second argument" $ + assertEvalError "second" "builtins.traceVerbose 1 (throw \"b\")" "b", + emits "traceVerbose prints nothing" "builtins.traceVerbose \"hi\" 1" [], + emits "traceVerbose prints nothing before its second argument fails" "builtins.traceVerbose \"hi\" (throw \"b\")" ["error: b"] + ] + +-- | The smallest slot count whose byte size exceeds @UINT32_MAX@. +-- @nn_env_alloc_slots@ refuses it before touching a page, so inside a +-- live arena it fails without exhausting anything. +slotCountPastUInt32 :: Int +slotCountPastUInt32 = fromIntegral (maxBound :: Word32) `div` sizeOf (nullPtr :: Ptr ()) + 1 + +-- | One byte past the longest string the symbol table can hold. +symbolLengthPastUInt32 :: Int +symbolLengthPastUInt32 = fromIntegral (maxBound :: Word32) + 1 + +-- | Intern a ByteString whose length claims 'symbolLengthPastUInt32' +-- bytes over one real byte, so no 4 GiB buffer is needed. Sound only +-- because the interner refuses on the length before reading: an +-- interner that read would run out of bounds here. +internOversizedSymbol :: IO Symbol +internOversizedSymbol = + alloca $ \byte -> do + poke byte (0 :: CChar) + oversized <- BSU.unsafePackCStringLen (byte, symbolLengthPastUInt32) + symbolInternBytes oversized + +-- | Reaching the C layer outside the 'arenaInit' .. 'arenaDestroy' +-- window raises 'ArenaNotInitialized' naming the entry point, where +-- #206 reported a SIGSEGV. Each such path runs in a child process. +-- The live side of the same check runs in this process, under the +-- suite's bracket: a refusal with the arena up is 'CAllocationFailed'. +testArenaGuard :: IO [Bool] +testArenaGuard = do + putStrLn "arena/guard" + self <- getExecutablePath + children <- + mapM + ( \path -> runTestM (guardClaim path) $ do + (code, out, err) <- Proc.readCreateProcessWithExitCode (Proc.proc self [arenaGuardChildFlag, guardName path]) "" + let message = T.pack out + pure $ case (code, guardOutcome path) of + (ExitSuccess, RefusedAt site) + | "arenaInit" `T.isInfixOf` message && site `T.isInfixOf` message -> Pass + | otherwise -> Fail ("message does not name arenaInit and " <> site <> ": " <> message) + (ExitSuccess, Served) + | T.strip message == T.pack servedLine -> Pass + | otherwise -> Fail ("expected no exception, got: " <> message) + (ExitFailure n, _) -> Fail ("child exited " <> T.pack (show n) <> " (negative is a signal): " <> T.pack err) + ) + arenaGuardPaths + live <- + sequence + [ liveRefusal "a slot array past UINT32_MAX bytes" "nn_env_alloc_slots" (void (evaluate (allocCSlots slotCountPastUInt32))), + -- The list's items come from the same slot allocator, so the same + -- count is refused there and must surface as a list failure, where + -- the NULL it used to return read as the empty list. + liveRefusal "a list past UINT32_MAX slot bytes" "nn_list_new" (void (clistNew (fromIntegral slotCountPastUInt32))), + -- A length the entry's uint32_t cannot hold, refused rather than + -- truncated to alias a shorter string. + liveRefusal "a symbol longer than UINT32_MAX bytes" "nn_symbol_intern" (void internOversizedSymbol) + ] + tableIntact <- + runTestM "a refused symbol leaves the table unchanged" $ do + before <- symbolCount + _ <- try internOversizedSymbol :: IO (Either CStatusError Symbol) + after <- symbolCount + sym <- symbolIntern "after-a-refusal" + pure $ + if before == after && symbolText sym == "after-a-refusal" + then Pass + else Fail ("count " <> T.pack (show before) <> " -> " <> T.pack (show after) <> ", text " <> symbolText sym) + pure (children ++ live ++ [tableIntact]) + where + liveRefusal what site action = + runTestM ("live arena: " <> what <> " raises CAllocationFailed at " <> site) $ do + alive <- arenaLive + outcome <- try action + pure $ case (alive, outcome) of + (True, Left (CAllocationFailed refused _)) | refused == T.unpack site -> Pass + (True, Left err) -> Fail ("expected CAllocationFailed at " <> site <> ", got " <> T.pack (show err)) + (True, Right ()) -> Fail "no exception raised" + (False, _) -> Fail "arenaLive is False inside the suite's bracket" + +-- --------------------------------------------------------------------------- +-- Symbol interning (C FFI) +-- --------------------------------------------------------------------------- + +testSymbol :: IO [Bool] +testSymbol = do + putStrLn "symbol" + -- Symbol table is initialized by arenaInit in main bracket. + sequence + [ runTestM "intern returns non-zero" $ do + sym <- symbolIntern "hello" + pure (if unSymbol sym /= 0 then Pass else Fail "got symbol 0"), + runTestM "intern same string returns same symbol" $ do + sym1 <- symbolIntern "name" + sym2 <- symbolIntern "name" + pure (assertEqual "same symbol" sym1 sym2), + runTestM "intern different strings returns different symbols" $ do + sym1 <- symbolIntern "foo" + sym2 <- symbolIntern "bar" + pure (if sym1 /= sym2 then Pass else Fail "symbols should differ"), + runTestM "symbolText round-trips" $ do + sym <- symbolIntern "version" + let txt = symbolText sym + pure (assertEqual "text" "version" txt), + runTestM "symbolLen correct" $ do + sym <- symbolIntern "outputs" + pure (assertEqual "len" 7 (symbolLen sym)), + runTestM "empty string interns" $ do + sym <- symbolIntern "" + let txt = symbolText sym + pure (assertEqual "empty" "" txt), + runTestM "symbolCount tracks unique entries" $ do + _ <- symbolIntern "alpha" + _ <- symbolIntern "beta" + _ <- symbolIntern "alpha" + count <- symbolCount + -- count includes all symbols interned in this bracket, + -- so at least the ones from prior tests plus alpha + beta + pure (if count >= 2 then Pass else Fail ("count too low: " <> T.pack (show count))), + runTestM "many symbols (stress)" $ do + let names = map (\i -> "pkg_" <> T.pack (show (i :: Int))) [1 .. 1000] + syms <- mapM symbolIntern names + -- All unique + let unique = length (Set.fromList (map unSymbol syms)) + pure (assertEqual "1000 unique" 1000 unique) + ] + +-- --------------------------------------------------------------------------- +-- C attribute set (FFI) +-- --------------------------------------------------------------------------- + +-- | Cast a StablePtr to CThunkPtr for CAttrSet tests. +-- CAttrSet stores void* - we use StablePtrs as opaque values in tests. +spToCPtr :: StablePtr a -> CThunkPtr +spToCPtr = castPtr . castStablePtrToPtr + +-- | Cast a CThunkPtr back to StablePtr for CAttrSet test verification. +cptrToSp :: CThunkPtr -> StablePtr a +cptrToSp = castPtrToStablePtr . castPtr + +testCAttrSet :: IO [Bool] +testCAttrSet = do + putStrLn "cattrset" + -- Symbol table is initialized by arenaInit in main bracket. + sequence + [ runTestM "new/free" $ do + _set <- cattrsetNew 16 + -- set freed by arenaDestroy via nn_attrset_free_all + pure Pass, + runTestM "insert + freeze + lookup" $ do + set <- cattrsetNew 4 + kName <- symbolIntern "name" + kVer <- symbolIntern "version" + valName <- newStablePtr ("hello" :: Text) + valVer <- newStablePtr ("1.0" :: Text) + cattrsetInsert set kName noPos (spToCPtr valName) + cattrsetInsert set kVer noPos (spToCPtr valVer) + cattrsetFreeze set + result <- cattrsetLookup set kName + case result of + Nothing -> do + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr valName + freeStablePtr valVer + pure (Fail "lookup returned Nothing") + Just cptr -> do + val <- deRefStablePtr (cptrToSp cptr) :: IO Text + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr valName + freeStablePtr valVer + pure (assertEqual "lookup name" "hello" val), + runTestM "lookup missing key returns Nothing" $ do + set <- cattrsetNew 4 + kFoo <- symbolIntern "foo" + kBar <- symbolIntern "bar" + sp <- newStablePtr ("x" :: Text) + cattrsetInsert set kFoo noPos (spToCPtr sp) + cattrsetFreeze set + result <- cattrsetLookup set kBar + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr sp + pure (case result of Nothing -> Pass; Just _ -> Fail "expected Nothing"), + runTestM "size after freeze" $ do + set <- cattrsetNew 4 + k1 <- symbolIntern "a" + k2 <- symbolIntern "b" + k3 <- symbolIntern "c" + sp <- newStablePtr (42 :: Int) + cattrsetInsert set k1 noPos (spToCPtr sp) + cattrsetInsert set k2 noPos (spToCPtr sp) + cattrsetInsert set k3 noPos (spToCPtr sp) + cattrsetFreeze set + n <- cattrsetSize set + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr sp + pure (assertEqual "size" 3 n), + runTestM "duplicate keys: last writer wins" $ do + set <- cattrsetNew 4 + kName <- symbolIntern "name" + sp1 <- newStablePtr ("first" :: Text) + sp2 <- newStablePtr ("second" :: Text) + cattrsetInsert set kName noPos (spToCPtr sp1) + cattrsetInsert set kName noPos (spToCPtr sp2) + cattrsetFreeze set + n <- cattrsetSize set + result <- cattrsetLookup set kName + val <- case result of + Nothing -> pure "MISSING" + Just cptr -> deRefStablePtr (cptrToSp cptr) + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr sp1 + freeStablePtr sp2 + pure + ( if n == 1 && val == ("second" :: Text) + then Pass + else Fail ("size=" <> T.pack (show n) <> " val=" <> val) + ), + runTestM "keys returned sorted" $ do + set <- cattrsetNew 8 + -- Insert in reverse order; after freeze keys should be sorted by symbol ID + k1 <- symbolIntern "zzz" + k2 <- symbolIntern "aaa" + k3 <- symbolIntern "mmm" + sp <- newStablePtr (0 :: Int) + cattrsetInsert set k1 noPos (spToCPtr sp) + cattrsetInsert set k2 noPos (spToCPtr sp) + cattrsetInsert set k3 noPos (spToCPtr sp) + cattrsetFreeze set + keys <- cattrsetKeys set + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr sp + -- Keys should be sorted by symbol ID (ascending) + let ids = map unSymbol keys + sorted = ids == foldl (\acc x -> acc ++ [x]) [] (Set.toAscList (Set.fromList ids)) + pure (if sorted then Pass else Fail ("unsorted: " <> T.pack (show ids))), + runTestM "union right-biased" $ do + setA <- cattrsetNew 4 + setB <- cattrsetNew 4 + kX <- symbolIntern "x" + kY <- symbolIntern "y" + kZ <- symbolIntern "z" + spA <- newStablePtr ("fromA" :: Text) + spB <- newStablePtr ("fromB" :: Text) + spZ <- newStablePtr ("onlyA" :: Text) + cattrsetInsert setA kX noPos (spToCPtr spA) + cattrsetInsert setA kZ noPos (spToCPtr spZ) + cattrsetInsert setB kX noPos (spToCPtr spB) + cattrsetInsert setB kY noPos (spToCPtr spB) + cattrsetFreeze setA + cattrsetFreeze setB + merged <- cattrsetUnion setA setB + n <- cattrsetSize merged + resultX <- cattrsetLookup merged kX + valX <- case resultX of + Nothing -> pure "MISSING" + Just cptr -> deRefStablePtr (cptrToSp cptr) + -- sets freed by arenaDestroy via nn_attrset_free_all + freeStablePtr spA + freeStablePtr spB + freeStablePtr spZ + pure + ( if n == 3 && valX == ("fromB" :: Text) + then Pass + else Fail ("size=" <> T.pack (show n) <> " x=" <> valX) + ), + runTestM "stress: 10k entries" $ do + set <- cattrsetNew 1024 + sp <- newStablePtr (0 :: Int) + syms <- mapM (\i -> symbolIntern ("key_" <> T.pack (show (i :: Int)))) [1 .. 10000] + mapM_ (\sym -> cattrsetInsert set sym noPos (spToCPtr sp)) syms + cattrsetFreeze set + n <- cattrsetSize set + -- Spot-check a lookup from the middle of the key range + hit <- case drop 5000 syms of + middleSym : _ -> cattrsetLookup set middleSym + [] -> pure Nothing + -- set freed by arenaDestroy via nn_attrset_free_all + freeStablePtr sp + pure + ( if n == 10000 && isJust hit + then Pass + else Fail ("size=" <> T.pack (show n)) + ), + -- Grown from the default capacity, so every doubling runs; the + -- index of an absent key is the C side's NN_ATTRSET_NOT_FOUND. + runTestM "index finds each key at its sorted position and none for an absent key" $ do + set <- cattrsetNew 0 + sp <- newStablePtr (0 :: Int) + syms <- mapM (\i -> symbolIntern ("index_" <> T.pack (show (i :: Int)))) [1 .. 100] + mapM_ (\sym -> cattrsetInsert set sym noPos (spToCPtr sp)) syms + cattrsetFreeze set + absent <- symbolIntern "index_absent" + found <- mapM (cattrsetIndex set) (sort syms) + missing <- cattrsetIndex set absent + freeStablePtr sp + pure + ( if found == map Just [0 .. 99] && isNothing missing + then Pass + else Fail ("found=" <> T.pack (show found) <> " missing=" <> T.pack (show missing)) + ), + -- A position travels with its entry: through both sorts freeze uses + -- (insertion up to 64 entries, the tagged sort past that), the dedup + -- that keeps a key's last insert, the growth from the default + -- capacity that moves the positions within their block, a union + -- that keeps the right side's on a clash, and a key removal. The + -- pool is small enough that inserts repeat keys and large enough to + -- pass the 64-entry switch. + runTestM "positions follow their entries through freeze, union and removal" $ do + pool <- mapM (\i -> symbolIntern ("pos_" <> T.pack (show (i :: Int)))) [1 .. 100] + sp <- newStablePtr (0 :: Int) + let genInserts = QC.listOf ((,) <$> QC.elements pool <*> QC.arbitrary) + build inserts = do + set <- cattrsetNew 0 + mapM_ (\(key, pos) -> cattrsetInsert set key (PosIdx pos) (spToCPtr sp)) inserts + cattrsetFreeze set + pure set + property = + QC.forAll (QC.resize 200 ((,,) <$> genInserts <*> genInserts <*> QC.sublistOf pool)) $ \(left, right, removed) -> + QC.ioProperty $ do + leftSet <- build left + rightSet <- build right + merged <- cattrsetUnion leftSet rightSet + kept <- cattrsetRemoveKeys leftSet removed + actual <- mapM entryPositions [leftSet, merged, kept] + let leftModel = Map.fromList left + rightModel = Map.fromList right + pure (actual QC.=== [leftModel, Map.union rightModel leftModel, Map.withoutKeys leftModel (Set.fromList removed)]) + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + -- sets freed by arenaDestroy via nn_attrset_free_all + freeStablePtr sp + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + where + entryPositions set = do + n <- cattrsetSize set + entries <- mapM (\i -> (,) <$> cattrsetGetKey set i <*> (unPosIdx <$> cattrsetGetPos set i)) (takeWhile (< n) [0 ..]) + pure (Map.fromList entries) + +-- --------------------------------------------------------------------------- +-- C thunk arena (FFI) +-- --------------------------------------------------------------------------- + +testCThunk :: IO [Bool] +testCThunk = do + putStrLn "cthunk" + -- Arena is already initialized by main's bracket. + -- Each test uses the shared arena (thunks accumulate - that's fine). + sequence + [ runTestM "new pending + state" $ do + sp <- newStablePtr ("pending" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) + state <- cthunkState ptr + pure (assertEqual "state" 0 state), + runTestM "new computed + state" $ do + sp <- newStablePtr ("computed" :: Text) + ptr <- cthunkNewComputed (castStablePtrToPtr sp) + state <- cthunkState ptr + pure (assertEqual "state" 1 state), + runTestM "payload round-trips (pending)" $ do + sp <- newStablePtr ("hello" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) + payload <- cthunkPayload ptr + val <- deRefStablePtr (castPtrToStablePtr payload) :: IO Text + pure (assertEqual "payload" "hello" val), + runTestM "payload round-trips (computed)" $ do + sp <- newStablePtr (42 :: Int) + ptr <- cthunkNewComputed (castStablePtrToPtr sp) + payload <- cthunkPayload ptr + val <- deRefStablePtr (castPtrToStablePtr payload) :: IO Int + pure (assertEqual "payload" 42 val), + runTestM "mark_blackhole succeeds on pending" $ do + sp <- newStablePtr ("x" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) + ok <- cthunkMarkBlackhole ptr + state <- cthunkState ptr + pure + ( if ok && state == 2 + then Pass + else Fail ("ok=" <> T.pack (show ok) <> " state=" <> T.pack (show state)) + ), + runTestM "mark_blackhole fails on computed" $ do + sp <- newStablePtr ("x" :: Text) + ptr <- cthunkNewComputed (castStablePtrToPtr sp) + ok <- cthunkMarkBlackhole ptr + pure (if not ok then Pass else Fail "should have failed"), + runTestM "mark_blackhole fails on blackhole" $ do + sp <- newStablePtr ("x" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) + _ <- cthunkMarkBlackhole ptr + ok <- cthunkMarkBlackhole ptr + pure (if not ok then Pass else Fail "should have failed"), + runTestM "set_computed stores into a blackhole" $ do + pendingSp <- newStablePtr ("old" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr pendingSp) + _ <- cthunkMarkBlackhole ptr + computedSp <- newStablePtr ("new" :: Text) + stored <- cthunkSetComputed ptr (castStablePtrToPtr computedSp) + state <- cthunkState ptr + newPayload <- cthunkPayload ptr + newVal <- deRefStablePtr (castPtrToStablePtr newPayload) :: IO Text + freeStablePtr pendingSp + pure + ( if stored && newVal == "new" && state == 1 + then Pass + else Fail ("stored=" <> T.pack (show stored) <> " new=" <> newVal <> " state=" <> T.pack (show state)) + ), + -- set_computed accepts PENDING (direct memoization, no blackhole step) + runTestM "set_computed stores into a pending thunk" $ do + sp <- newStablePtr ("x" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) + valSp <- newStablePtr ("v" :: Text) + stored <- cthunkSetComputed ptr (castStablePtrToPtr valSp) + freeStablePtr sp + pure (if stored then Pass else Fail "refused a PENDING thunk"), + runTestM "set_computed refuses a computed thunk and keeps its value" $ do + firstSp <- newStablePtr ("first" :: Text) + ptr <- cthunkNewComputed (castStablePtrToPtr firstSp) + secondSp <- newStablePtr ("second" :: Text) + stored <- cthunkSetComputed ptr (castStablePtrToPtr secondSp) + payload <- cthunkPayload ptr + kept <- deRefStablePtr (castPtrToStablePtr payload) :: IO Text + freeStablePtr secondSp + pure + ( if not stored && kept == "first" + then Pass + else Fail ("stored=" <> T.pack (show stored) <> " kept=" <> kept) + ), + -- The shared cells are one static each for the whole process, so a + -- transition that ran on one would change every null or boolean. + runTestM "the shared null and boolean cells refuse every transition" $ do + let cells = [cthunkNull, cthunkBool True, cthunkBool False] + marked <- mapM cthunkMarkBlackhole cells + stored <- mapM (`cthunkSetComputed` nullPtr) cells + repointed <- mapM (`cthunkSetPayload` nullPtr) cells + let values = map (readThunkValue . Thunk) cells + expected = map Just [VNull, VBool True, VBool False] + pure + ( if not (or (marked ++ stored ++ repointed)) && values == expected + then Pass + else Fail ("accepted=" <> T.pack (show (marked, stored, repointed)) <> " values=" <> T.pack (show values)) + ), + runTestM "count tracks allocations" $ do + countBefore <- cthunkCount + sp <- newStablePtr (0 :: Int) + _ <- cthunkNewBc 0 (castStablePtrToPtr sp) + _ <- cthunkNewBc 0 (castStablePtrToPtr sp) + _ <- cthunkNewComputed (castStablePtrToPtr sp) + countAfter <- cthunkCount + let delta = countAfter - countBefore + pure (assertEqual "delta" 3 delta), + runTestM "get retrieves by index" $ do + countBefore <- cthunkCount + sp <- newStablePtr ("indexed" :: Text) + ptr <- cthunkNewBc 0 (castStablePtrToPtr sp) + retrieved <- cthunkGet countBefore + stateOrig <- cthunkState ptr + stateRetrieved <- cthunkState retrieved + pure + ( if ptr == retrieved && stateOrig == stateRetrieved + then Pass + else Fail "get returned wrong pointer" + ), + runTestM "stress: 100k thunks" $ do + countBefore <- cthunkCount + sp <- newStablePtr (0 :: Int) + mapM_ (\_ -> cthunkNewBc 0 (castStablePtrToPtr sp)) [(1 :: Int) .. 100000] + countAfter <- cthunkCount + let delta = countAfter - countBefore + -- Spot-check: retrieve one from the middle + midPtr <- cthunkGet (countBefore + 50000) + midState <- cthunkState midPtr + pure + ( if delta == 100000 && midState == 0 + then Pass + else + Fail + ( "delta=" + <> T.pack (show delta) + <> " midState=" + <> T.pack (show midState) + ) + ) + ] + +-- --------------------------------------------------------------------------- +-- Bytecode compilation tests +-- --------------------------------------------------------------------------- + +-- --------------------------------------------------------------------------- +-- Tests: upstream conformance follow-ups (#50) +-- --------------------------------------------------------------------------- + +-- | Error kind for 'StubStoreEval', mirroring PureEval's split: only a +-- throw/assert is tryEval-catchable. +data StubErr = StubThrow !Text | StubOther !Text + +-- | Pure evaluator over a stubbed store: 'readStoreDerivation' serves +-- derivations from a fixed map (keyed by canonical @.drv@ path text); +-- everything else behaves like 'PureEval'. Exercises the +-- input-derivation-modulo STORE-READ arm hermetically - the real arm +-- reads the platform store, which dev machines and CI runners must not +-- depend on (the build matrix has no writable @/nix/store@). +newtype StubStoreEval a = StubStoreEval (StubEnv -> Either StubErr a) + +-- | What the stubbed store answers from. +data StubEnv = StubEnv + { -- | Derivations 'readStoreDerivation' serves, by canonical @.drv@ path. + seDrvs :: !(Map.Map Text Derivation), + -- | Recorded fetches 'lookupFetchCache' serves, by key. + seFetchCache :: !(Map.Map Text Text), + -- | Store paths 'adoptStorePath' accepts. Deliberately NOT the same + -- answer as 'doesPathExist', which is 'False' throughout: on disk and + -- registered are different facts, and a test where the two coincide + -- cannot tell which one the code under test asked about. + seAdoptable :: !(Set.Set Text), + -- | The store directory 'qualifyPath' names paths against. + seStoreDir :: !StoreDir + } + +-- | A stub store holding nothing but the given derivations, at the +-- default store directory. +stubEnv :: Map.Map Text Derivation -> StubEnv +stubEnv drvs = StubEnv {seDrvs = drvs, seFetchCache = Map.empty, seAdoptable = Set.empty, seStoreDir = defaultStoreDir} + +runStubStoreEvalWith :: StubEnv -> StubStoreEval a -> Either Text a +runStubStoreEvalWith env (StubStoreEval action) = case action env of + Left (StubThrow msg) -> Left msg + Left (StubOther msg) -> Left msg + Right val -> Right val + +instance Functor StubStoreEval where + fmap f (StubStoreEval g) = StubStoreEval (fmap f . g) + +instance Applicative StubStoreEval where + pure val = StubStoreEval (const (Right val)) + StubStoreEval mf <*> StubStoreEval ma = StubStoreEval $ \env -> mf env <*> ma env + +instance Monad StubStoreEval where + StubStoreEval ma >>= f = StubStoreEval $ \env -> case ma env of + Left err -> Left err + Right val -> let StubStoreEval mb = f val in mb env + +instance MonadEval StubStoreEval where + throwEvalError msg = StubStoreEval (const (Left (StubOther msg))) + throwCatchableError msg = StubStoreEval (const (Left (StubThrow msg))) + abortEvaluation msg = StubStoreEval (const (Left (StubOther ("evaluation aborted: " <> msg)))) + catchEvalError (StubStoreEval action) = StubStoreEval $ \env -> case action env of + Left (StubThrow msg) -> Right (Left msg) + Left other -> Left other + Right val -> Right (Right val) + onEvalError (StubStoreEval action) _ = StubStoreEval action + addErrorTrace _ action = action + + -- The stub keeps no call depth: it exists to answer store questions, + -- and the ceiling is tested on the evaluators that enforce it. + withCallFrame (StubStoreEval action) = StubStoreEval action + doesPathExist _ _ = pure False + listDirectory _ = throwEvalError "readDir: not available in the stub evaluator" + importFile _ = throwEvalError "import: not available in the stub evaluator" + getEnvVar _ = pure "" + getCurrentTime = pure 0 + writeToStore _ _ _ = throwEvalError "toFile: not available in the stub evaluator" + scopedImportFile _ _ = throwEvalError "scopedImport: not available in the stub evaluator" + readFileBytes _ = throwEvalError "readFile: not available in the stub evaluator" + getFileType _ = throwEvalError "readFileType: not available in the stub evaluator" + runProcess _ _ _ = throwEvalError "runProcess: not available in the stub evaluator" + createScratchDir _ = throwEvalError "createScratchDir: not available in the stub evaluator" + removeScratchDir _ = pure () + copyPathToStore _ _ _ = throwEvalError "builtins.path: not available in the stub evaluator" + narHashOfPath _ = throwEvalError "builtins.fetchGit: not available in the stub evaluator" + setExecutableFile _ = throwEvalError "builtins.fetchGit: not available in the stub evaluator" + lookupFetchCache key = StubStoreEval $ \env -> Right (Map.lookup key (seFetchCache env)) + adoptStorePath path = StubStoreEval $ \env -> Right (Set.member path (seAdoptable env)) + writeFetchCache _ _ = pure () + isExecutableFile _ = throwEvalError "builtins.path: not available in the stub evaluator" + readSymlinkTarget _ = throwEvalError "builtins.path: not available in the stub evaluator" + resolveSymlinks = pure + addSourceNar _ _ = throwEvalError "builtins.path: not available in the stub evaluator" + addFixedOutputFile _ _ = throwEvalError "builtins.fetchurl: not available in the stub evaluator" + traceMessage _ = pure () + lookupDrvHash _ = pure Nothing + cacheDrvHash _ _ = pure () + recordDrvAterm _ _ = pure () + readStoreDerivation sp = + StubStoreEval $ \env -> Right (Map.lookup (storePathToText defaultStoreDir sp) (seDrvs env)) + lookupSessionDrv _ = pure Nothing + lookupSessionReferences _ = pure Nothing + storeSourcePath = pure + evalPolicy = pure unrestrictedPolicy + checkUri _ = pure () + qualifyPath path = StubStoreEval $ \env -> Right (qualifyPathText (seStoreDir env) path) + resolvePathLiteral = pure . canonPath + forceThunk evalFn thunk@(Thunk ptr) = case readThunkValue thunk of + Just val -> pure val + Nothing -> case unsafePerformIO (cthunkState ptr) of + 2 {- BLACKHOLE -} -> abortEvaluation "infinite recursion encountered" + _ {- PENDING -} -> + let bcIdx = unsafePerformIO (cthunkGetBcIdx ptr) + envSp = unsafePerformIO (cthunkPayload ptr) + env = unsafePerformIO (deRefStablePtr (castPtrToStablePtr envSp)) + in evalFn env bcIdx + +-- | Parse and evaluate under the stubbed-store evaluator. +evalNixStub :: Map.Map Text Derivation -> Text -> Either Text NixValue +evalNixStub = evalNixStubWith . stubEnv + +-- | 'evalNixStub' with the whole stub store spelled out. +evalNixStubWith :: StubEnv -> Text -> Either Text NixValue +evalNixStubWith env source = case parseNix testBaseDir testOrigin (TE.encodeUtf8 source) of + Left err -> Left (T.pack (show err)) + Right expr -> runStubStoreEvalWith env (eval (builtinEnv unrestrictedPolicy 0 []) expr) + +-- | Upstream conformance follow-ups (#50): behaviors that landed +-- with #37 but had no direct test. Pure cases here; filesystem-touching +-- cases in 'testClassIFollowupsIO'. +testClassIFollowups :: IO [Bool] +testClassIFollowups = do + putStrLn "eval/class-i-followups" + let storeA = "/nix/store/" <> T.replicate 32 "a" + enclosingCtx = StringContext (Set.singleton (SCPlain (StorePath (T.replicate 32 "a") "x"))) + sequence + [ -- path + path concatenates the spellings and canonicalizes + runTest "path + path canonicalizes the joined spelling" $ + assertEval "pp-canon" "builtins.toString (/a/b + /c/../d)" (mkStr "/a/b/d"), + -- concatStringsSep coerces a path element; an in-store path takes + -- the short-circuit (itself + enclosing context, no store copy) + runTest "concatStringsSep coerces an in-store path element" $ + assertEval + "csep-path" + ("builtins.concatStringsSep \":\" [ " <> storeA <> "-x \"y\" ]") + (VStr (TE.encodeUtf8 (storeA <> "-x:y")) enclosingCtx), + runTest "substring and unsafeDiscardOutputDependency keep a coerced path's context" $ + assertEval "substring-store-path" ("builtins.substring 0 10 " <> storeA <> "-x") (VStr "/nix/store" enclosingCtx) + `andThen` assertEval + "discard-output-store-path" + ("builtins.unsafeDiscardOutputDependency " <> storeA <> "-x") + (VStr (TE.encodeUtf8 (storeA <> "-x")) enclosingCtx), + runTest "addDrvOutputDependencies judges a coerced path by its context" $ + assertEvalError + "add-output-store-path" + ("builtins.addDrvOutputDependencies " <> storeA <> "-x") + ("builtins.addDrvOutputDependencies: path " <> storeA <> "-x is not a derivation"), + -- the same in-store short-circuit for general interpolation, on a + -- SUBPATH: the text is the subpath, the context the enclosing path + runTest "interpolating an in-store subpath keeps text, contexts the enclosing path" $ + assertEval + "interp-substore" + ("\"${" <> storeA <> "-x/sub}\"") + (VStr (TE.encodeUtf8 (storeA <> "-x/sub")) enclosingCtx), + -- storePath on a subpath: value text is the subpath itself + runTest "storePath on a subpath keeps text, contexts the enclosing path" $ + assertEval + "storepath-sub" + ("builtins.storePath " <> storeA <> "-x/sub/file") + (VStr (TE.encodeUtf8 (storeA <> "-x/sub/file")) enclosingCtx), + runTest "fromJSON falls to float past uint64" $ + assertEval "fromjson-float" "builtins.fromJSON \"18446744073709551616\"" (VFloat 18446744073709551616.0), + -- the input-derivation-modulo STORE-READ arm: a dependent whose + -- input .drv was NOT evaluated in-session resolves by reading the + -- (stubbed) store, and lands on the same drvPath as the in-session + -- cache-hit arm computes for the identical derivation + runTestM "input modulo recurses through the store read (stub store)" $ do + let depSrc = "derivation { name = \"dep\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }" + tmpBase <- getTemporaryDirectory + depDrv <- evalDerivationIO tmpBase depSrc >>= either (fail . ("dep: " <>) . T.unpack) pure + depPath <- case evalNix ("(" <> depSrc <> ").drvPath") of + Right (VStr p _) -> pure (bytesText p) + other -> fail ("dep.drvPath: " <> show other) + let stubResult = + evalNixStub (Map.singleton depPath depDrv) $ + T.concat + [ "(derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ", + "input = builtins.appendContext \"x\" { \"", + depPath, + "\" = { outputs = [\"out\"]; }; }; }).drvPath" + ] + ioResult <- + evalNixIO tmpBase $ + T.concat + [ "let dep = ", + depSrc, + "; in (derivation { name = \"main\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; ", + "input = builtins.appendContext \"x\" { \"${dep.drvPath}\" = { outputs = [\"out\"]; }; }; }).drvPath" + ] + pure $ case (stubResult, ioResult) of + (Right (VStr a _), Right (VStr b _)) + | a == b -> Pass + | otherwise -> + Fail ("store-read and in-session arms disagree: " <> bytesText a <> " vs " <> bytesText b) + other -> Fail ("expected two drvPaths, got: " <> T.pack (show other)) + ] + +-- | Filesystem-touching conformance follow-ups (#50). +testClassIFollowupsIO :: IO [Bool] +testClassIFollowupsIO = do + putStrLn "eval/class-i-followups-io" + tmpDir <- getTemporaryDirectory + let testDir = tmpDir "nova-nix-classi-test" + testDirFwd = T.replace "\\" "/" (T.pack testDir) + bracket_ + ( do + createDirectoryIfMissing True (testDir "sub") + TIO.writeFile (testDir "target.txt") "hit\n" + TIO.writeFile (testDir "thefile") "payload\n" + -- Imported files for the two path-resolution tests below. Each is + -- a directory deeper than the expression that names it, so a + -- literal resolved against the wrong one is visibly wrong. + TIO.writeFile (testDir "sub" "useq.nix") "q\n" + TIO.writeFile (testDir "sub" "tilde.nix") "~/nova-tilde-probe\n" + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ -- ~/ expands against the home directory at path resolution + runTestM "tilde path literal expands against the home directory" $ do + home <- Dir.getHomeDirectory + result <- evalNixIO testDir "builtins.toString ~/nova-tilde-probe" + let expected = canonPathValue (T.pack (home "nova-tilde-probe")) + pure $ assertRight "tilde" result $ \val -> + assertEqual "tilde-expanded" (mkStr expected) val, + -- The same literal inside an imported file. Path resolution runs + -- over every parsed file now, and joining ~/x to the importing + -- directory would bury the tilde where nothing expands it. + runTestM "tilde path literal expands the same inside an imported file" $ do + home <- Dir.getHomeDirectory + result <- evalNixIO testDir "builtins.toString (import ./sub/tilde.nix)" + let expected = canonPathValue (T.pack (home "nova-tilde-probe")) + pure $ assertRight "tilde-import" result $ \val -> + assertEqual "tilde-expanded-in-import" (mkStr expected) val, + -- A path literal names a location relative to the file it is + -- written in. This one is written here and forced during the + -- evaluation of sub/useq.nix, where the base directory is sub/: + -- resolving on force rather than on parse gave sub/target.txt. + runTestM "a path literal resolves where it is written, not where it is forced" $ do + let expr = "builtins.toString (builtins.scopedImport { q = ./target.txt; } ./sub/useq.nix)" + result <- evalNixIO testDir expr + let expected = canonPathValue (T.pack (testDir "target.txt")) + pure $ assertRight "scoped-import-path" result $ \val -> + assertEqual "resolved-against-writing-file" (mkStr expected) val, + -- a search-path match is returned CANONICALIZED + runTestM "findFile canonicalizes the matched candidate" $ do + result <- + evalNixIO testDir $ + T.concat + ["builtins.findFile [ { prefix = \"\"; path = \"", testDirFwd, "/sub/..\"; } ] \"target.txt\""] + pure $ assertRight "findfile-canon" result $ \val -> + assertEqual "canonical" (VPath (testDirFwd <> "/target.txt")) val, + -- the store copy is named by canonBaseName (the path's last segment) + runTestM "source copy is named by canonBaseName" $ do + result <- evalNixIO testDir "\"${./thefile}\"" + pure $ assertRight "canonbase" result $ \case + VStr s ctx -> + if "/nix/store/" `BS.isPrefixOf` s && "-thefile" `BS.isSuffixOf` s && ctx /= emptyContext + then Pass + else Fail ("expected a store path named -thefile with context, got " <> bytesText s) + other -> Fail ("expected VStr, got " <> T.pack (show other)), + -- canonBaseName's empty-name arm: the filesystem root has no + -- base name to copy under, refused before any read. POSIX only: + -- a root path literal on Windows names a drive. + if SI.os == "mingw32" + then True <$ putStrLn " SKIP coercing the filesystem root errors (no base name): the root is a drive" + else runTestM "coercing the filesystem root errors (no base name)" $ do + result <- evalNixIO testDir "\"${/.}\"" + pure $ case result of + Left err | "no base name" `T.isInfixOf` err -> Pass + Left err -> Fail ("expected a base-name error, got: " <> err) + Right val -> Fail ("expected failure, got " <> T.pack (show val)) + ] + +-- | Bytecode short_arg spill: op-level payload counts at or above the +-- 0xFFFF sentinel move to the first data word, so literals are no longer +-- capped at 65535 elements. The two exact-boundary list cases pin the +-- inline maximum (65534) and the first spilled count (65535); the rest +-- drive each counted-op kind (list, attrs, let, string parts, attr path) +-- well past the old ceiling. +-- --------------------------------------------------------------------------- +-- Bytecode shared across elements +-- --------------------------------------------------------------------------- + +-- | A bytecode instruction as far as the reserved instructions use them: a +-- resolved variable (level, slot), a deferred application, or anything +-- else (opcode, flags). +data CodeShape + = SlotRef !Word32 !Word32 + | DeferredApp !CodeShape !CodeShape + | OtherCode !Word8 !Word8 + deriving (Eq, Show) + +-- | Read the code at a bytecode index back as a 'CodeShape'. +codeShape :: Word32 -> IO CodeShape +codeShape idx = do + op <- cbcOpcode idx + flags <- cbcFlags idx + arg1 <- cbcArg1 idx + arg2 <- cbcArg2 idx + case op of + OpResolvedVar -> pure (SlotRef arg1 arg2) + OpApp | flags == appDeferred -> DeferredApp <$> codeShape arg1 <*> codeShape arg2 + _ -> pure (OtherCode op flags) + +-- | The instructions and data words evaluating a source adds to the +-- bytecode store, which only 'arenaDestroy' frees. The source must +-- evaluate to an integer computed from everything it builds, so each +-- element has been forced when the counts are read. +bytecodeGrowth :: Text -> IO (Either Text (Word32, Word32)) +bytecodeGrowth source = do + opsBefore <- cbcOpCount + dataBefore <- cbcDataCount + forced <- case evalNix source of + Right (VInt n) -> Right <$> evaluate n + Right other -> pure (Left ("expected an integer, got " <> T.pack (show other))) + Left err -> pure (Left err) + opsAfter <- cbcOpCount + dataAfter <- cbcDataCount + pure ((opsAfter - opsBefore, dataAfter - dataBefore) <$ forced) + +-- | A source builds one element or two hundred, and the bytecode it adds +-- is the same: the code each element runs is shared, never compiled per +-- element. A first run at one element is discarded, so anything compiled +-- once per process is not counted against either size. +assertNoPerElementBytecode :: (Text -> Text) -> IO TestResult +assertNoPerElementBytecode sourceFor = do + _ <- bytecodeGrowth (sourceFor "1") + one <- bytecodeGrowth (sourceFor "1") + many <- bytecodeGrowth (sourceFor "200") + pure $ case (one, many) of + (Right atOne, Right atMany) -> + assertEqual "instructions and data words added at 1 element and at 200" atOne atMany + (Left err, _) -> Fail err + (_, Left err) -> Fail err + +testBytecodePerElement :: IO [Bool] +testBytecodePerElement = do + putStrLn "bytecode/per-element" + let summed body n = "builtins.foldl' (a: b: a + b) 0 (" <> body n <> ")" + indices n = "builtins.genList (i: i) " <> n + sequence + [ runTestM "reserved instructions are the deferred applications of the slots" $ do + apply1 <- codeShape reservedApply1 + apply2 <- codeShape reservedApply2 + apply2Function <- cbcArg1 reservedApply2 + pure $ + assertEqual "reservedApply1" (DeferredApp (SlotRef 0 0) (SlotRef 0 1)) apply1 + `andThen` assertEqual "reservedApply2" (DeferredApp (DeferredApp (SlotRef 0 0) (SlotRef 0 1)) (SlotRef 0 2)) apply2 + `andThen` assertEqual "reservedApply2's function" reservedApply1 apply2Function, + runTestM "map adds no bytecode per element" $ + assertNoPerElementBytecode (summed (\n -> "builtins.map (x: x + 1) (" <> indices n <> ")")), + runTestM "genList adds no bytecode per element" $ + assertNoPerElementBytecode (summed ("builtins.genList (i: i * 2) " <>)), + runTestM "concatMap adds no bytecode per element" $ + assertNoPerElementBytecode (summed (\n -> "builtins.concatMap (x: [ x x ]) (" <> indices n <> ")")), + runTestM "mapAttrs adds no bytecode per attribute" $ + assertNoPerElementBytecode + ( summed + (\n -> "builtins.attrValues (builtins.mapAttrs (name: v: v + 1) (builtins.listToAttrs (builtins.genList (i: { name = toString i; value = i; }) " <> n <> ")))") + ), + runTestM "zipAttrsWith adds no bytecode per attribute" $ + assertNoPerElementBytecode + ( summed + (\n -> "builtins.attrValues (builtins.zipAttrsWith (name: vs: builtins.length vs) (builtins.genList (i: { ${toString i} = i; }) " <> n <> "))") + ), + runTestM "inherit (from) in an attr set adds no bytecode per evaluation" $ + assertNoPerElementBytecode (summed ("builtins.genList (i: { inherit ({ v = i; }) v; }.v) " <>)), + runTestM "inherit (from) in a recursive attr set adds no bytecode per evaluation" $ + assertNoPerElementBytecode (summed ("builtins.genList (i: rec { inherit ({ v = i; }) v; }.v) " <>)), + runTestM "inherit (from) in a let adds no bytecode per evaluation" $ + assertNoPerElementBytecode (summed ("builtins.genList (i: let inherit ({ v = i; }) v; in v) " <>)) + ] + +testBytecodeCountSpill :: IO [Bool] +testBytecodeCountSpill = do + putStrLn "bytecode/count-spill" + let listOf n = "builtins.length [ " <> T.unwords (replicate n "1") <> " ]" + bigAttrsBody = T.concat [T.pack ("a" <> show i <> " = " <> show i <> "; ") | i <- [0 :: Int .. 69999]] + sequence + [ runTest "list literal at the inline count maximum (65534)" $ + assertEval "spill-list-inline-max" (listOf 65534) (VInt 65534), + runTest "list literal at the first spilled count (65535)" $ + assertEval "spill-list-first-spill" (listOf 65535) (VInt 65535), + runTest "spilled list preserves element order" $ + assertEval + "spill-list-order" + ("builtins.elemAt [ " <> T.unwords (map (T.pack . show) [0 :: Int .. 69999]) <> " ] 69999") + (VInt 69999), + runTest "spilled attrset literal binds every attribute" $ + assertEval + "spill-attrs-count" + ("builtins.length (builtins.attrNames { " <> bigAttrsBody <> "})") + (VInt 70000), + runTest "spilled attrset lookup reads the right value" $ + assertEval + "spill-attrs-lookup" + ("{ " <> bigAttrsBody <> "}.a69999") + (VInt 69999), + runTest "spilled let binds every name" $ + assertEval + "spill-let" + ("let " <> T.concat [T.pack ("v" <> show i <> " = " <> show i <> "; ") | i <- [0 :: Int .. 69999]] <> "in v69999") + (VInt 69999), + runTest "spilled interpolated string keeps every part" $ + assertEval + "spill-string-parts" + ("builtins.stringLength \"" <> T.concat (replicate 70000 "${\"x\"}") <> "\"") + (VInt 70000), + runTest "spilled attr path walks (set ? long.path)" $ + assertEval + "spill-attrpath" + ("{ } ? " <> T.intercalate "." (map (\i -> T.pack ("p" <> show i)) [0 :: Int .. 69999])) + (VBool False) + ] + +-- | C value structs carry element counts as a full uint32; a narrower +-- count would wrap at 65536 and size the C array smaller than the fill +-- loop that follows it. Both cases marshal counts past that boundary +-- and force the value twice - the first force writes the C struct (the +-- marshal side), the second reads it back off the computed thunk cell +-- (the unmarshal side). +testValueCountWidths :: IO [Bool] +testValueCountWidths = do + putStrLn "value/count-widths" + let formalsBody = T.intercalate ", " [T.pack ("a" <> show i) | i <- [0 :: Int .. 69999]] + sequence + [ runTest "lambda with 70000 formals round-trips through the C closure" $ + assertEval + "width-lambda-formals" + ( "let f = { " + <> formalsBody + <> " }: 1; in builtins.seq (builtins.functionArgs f) (builtins.length (builtins.attrNames (builtins.functionArgs f)))" + ) + (VInt 70000), + runTest "string context with 70000 elements round-trips through the C thunk" $ + assertEval + "width-ctxstr-elems" + ( "let s = builtins.appendContext \"x\" (builtins.listToAttrs (builtins.genList (i: { " + <> "name = \"/nix/store/00000000000000000000000000000000-p\" + builtins.toString i; " + <> "value = { path = true; }; }) 70000)); " + <> "in builtins.seq s (builtins.length (builtins.attrNames (builtins.getContext s)))" + ) + (VInt 70000) + ] + +-- --------------------------------------------------------------------------- +-- Tests: store-path name validation at write sinks (#39) +-- --------------------------------------------------------------------------- + +-- | Name validation at write sinks (#39): the store-path name rules hold +-- at path CONSTRUCTION, not only at parse. Derivation names, output names, and +-- fetchurl basenames reject exactly what the parse boundary rejects, +-- before any write path is built from them - and names the old ad hoc +-- sink checks over-rejected (an interior @..@) are valid again. +testStoreNameSinks :: IO [Bool] +testStoreNameSinks = do + putStrLn "store/name-sinks" + let drvWith nameLit = + "(derivation { name = " <> nameLit <> "; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).drvPath" + drvOutPath nameLit = + "(derivation { name = " <> nameLit <> "; system = \"x86_64-linux\"; builder = \"/bin/sh\"; }).outPath" + drvWithOutputs outsLit = + "(derivation { name = \"p\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = " <> outsLit <> "; }).drvPath" + failsWith label source needle = case evalNix source of + Left err + | parseErrorTag `T.isPrefixOf` err -> Fail (label <> ": did not parse: " <> err) + | needle `T.isInfixOf` err -> Pass + | otherwise -> Fail (label <> ": wrong error: " <> err) + Right val -> Fail (label <> ": expected an eval error, got " <> T.pack (show val)) + succeedsWithSuffix label source suffix = case evalNix source of + Left err -> Fail (label <> ": unexpected error: " <> err) + Right (VStr s _) -> + if TE.encodeUtf8 suffix `BS.isSuffixOf` s + then Pass + else Fail (label <> ": expected suffix " <> suffix <> ", got " <> bytesText s) + Right other -> Fail (label <> ": expected VStr, got " <> T.pack (show other)) + -- Upstream's BadStorePath text in full for a name refused where its + -- path is built from a derivation's hashes, the hash part held only + -- to the nix-base32 shape. + refusedConstructing label source name reason = case evalNix source of + Left err + | Just rest <- T.stripPrefix "path '" err, + (hashPart, afterHash) <- T.splitAt storePathHashLen rest, + Just _ <- parseStorePathBaseName (hashPart <> "-x"), + afterHash == "-" <> name <> "' is not a valid store path: name '" <> name <> "' " <> reason -> + Pass + | otherwise -> Fail (label <> ": wrong error: " <> err) + Right val -> Fail (label <> ": expected an eval error, got " <> T.pack (show val)) + drvNamedWithOutputs nameText outsLit = + "(derivation { name = \"" <> nameText <> "\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = " <> outsLit <> "; }).drvPath" + longest = T.replicate 211 "a" + nearlyLongest = T.replicate 208 "a" + sequence + [ runTest "derivation name with a space is rejected" $ + failsWith "name-space" (drvWith "\"a b\"") "invalid derivation name", + runTest "derivation name with a slash is rejected" $ + failsWith "name-slash" (drvWith "\"a/b\"") "invalid derivation name", + runTest "derivation name with a backslash is rejected" $ + failsWith "name-backslash" (drvWith "\"a\\\\b\"") "invalid derivation name", + runTest "derivation name with a drive colon is rejected" $ + failsWith "name-colon" (drvWith "\"C:x\"") "invalid derivation name", + runTest "empty derivation name is rejected" $ + failsWith "name-empty" (drvWith "\"\"") "name must not be empty", + runTest "212-character derivation name is rejected" $ + failsWith "name-long" (drvWith ("\"" <> T.replicate 212 "a" <> "\"")) "must be no longer than 211 characters", + runTest "derivation name '..' is rejected" $ + failsWith "name-dotdot" (drvWith "\"..\"") "name '..' is not valid", + runTest "derivation name '.-x' is rejected" $ + failsWith "name-dotdash" (drvWith "\".-x\"") "dash-separated component", + runTest "dotfile derivation name stays valid" $ + succeedsWithSuffix "name-dotfile" (drvWith "\".foo-1.0\"") "-.foo-1.0.drv", + runTest "interior '..' in a derivation name stays valid" $ + succeedsWithSuffix "name-interior-dots" (drvOutPath "\"x..y\"") "-x..y", + runTest "derivation output name with a traversal is rejected" $ + failsWith "out-traversal" (drvWithOutputs "[ \"out\" \"../x\" ]") "invalid derivation output name", + runTest "derivation output name with a colon is rejected" $ + failsWith "out-colon" (drvWithOutputs "[ \"a:b\" ]") "invalid derivation output name", + -- Upstream's derivationStrict refuses these in its outputs loop: the + -- result set already has a drvPath attribute, and a repeat would + -- collide there too. + runTest "derivation output named drvPath is rejected" $ + failsWith "out-drvpath" (drvWithOutputs "[ \"drvPath\" ]") "invalid derivation output name 'drvPath'", + runTest "repeated derivation output name is rejected" $ + failsWith "out-duplicate" (drvWithOutputs "[ \"out\" \"out\" ]") "duplicate derivation output 'out'", + -- The wrapper never calls derivationStrict with an empty list (its + -- builtins.head fails on the empty list of outputs first), so the + -- primop is called directly. + runTest "empty derivation output list is rejected" $ + failsWith + "out-empty" + "derivationStrict { name = \"p\"; system = \"x86_64-linux\"; builder = \"/bin/sh\"; outputs = [ ]; }" + "derivation cannot have an empty set of outputs", + -- Both fields clean on their own, only the COMPOSED drvName-output + -- crosses the length cap: the construction-side check catches what + -- the field-level checks cannot. + runTest "composed name-output past the length cap is rejected" $ + refusedConstructing + "composed-long" + (drvNamedWithOutputs nearlyLongest "[ \"dev\" ]") + (nearlyLongest <> "-dev") + "must be no longer than 211 characters", + -- Upstream builds the output paths over its sorted output set, so + -- of two names past the cap the first by name is the one refused. + runTest "of two outputs past the length cap the first by name is refused" $ + refusedConstructing + "composed-order" + (drvNamedWithOutputs nearlyLongest "[ \"out\" \"zzz\" \"dev\" ]") + (nearlyLongest <> "-dev") + "must be no longer than 211 characters", + runTest "a name whose .drv name is past the length cap is refused" $ + refusedConstructing + "drv-long" + (drvNamedWithOutputs longest "[ \"out\" ]") + (longest <> ".drv") + "must be no longer than 211 characters", + -- fetchurl derives the store name from the URL alone, so a bad + -- basename fails BEFORE the download: under PureEval a reachable + -- download would surface as "runProcess: not available" instead. + runTest "fetchurl rejects a backslash basename before fetching" $ + failsWith "fetchurl-backslash" "builtins.fetchurl \"http://e/a\\\\b\"" "invalid store path name", + runTest "fetchurl rejects a dot-segment basename before fetching" $ + failsWith "fetchurl-dotdot" "builtins.fetchurl \"http://e/..\"" "invalid store path name" + ] + +-- | Which entry names and link targets each host's rules admit +-- ("Nix.Store.EntryName"). The decision is pure, so every host's answer +-- is checked on any host: the grammar's refusals hold everywhere, POSIX +-- holds every other name as bytes, macOS needs UTF-8 without a +-- noncharacter, and Windows refuses what Win32 reserves or rewrites. +testNarNameSafety :: IO [Bool] +testNarNameSafety = do + putStrLn "store/entry-name-rules" + let admitted rules names = [(name, admits rules name) | name <- names] + admits rules name = either (const False) (const True) (checkEntryName rules name) + allAdmit rules names = assertEqual (T.pack (show rules) <> " verdicts") [(name, True) | name <- names] (admitted rules names) + allRefuse rules names = assertEqual (T.pack (show rules) <> " verdicts") [(name, False) | name <- names] (admitted rules names) + everyHost = [PosixNames, DarwinNames, WindowsNames] + grammarRefused = ["", ".", "..", "a/b", "/", "a\NULb"] + posixOnlyNames = [name | (name, _) <- posixOnlyEntries] + notUtf8 = ["caf\xE9", "\xFF", "\xC0\xAF", "\xED\xA0\x80", "\xF4\x90\x80\x80"] + noncharacters = ["n\xEF\xB7\x90", "n\xEF\xB7\xAF", "n\xEF\xBF\xBE", "n\xEF\xBF\xBF", "n\xF0\x9F\xBF\xBE", "n\xF4\x8F\xBF\xBF"] + sequence + [ runTest "the grammar's refusals hold on every host" $ + foldr (keepFirstFail . (`allRefuse` grammarRefused)) Pass everyHost, + runTest "POSIX holds every other name as its bytes" $ + allAdmit PosixNames (posixOnlyNames <> notUtf8 <> noncharacters <> ["caf\xC3\xA9", "a\x7F"]), + runTest "macOS holds a name upstream restores there" $ + allAdmit DarwinNames (posixOnlyNames <> ["caf\xC3\xA9", "n\xEE\x80\x80", "n\xEF\xBF\xBD", "n\xEF\xBB\xBF"]), + runTest "macOS refuses a name that is not UTF-8 or holds a noncharacter" $ + allRefuse DarwinNames (notUtf8 <> noncharacters), + runTest "Windows refuses device names, trailing dots and spaces, and reserved characters" $ + allRefuse + WindowsNames + ( filter (not . BS.isPrefixOf "link-") posixOnlyNames + <> ["nul.txt", "Nul .txt", "COM0.log", "com3", "lpt9", "COM\xC2\xB2", "COM\xC2\xB3", "C:evil", "a*b", "a?b", "ab", "a|b", "ctl\x1F"] + ), + runTest "Windows refuses a name with no UTF-16 form" $ + allRefuse WindowsNames notUtf8, + runTest "Windows holds ordinary and near-miss names" $ + allAdmit + WindowsNames + ["a", ".hidden", "a.b", "a b", " a", "com10", "COM", "NULx", "xNUL.txt", "caf\xC3\xA9", "LPT\xE2\x81\xB9", "a~b", "a\x7F", "n\xEF\xBF\xBE"], + runTest "a refusal names the entry and the reason" $ + assertEqual + "refusals" + [ Left "NAR directory entry name 'aux.c' is a Windows device name", + Left "NAR directory entry name 'x.' ends in a dot or a space, which Windows strips", + Left "NAR directory entry name 'a:b' holds a character Windows does not allow in a name", + Left "NAR directory entry name \"caf\\233\" is not valid UTF-8, which a macOS filesystem cannot hold", + Left "unsafe NAR directory entry name: \"a/b\"" + ] + [ checkEntryName WindowsNames "aux.c", + checkEntryName WindowsNames "x.", + checkEntryName WindowsNames "a:b", + checkEntryName DarwinNames "caf\xE9", + checkEntryName PosixNames "a/b" + ], + runTest "a link target is bytes on POSIX and macOS and UTF-16 on Windows" $ + assertEqual + "target verdicts" + [Right (), Right (), Left "NAR symlink target \"caf\\233\" is not valid UTF-8, so it has no UTF-16 form for Windows", Right ()] + [ checkLinkTarget PosixNames "caf\xE9", + checkLinkTarget DarwinNames "caf\xE9", + checkLinkTarget WindowsNames "caf\xE9", + checkLinkTarget WindowsNames "../a b/c:d" + ], + -- The Windows rules check a name's bytes, where the check they + -- replace read it as text; on every name both could judge (UTF-8 + -- without a character the old check let through and Windows + -- refuses at the create) they must agree. + runTestM "the Windows rules refuse what the text check they replace refused" $ do + result <- + QC.quickCheckWithResult QC.stdArgs {QC.chatty = False, QC.maxSuccess = 5000} $ + QC.forAll genDeviceLikeName $ \name -> + either (const False) (const True) (checkEntryName WindowsNames (TE.encodeUtf8 name)) + QC.=== legacyTextNameSafety name + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))) + ] + where + keepFirstFail Pass acc = acc + keepFirstFail failure _ = failure + +-- | The text-form name check the Windows rules replaced, kept verbatim as +-- the oracle their byte-form port is tested against. +legacyTextNameSafety :: Text -> Bool +legacyTextNameSafety name = + not (T.null name) + && name /= ".." + && name /= "." + && not (T.any escapesTree name) + && not (trailingRewritten name) + && not (reservedDeviceStem name) + where + escapesTree c = c == '/' || c == '\\' || c == ':' || c == '\0' + trailingRewritten n = case T.unsnoc n of + Just (_, end) -> end == '.' || end == ' ' + Nothing -> False + reservedDeviceStem n = + let stem = T.toUpper (T.dropWhileEnd (== ' ') (T.takeWhile (/= '.') n)) + in stem == "CON" + || stem == "PRN" + || stem == "AUX" + || stem == "NUL" + || numberedDeviceStem stem + numberedDeviceStem stem = case T.unpack stem of + [a, b, c, digit] -> ([a, b, c] == "COM" || [a, b, c] == "LPT") && deviceDigit digit + _ -> False + deviceDigit c = isDigit c || c == '\185' || c == '\178' || c == '\179' + +-- | Names shaped like a Windows device: a stem in mixed case or a near +-- miss, then a digit (plain, superscript, or a superscript nine that is +-- not a device digit), spaces, and nothing, an extension, or more +-- pieces, among them separators, dots and letters whose uppercase is +-- longer than themselves. About one name in twenty is refused by the +-- device rule alone. +genDeviceLikeName :: QC.Gen Text +genDeviceLikeName = do + stem <- QC.elements ["con", "CON", "Prn", "aux", "AUX", "nul", "NuL", "com", "COM", "lpt", "LpT", "x", "\305", "\329"] + digit <- QC.elements ["", "0", "1", "9", "10", "\185", "\178", "\179", "\8313", "\233"] + spaces <- QC.elements ["", " ", " "] + rest <- QC.frequency [(3, pure ""), (3, ("." <>) <$> pieces), (2, pieces)] + pure (stem <> digit <> spaces <> rest) + where + pieces = + T.concat + <$> QC.resize 4 (QC.listOf (QC.elements [".", "..", " ", "x", "txt", "\233", "\223", "\64256", ":", "\\", "/", "\NUL", "con", "1"])) + +-- | Entry names upstream's restore writes on POSIX as it finds them and +-- Windows cannot hold, each as compared against @nix-store --restore@ +-- 2.33.2: device stems (one with a superscript digit), trailing dots and +-- spaces, colons (perl's man pages carry them), a backslash, the +-- punctuation Win32 reserves, a control character, and links pointing +-- at such names. +posixOnlyEntries :: [(BS.ByteString, NAR.NarEntry)] +posixOnlyEntries = + [ ("COM1", NAR.NarRegular False "com1"), + ("ExtUtils::MakeMaker.3", NAR.NarRegular False "man"), + ("LPT\xC2\xB9.txt", NAR.NarRegular False "lpt"), + ("NUL", NAR.NarRegular False "nul"), + ("a:b", NAR.NarRegular False "colon"), + ("a\\b", NAR.NarRegular False "backslash"), + ("aux.c", NAR.NarRegular False "aux"), + ("con.h", NAR.NarRegular False "con"), + ("ctl\x01", NAR.NarRegular False "control"), + ("dir.", NAR.NarDirectory [("prn", NAR.NarRegular True "prn")]), + ("link-aux", NAR.NarSymlink "aux.c"), + ("link-colon", NAR.NarSymlink "a:b"), + ("link-dot", NAR.NarSymlink "x."), + ("q\"*?<>|", NAR.NarRegular False "reserved"), + ("x.", NAR.NarRegular False "dot"), + ("y ", NAR.NarRegular False "space") + ] + +-- | 'posixOnlyEntries' as one directory. +posixOnlyTree :: NAR.NarEntry +posixOnlyTree = NAR.NarDirectory posixOnlyEntries + +-- | IO-evaluator write sinks reject an invalid name BEFORE any write: +-- every case here errors out against a scratch dir with no store traffic, +-- in upstream's BadStorePath words, naming the path the write would have +-- had. The hash parts are computed apart from nova-nix, from the NAR and +-- store-path formats, and the first two are what nix-instantiate 2.24.9 +-- prints. The fixtures are written as bytes, so their NARs, and so the +-- hash parts, are the same on every host. +testStoreNameSinksIO :: IO [Bool] +testStoreNameSinksIO = do + putStrLn "store/name-sinks-io" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-name-sinks" + refusedAs label source expected = runTestM label (assertEvalErrorIO testDir label source expected) + bracket_ + ( do + createDirectoryIfMissing True (testDir "tree") + BS.writeFile (testDir "tree" "f.txt") "payload\n" + BS.writeFile (testDir "sp ace") "payload\n" + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ refusedAs + "toFile rejects a name with a space" + "builtins.toFile \"a b\" \"x\"" + "path 'dm85kbl5cy82j2dzvy1874s14y3salv3-a b' is not a valid store path: name 'a b' contains illegal character ' '", + refusedAs + "toFile rejects an empty name" + "builtins.toFile \"\" \"x\"" + "path '9r1mh2rc3s3i33vpdw86kqqyvy9i1y4w-' is not a valid store path: name must not be empty", + refusedAs + "toFile rejects a stream-colon name" + "builtins.toFile \"a:b\" \"x\"" + "path '2gs912wpmbp0agwviqp9ymw7ljxlsla0-a:b' is not a valid store path: name 'a:b' contains illegal character ':'", + refusedAs + "toFile rejects a dot-segment name" + "builtins.toFile \"..\" \"x\"" + "path 'hv29bhyiqgqrrvfwnrc9gg9g9cw83k4b-..' is not a valid store path: name '..' is not valid", + -- A copy's name is refused once the tree is hashed, so its hash + -- part is that of the tree's NAR. + refusedAs + "path rejects a traversal name override" + "builtins.path { path = ./tree; name = \"../../evil\"; }" + "path '7gzygjfd61wpybnrahsdpkpa1qhcgx55-../../evil' is not a valid store path: name '../../evil' contains illegal character '/'", + refusedAs + "path with a filter rejects a drive-prefixed name" + "builtins.path { path = ./tree; name = \"C:evil\"; filter = (_: _: true); }" + "path 'la26d723gkznrdzhaxknqp0mi025ibi7-C:evil' is not a valid store path: name 'C:evil' contains illegal character ':'", + -- A pinned copy's name is refused under the pin, before the pin + -- is checked against the tree (which it does not match). + refusedAs + "a pinned path's name is refused under the pinned hash" + ("builtins.path { path = ./tree; name = \"a b\"; sha256 = \"" <> T.replicate 64 "0" <> "\"; }") + "path 'mrlc43by4xlm6cr8163bcqrr712bh2k2-a b' is not a valid store path: name 'a b' contains illegal character ' '", + -- Every argument is forced before the pinned path is built. + refusedAs + "a pinned path forces its filter before refusing its name" + ("builtins.path { path = ./tree; name = \"a b\"; sha256 = \"" <> T.replicate 64 "0" <> "\"; filter = throw \"filter forced\"; }") + "filter forced", + refusedAs + "source coercion rejects a basename outside the name rules" + "\"${./. + \"/sp ace\"}\"" + "path 'pj9xmn69xsrk8nlx6xsljb0bmsydj4dr-sp ace' is not a valid store path: name 'sp ace' contains illegal character ' '" + ] + +-- | An inherited name and whether its select reads that name, as the one +-- path segment, from slot 0 of the env it runs in. +inheritedSelect :: BcInheritedName -> IO (Text, Bool) +inheritedSelect (BcInheritedName _ sym selectIdx) = do + op <- cbcOpcode selectIdx + pathLen <- cbcShortArg selectIdx + target <- cbcArg1 selectIdx + pathOff <- cbcArg2 selectIdx + targetOp <- cbcOpcode target + level <- cbcArg1 target + slot <- cbcArg2 target + keyTag <- cbcData pathOff + keySym <- cbcData (pathOff + 1) + pure + ( symbolText (Symbol sym), + op == OpSelect && pathLen == 1 && targetOp == OpResolvedVar && level == 0 && slot == 0 && keyTag == attrkeyStatic && keySym == sym + ) + +testBytecodeCompile :: IO [Bool] +testBytecodeCompile = do + putStrLn "bytecode" + -- Arena (including bytecode store) already initialized by main's bracket. + sequence + [ runTestM "compile ELit NixInt" $ do + idx <- compileExpr (ELit (NixInt 42)) + op <- cbcOpcode idx + a1 <- cbcArg1 idx + a2 <- cbcArg2 idx + pure + ( if op == OpLitInt && a1 == 42 && a2 == 0 + then Pass + else Fail ("op=" <> T.pack (show op) <> " a1=" <> T.pack (show a1)) + ), + runTestM "compile ELit NixInt negative" $ do + idx <- compileExpr (ELit (NixInt (-1))) + op <- cbcOpcode idx + a1 <- cbcArg1 idx + a2 <- cbcArg2 idx + -- -1 as uint64 = 0xFFFFFFFFFFFFFFFF, lo=0xFFFFFFFF, hi=0xFFFFFFFF + pure + ( if op == OpLitInt && a1 == 0xFFFFFFFF && a2 == 0xFFFFFFFF + then Pass + else + Fail + ( "a1=" + <> T.pack (show a1) + <> " a2=" + <> T.pack (show a2) + ) + ), + runTestM "compile ELit NixBool" $ do + idxT <- compileExpr (ELit (NixBool True)) + idxF <- compileExpr (ELit (NixBool False)) + opT <- cbcOpcode idxT + opF <- cbcOpcode idxF + saT <- cbcShortArg idxT + saF <- cbcShortArg idxF + pure + ( if opT == OpLitBool && saT == 1 && opF == OpLitBool && saF == 0 + then Pass + else Fail "bool encoding mismatch" + ), + runTestM "compile ELit NixNull" $ do + idx <- compileExpr (ELit NixNull) + op <- cbcOpcode idx + pure (assertEqual "opcode" OpLitNull op), + runTestM "compile EResolvedVar" $ do + idx <- compileExpr (EResolvedVar 3 7) + op <- cbcOpcode idx + a1 <- cbcArg1 idx + a2 <- cbcArg2 idx + pure + ( if op == OpResolvedVar && a1 == 3 && a2 == 7 + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " a1=" + <> T.pack (show a1) + <> " a2=" + <> T.pack (show a2) + ) + ), + runTestM "compile EVar" $ do + idx <- compileExpr (EVar "hello") + op <- cbcOpcode idx + sym <- cbcArg1 idx + let symText = symbolText (Symbol sym) + pure + ( if op == OpVar && symText == "hello" + then Pass + else Fail ("op=" <> T.pack (show op) <> " sym=" <> symText) + ), + runTestM "compile EApp" $ do + idx <- compileExpr (EApp (EVar "f") (ELit (NixInt 1))) + op <- cbcOpcode idx + funcIdx <- cbcArg1 idx + argIdx <- cbcArg2 idx + funcOp <- cbcOpcode funcIdx + argOp <- cbcOpcode argIdx + pure + ( if op == OpApp && funcOp == OpVar && argOp == OpLitInt + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " funcOp=" + <> T.pack (show funcOp) + <> " argOp=" + <> T.pack (show argOp) + ) + ), + runTestM "compile EIf" $ do + idx <- + compileExpr + (EIf (ELit (NixBool True)) (ELit (NixInt 1)) (ELit (NixInt 2))) + op <- cbcOpcode idx + condIdx <- cbcArg1 idx + thenIdx <- cbcArg2 idx + elseIdx <- cbcArg3 idx + condOp <- cbcOpcode condIdx + thenA1 <- cbcArg1 thenIdx + elseA1 <- cbcArg1 elseIdx + pure + ( if op == OpIf && condOp == OpLitBool && thenA1 == 1 && elseA1 == 2 + then Pass + else Fail "if structure mismatch" + ), + runTestM "compile EBinary" $ do + idx <- + compileExpr + (EBinary OpAdd (ELit (NixInt 10)) (ELit (NixInt 20))) + op <- cbcOpcode idx + fl <- cbcFlags idx + leftIdx <- cbcArg1 idx + rightIdx <- cbcArg2 idx + leftA1 <- cbcArg1 leftIdx + rightA1 <- cbcArg1 rightIdx + pure + ( if op == OpBinary && fl == binaryAdd && leftA1 == 10 && rightA1 == 20 + then Pass + else Fail "binary structure mismatch" + ), + runTestM "compile EUnary" $ do + idx <- compileExpr (EUnary OpNegate (ELit (NixInt 5))) + op <- cbcOpcode idx + fl <- cbcFlags idx + operandIdx <- cbcArg1 idx + operandA1 <- cbcArg1 operandIdx + pure + ( if op == OpUnary && fl == unaryNegate && operandA1 == 5 + then Pass + else Fail "unary structure mismatch" + ), + runTestM "compile EList" $ do + idx <- + compileExpr + (EList [ELit (NixInt 1), ELit (NixInt 2), ELit (NixInt 3)]) + op <- cbcOpcode idx + count <- cbcShortArg idx + dataOff <- cbcArg1 idx + c0 <- cbcData dataOff + c1 <- cbcData (dataOff + 1) + c2 <- cbcData (dataOff + 2) + c0a1 <- cbcArg1 c0 + c1a1 <- cbcArg1 c1 + c2a1 <- cbcArg1 c2 + pure + ( if op == OpList && count == 3 && c0a1 == 1 && c1a1 == 2 && c2a1 == 3 + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " count=" + <> T.pack (show count) + ) + ), + runTestM "compile EStr with interpolation" $ do + idx <- + compileExpr + (EStr [StrLit "hello ", StrInterp (EVar "name"), StrLit "!"]) + op <- cbcOpcode idx + count <- cbcShortArg idx + dataOff <- cbcArg1 idx + -- 3 parts x 2 words each = 6 data words + tag0 <- cbcData dataOff + _val0 <- cbcData (dataOff + 1) + tag1 <- cbcData (dataOff + 2) + val1 <- cbcData (dataOff + 3) + tag2 <- cbcData (dataOff + 4) + -- tag0=0(lit), tag1=1(interp), tag2=0(lit) + interpOp <- cbcOpcode val1 + pure + ( if op == OpStr + && count == 3 + && tag0 == strpartLit + && tag1 == strpartInterp + && tag2 == strpartLit + && interpOp == OpVar + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " count=" + <> T.pack (show count) + <> " tag0=" + <> T.pack (show tag0) + <> " tag1=" + <> T.pack (show tag1) + ) + ), + runTestM "compile EWith" $ do + idx <- compileExpr (EWith (EVar "lib") (EVar "x")) + op <- cbcOpcode idx + scopeIdx <- cbcArg1 idx + bodyIdx <- cbcArg2 idx + scopeOp <- cbcOpcode scopeIdx + bodyOp <- cbcOpcode bodyIdx + pure + ( if op == OpWith && scopeOp == OpVar && bodyOp == OpVar + then Pass + else Fail "with structure mismatch" + ), + runTestM "compile EAssert" $ do + idx <- compileExpr (EAssert (ELit (NixBool True)) (ELit (NixInt 1))) + op <- cbcOpcode idx + condIdx <- cbcArg1 idx + bodyIdx <- cbcArg2 idx + condOp <- cbcOpcode condIdx + bodyOp <- cbcOpcode bodyIdx + pure + ( if op == OpAssert && condOp == OpLitBool && bodyOp == OpLitInt + then Pass + else Fail "assert structure mismatch" + ), + runTestM "compile ELambda (FormalName)" $ do + idx <- + compileExpr + (ELambda (FormalName "x") (EResolvedVar 0 0) NoCaptureInfo) + op <- cbcOpcode idx + fl <- cbcFlags idx + bodyIdx <- cbcArg2 idx + bodyOp <- cbcOpcode bodyIdx + pure + ( if op == OpLambda && fl == formalName && bodyOp == OpResolvedVar + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " flags=" + <> T.pack (show fl) + ) + ), + runTestM "compile ELet" $ do + idx <- + compileExpr + ( ELet + [NamedBinding (testPos 1 5) (StaticKey "x") (ELit (NixInt 42))] + (EResolvedVar 0 0) + NoCaptureInfo + ) + op <- cbcOpcode idx + count <- cbcShortArg idx + bodyIdx <- cbcArg2 idx + bodyOp <- cbcOpcode bodyIdx + pure + ( if op == OpLet && count == 1 && bodyOp == OpResolvedVar + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " count=" + <> T.pack (show count) + ) + ), + runTestM "compile EAttrs" $ do + idx <- + compileExpr + ( EAttrs + False + [NamedBinding (testPos 1 3) (StaticKey "a") (ELit (NixInt 1))] + NoCaptureInfo + ) + op <- cbcOpcode idx + fl <- cbcFlags idx + count <- cbcShortArg idx + pure + ( if op == OpAttrs && fl == 0 && count == 1 + then Pass + else Fail "attrs structure mismatch" + ), + runTestM "compile EAttrs recursive" $ do + idx <- + compileExpr + ( EAttrs + True + [ NamedBinding (testPos 1 7) (StaticKey "x") (ELit (NixInt 1)), + NamedBinding (testPos 1 14) (StaticKey "y") (EResolvedVar 0 0) + ] + (Captures [(0, 0)]) + ) + op <- cbcOpcode idx + fl <- cbcFlags idx + count <- cbcShortArg idx + pure + ( if op == OpAttrs && fl == 1 && count == 2 + then Pass + else + Fail + ( "flags=" + <> T.pack (show fl) + <> " count=" + <> T.pack (show count) + ) + ), + runTestM "compile ESelect" $ do + idx <- + compileExpr + (ESelect (EVar "x") [StaticKey "a"] Nothing) + op <- cbcOpcode idx + fl <- cbcFlags idx + pure + ( if op == OpSelect && fl == 0 + then Pass + else Fail ("flags=" <> T.pack (show fl)) + ), + runTestM "compile ESelect with default" $ do + idx <- + compileExpr + (ESelect (EVar "x") [StaticKey "a"] (Just (ELit NixNull))) + op <- cbcOpcode idx + fl <- cbcFlags idx + defIdx <- cbcArg3 idx + defOp <- cbcOpcode defIdx + pure + ( if op == OpSelect && fl == 1 && defOp == OpLitNull + then Pass + else Fail ("flags=" <> T.pack (show fl)) + ), + runTestM "compile EHasAttr" $ do + idx <- + compileExpr + (EHasAttr (EVar "x") [StaticKey "a", StaticKey "b"]) + op <- cbcOpcode idx + pathLen <- cbcShortArg idx + pure + ( if op == OpHasAttr && pathLen == 2 + then Pass + else + Fail + ( "op=" + <> T.pack (show op) + <> " pathLen=" + <> T.pack (show pathLen) + ) + ), + -- ESearchPath is desugared by resolver to __findFile __nixPath "name", + -- so the compiler sees an EApp chain, not a raw ESearchPath. + runTestM "compile desugared search path" $ do + idx <- compileExpr (EApp (EApp (EVar "__findFile") (EVar "__nixPath")) (EStr [StrLit "nixpkgs"])) + op <- cbcOpcode idx + pure + ( if op == OpApp + then Pass + else Fail ("expected OpApp, got op=" <> T.pack (show op)) + ), + runTestM "op_count grows after compilation" $ do + before <- cbcOpCount + _ <- compileExpr (EApp (EVar "f") (ELit (NixInt 1))) + after <- cbcOpCount + pure + ( if after > before + then Pass + else + Fail + ( "before=" + <> T.pack (show before) + <> " after=" + <> T.pack (show after) + ) + ), + runTestM "compile ELit NixFloat" $ do + idx <- compileExpr (ELit (NixFloat 3.14)) + op <- cbcOpcode idx + pure (assertEqual "opcode" OpLitFloat op), + runTestM "compile ELit NixUri" $ do + idx <- compileExpr (ELit (NixUri "https://example.com")) + op <- cbcOpcode idx + sym <- cbcArg1 idx + pure + ( if op == OpLitUri && symbolText (Symbol sym) == "https://example.com" + then Pass + else Fail "uri mismatch" + ), + runTestM "compile ELit NixPath" $ do + idx <- compileExpr (ELit (NixPath "/nix/store/foo")) + op <- cbcOpcode idx + sym <- cbcArg1 idx + pure + ( if op == OpLitPath && symbolText (Symbol sym) == "/nix/store/foo" + then Pass + else Fail "path mismatch" + ), + runTestM "compile inherit-from binding" $ do + idx <- + compileExpr + ( EAttrs + False + [InheritFrom (EVar "s") [InheritedName (testPos 1 15) "x", InheritedName (testPos 1 17) "y"]] + NoCaptureInfo + ) + op <- cbcOpcode idx + count <- cbcShortArg idx + dataOff <- cbcArg1 idx + bindings <- decodeBcBindings 1 dataOff + case bindings of + [BcInheritFrom _ names] + | op == OpAttrs && count == 1 -> do + selects <- mapM inheritedSelect names + pure (assertEqual "inherited names and their selects" [("x", True), ("y", True)] selects) + _ -> pure (Fail "inherit binding mismatch"), + -- A plain inherit has no lookup of its own: it carries the variable, + -- bound like any other, for the evaluator to read in the outer env. + runTestM "compile plain inherit with the variable it copies" $ do + idx <- compileExpr (EAttrs False [Inherit (testPos 1 11) "x" (EResolvedVar 0 0)] NoCaptureInfo) + dataOff <- cbcArg1 idx + bindings <- decodeBcBindings 1 dataOff + case bindings of + [BcInherit _ sym valIdx] -> do + valOp <- cbcOpcode valIdx + pure $ + if symbolText (Symbol sym) == "x" && valOp == OpResolvedVar + then Pass + else Fail "expected x to carry the resolved variable" + _ -> pure (Fail "expected one inherit binding"), + -- Every kind of binding carries the position it was parsed at + -- through the bytecode, and reads it back with its file. + runTestM "compile records each binding's position" $ do + let at = SrcPos (SourceFile "/positions/set.nix") + idx <- + compileExpr + ( EAttrs + False + [ NamedBinding (at 2 3) (StaticKey "a") (ELit (NixInt 1)), + Inherit (at 3 11) "x" (EResolvedVar 0 0), + InheritFrom (EResolvedVar 0 0) [InheritedName (at 4 22) "y"] + ] + NoCaptureInfo + ) + dataOff <- cbcArg1 idx + bindings <- decodeBcBindings 3 dataOff + let positionsOf binding = case binding of + BcNamed pos _ _ -> [pos] + BcInherit pos _ _ -> [pos] + BcInheritFrom _ names -> [pos | BcInheritedName pos _ _ <- names] + pure $ + assertEqual + "positions read back" + (map Just [PosInFile "/positions/set.nix" 2 3, PosInFile "/positions/set.nix" 3 11, PosInFile "/positions/set.nix" 4 22]) + (map lookupPos (concatMap positionsOf bindings)), + -- Recording a position and reading it back keeps its file, line and + -- column, text with no file reads back as such, and a line or + -- column past 32 bits is unrecordable, as it is in upstream's table. + -- One recorder sees every case, so the origin it remembers changes + -- under it as a compilation's never does. + runTestM "a recorded position reads back as it was recorded" $ do + recorder <- newPosRecorder + let wordCeiling = fromIntegral (maxBound :: Word32) + genOrigin = + QC.oneof + [ SourceFile <$> QC.elements ["/a.nix", "/nix/store/00000000000000000000000000000000-s/default.nix", "C:\\work\\f.nix", "/caf\233.nix"], + pure testOrigin + ] + genCoordinate = QC.oneof [QC.chooseInt (1, 4096), QC.chooseInt (1, wordCeiling), QC.chooseInt (wordCeiling + 1, maxBound)] + expected (SrcPos origin line column) + | line > wordCeiling || column > wordCeiling = Nothing + | otherwise = Just $ case origin of + SourceFile path -> PosInFile path line column + SourceText _ -> PosInText line column + property = + QC.forAll (SrcPos <$> genOrigin <*> genCoordinate <*> genCoordinate) $ \pos -> + QC.ioProperty ((\idx -> lookupPos idx QC.=== expected pos) <$> recordPos recorder pos) + result <- QC.quickCheckWithResult QC.stdArgs {QC.chatty = False} property + pure (if QC.isSuccess result then Pass else Fail (T.pack (QC.output result))), + runTestM "compile ELambda (FormalSet)" $ do + idx <- + compileExpr + ( ELambda + (FormalSet [Formal "a" Nothing, Formal "b" (Just (ELit (NixInt 0)))] False) + (EResolvedVar 0 0) + NoCaptureInfo + ) + op <- cbcOpcode idx + fl <- cbcFlags idx + pure + ( if op == OpLambda && fl == formalSet + then Pass + else Fail ("flags=" <> T.pack (show fl)) + ), + runTestM "compile ELambda (FormalNamedSet)" $ do + idx <- + compileExpr + ( ELambda + (FormalNamedSet "args" [Formal "x" Nothing] True) + (EResolvedVar 0 0) + NoCaptureInfo + ) + op <- cbcOpcode idx + fl <- cbcFlags idx + pure + ( if op == OpLambda && fl == formalNamedSet + then Pass + else Fail ("flags=" <> T.pack (show fl)) + ), + runTestM "compile CaptureInfo (Captures)" $ do + idx <- + compileExpr + ( ELambda + (FormalName "x") + (EResolvedVar 0 0) + (Captures [(1, 2), (3, 4)]) + ) + op <- cbcOpcode idx + capOff <- cbcArg3 idx + capTag <- cbcData capOff + capCount <- cbcData (capOff + 1) + capL0 <- cbcData (capOff + 2) + capI0 <- cbcData (capOff + 3) + capL1 <- cbcData (capOff + 4) + capI1 <- cbcData (capOff + 5) + pure + ( if op == OpLambda + && capTag == captureSlots + && capCount == 2 + && capL0 == 1 + && capI0 == 2 + && capL1 == 3 + && capI1 == 4 + then Pass + else + Fail + ( "capTag=" + <> T.pack (show capTag) + <> " capCount=" + <> T.pack (show capCount) + ) + ), + runTestM "compile CaptureInfo (CapturesWithScopes)" $ do + idx <- + compileExpr + ( ELambda + (FormalName "x") + (EResolvedVar 0 0) + (CapturesWithScopes [(0, 0)]) + ) + capOff <- cbcArg3 idx + capTag <- cbcData capOff + pure (assertEqual "captureTag" captureWithScopes capTag), + runTestM "compile EWithVar" $ do + idx <- compileExpr (EWithVar "dynamic") + op <- cbcOpcode idx + sym <- cbcArg1 idx + pure + ( if op == OpWithVar && symbolText (Symbol sym) == "dynamic" + then Pass + else Fail "withvar mismatch" + ), + runTestM "compile EIndStr" $ do + idx <- compileExpr (EIndStr [StrLit "indented"]) + op <- cbcOpcode idx + count <- cbcShortArg idx + pure + ( if op == OpIndStr && count == 1 + then Pass + else Fail "indstr mismatch" + ) + ] + +-- --------------------------------------------------------------------------- +-- Tests: substituter signature verification (the --trusted-key trust gate) +-- --------------------------------------------------------------------------- + +-- | Minimal narinfo for signing tests; the fingerprint covers StorePath, +-- NarHash, NarSize, and References. +sigTestNarInfo :: NarInfo.NarInfo +sigTestNarInfo = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0", + NarInfo.niUrl = "nar/aaaa.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Just ("sha256:" <> T.replicate 52 "0"), + NarInfo.niFileSize = Just 1, + NarInfo.niNarHash = "sha256:" <> T.replicate 52 "0", + NarInfo.niNarSize = 1, + NarInfo.niReferences = [], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + +-- | A substituter cache trusting the given public key text. +sigTestCache :: Text -> Subst.CacheConfig +sigTestCache publicKeyText = + Subst.CacheConfig + { Subst.ccUrl = "http://localhost/test-cache", + Subst.ccPublicKeys = [publicKeyText], + Subst.ccPriority = 40 + } + +-- | Deterministic Ed25519 test keys: a nix secret key file is +-- seed(32) + public(32), and both signing and public-key derivation use +-- only the seed, so the public half can be zeros here. Both keys carry +-- the SAME name so the wrong-key test exercises the cryptographic +-- verification, not just the name comparison. +sigTestKeyText, sigTestWrongKeyText :: Text +sigTestKeyText = "test-key-1:" <> B64.encode (BS.pack ([1 .. 32] ++ replicate 32 0)) +sigTestWrongKeyText = "test-key-1:" <> B64.encode (BS.pack ([101 .. 132] ++ replicate 32 0)) + +-- | Derive (trusted cache, signature by the trusted key, signature by an +-- impostor key with the same name). Left on any setup failure. +sigTestSetup :: Either String (Subst.CacheConfig, Text, Text) +sigTestSetup = do + secretKey <- Signing.parseSecretKey sigTestKeyText + impostorKey <- Signing.parseSecretKey sigTestWrongKeyText + publicKey <- Signing.toPublicKey secretKey + let publicKeyText = Signing.renderPublicKey publicKey + validSig <- Signing.sign secretKey sigTestNarInfo + impostorSig <- Signing.sign impostorKey sigTestNarInfo + pure (sigTestCache publicKeyText, validSig, impostorSig) + +-- | verifySigs is the security boundary behind @--trusted-key@: unsigned +-- narinfos, wrong-key signatures, and malformed trusted keys must all be +-- rejected; a valid signature must be accepted. +testVerifySigs :: IO [Bool] +testVerifySigs = do + putStrLn "substituter/verify-sigs" + case sigTestSetup of + Left err -> (: []) <$> runTest "verifySigs test setup" (Fail (T.pack err)) + Right (cache, validSig, impostorSig) -> + sequence + [ runTest "valid signature accepted" $ + assertEqual "verify ok" (Right ()) (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = [validSig]}), + runTest "unsigned narinfo rejected" $ + assertLeft "no sigs" (Subst.verifySigs cache sigTestNarInfo), + runTest "same-name signature from a different key rejected" $ + assertLeft "impostor sig" (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = [impostorSig]}), + runTest "valid signature among invalid ones accepted" $ + assertEqual "any valid" (Right ()) (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = [impostorSig, validSig]}), + runTest "signature under a different key name rejected" $ + assertLeft "name mismatch" (Subst.verifySigs cache sigTestNarInfo {NarInfo.niSigs = ["other-key:" <> T.drop (T.length "test-key-1:") validSig]}), + runTest "malformed trusted public key rejected" $ + assertLeft "bad pubkey" (Subst.verifySigs (sigTestCache "not-a-key") sigTestNarInfo {NarInfo.niSigs = [validSig]}), + -- The flat trusted-key set: a signature valid under ANY of + -- several trusted keys is accepted, even when the matching key + -- is not first. + runTest "a signature valid under any of several trusted keys is accepted" $ + let multiKey = cache {Subst.ccPublicKeys = Subst.ccPublicKeys Subst.defaultCacheConfig ++ Subst.ccPublicKeys cache} + in assertEqual "any-of" (Right ()) (Subst.verifySigs multiKey sigTestNarInfo {NarInfo.niSigs = [validSig]}), + runTest "a signature matching none of several trusted keys is rejected" $ + let multiKey = cache {Subst.ccPublicKeys = ["cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=", "other.cache-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY="]} + in assertLeft "none-of" (Subst.verifySigs multiKey sigTestNarInfo {NarInfo.niSigs = [validSig]}), + -- A malformed key anywhere in the set is an error, not a + -- silently skipped key: a typo must not quietly narrow the + -- trusted set to the keys that happened to parse. + runTest "a malformed key among valid ones is an error, not skipped" $ + let multiKey = cache {Subst.ccPublicKeys = "not-a-key" : Subst.ccPublicKeys cache} + in assertLeft "typo not skipped" (Subst.verifySigs multiKey sigTestNarInfo {NarInfo.niSigs = [validSig]}) + ] + +-- | The nix.conf / NIX_CONFIG resolver: parsing, aliases, the extra- +-- append rule, the precedence fold, include expansion over an in-memory +-- file map, and the file cascade. The trusted-key cases are the +-- security-relevant ones, a plain assignment in a higher source replaces +-- the trusted set, an extra- widens it. +testNixConfig :: IO [Bool] +testNixConfig = do + putStrLn "config/nix-conf" + let -- A root the platform agrees is absolute: "/" is not one on + -- Windows, for System.FilePath and for upstream's canonPath alike. + root = if SI.os == "mingw32" then "C:\\" else "/" + etcNix = root "etc" "nix" + etcXdg = root "etc" "xdg" + etcXdgLocal = root "etc" "xdg-local" + configHome = root "home" "u" ".config" + systemConf = etcNix "nix.conf" + xdgConf dir = dir "nix" "nix.conf" + -- The expander's one effect, served from an in-memory map: a path + -- is in it or there is nothing there. + readFrom files path = Identity (maybe (Left Config.ConfigFileMissing) Right (Map.lookup path files)) + resolveWith files paths env = runIdentity (Config.loadConfig (readFrom files) paths env) + substitutersOf files paths env = ncSubstituters <$> resolveWith files paths env + fileMap = Map.mapKeys asciiOsPath . Map.fromList + -- The same, over the cascade a 'ConfigLocations' computes. + substitutersAt files locations env = Config.configFilePaths locations >>= \paths -> substitutersOf files paths env + firstPathOf locations = listToMaybe <$> Config.configFilePaths locations + -- Successive texts as successive files, weakest first. + resolveTexts texts = + let paths = [asciiOsPath (root "src" (show index ++ ".conf")) | index <- [1 .. length texts]] + in resolveWith (Map.fromList (zip paths texts)) paths Nothing + subs = fmap ncSubstituters . resolveTexts + keys = fmap ncTrustedPublicKeys . resolveTexts + fallback = fmap ncFallback . resolveTexts + uris = fmap ncAllowedUris . resolveTexts + cascade = + Config.ConfigLocations + { Config.clConfDir = Nothing, + Config.clSystemConfDir = Just (asciiOsPath etcNix), + Config.clUserConfFiles = Nothing, + Config.clConfigHome = asciiOsPath configHome, + Config.clConfigDirs = map asciiOsPath [etcXdg, etcXdgLocal] + } + cascadeFiles = + fileMap + [ (systemConf, "substituters = https://system"), + (xdgConf etcXdgLocal, "substituters = https://xdg-local"), + (xdgConf etcXdg, "substituters = https://xdg"), + (xdgConf configHome, "substituters = https://home") + ] + listVar = BS8.pack . intercalate [searchPathSeparator] + depth = fmap ncMaxCallDepth . resolveTexts + depthOf value = depth ["max-call-depth = " <> value] + refused = either (const True) (const False) . depthOf + -- Bytes with no UTF-8 reading (0xE9, Latin-1's e-acute). They are + -- a host path on POSIX and none on Windows, whose paths are UTF-16, + -- so the cases holding them branch on whether they spell one. + latin1 = "caf\xE9" :: BS.ByteString + -- What a lossy decode would open instead: U+FFFD's UTF-8. + replaced = "caf\xEF\xBF\xBD" + nixConfName = asciiOsPath "nix.conf" + sequence + [ runTest "parses a whitespace-split substituters list" $ + assertEqual "subs" (Right ["https://a", "https://b"]) (subs ["substituters = https://a https://b"]), + runTest "a comment truncates the line" $ + assertEqual "comment" (Right ["https://a"]) (subs ["substituters = https://a # not https://b"]), + runTest "a plain assignment replaces across sources" $ + assertEqual "replace" (Right ["https://b"]) (subs ["substituters = https://a", "substituters = https://b"]), + runTest "extra- appends within a source set" $ + assertEqual "append" (Right ["https://a", "https://b"]) (subs ["substituters = https://a", "extra-substituters = https://b"]), + runTest "binary-caches aliases substituters" $ + assertEqual "alias" (Right ["https://a"]) (subs ["binary-caches = https://a"]), + runTest "extra- composes with an alias" $ + assertEqual "extra-alias" (Right ["https://a", "https://b"]) (subs ["substituters = https://a", "extra-binary-caches = https://b"]), + runTest "binary-cache-public-keys aliases trusted-public-keys" $ + assertEqual "key-alias" (Right ["k1"]) (keys ["binary-cache-public-keys = k1"]), + runTest "a higher source plainly replaces the trusted set" $ + assertEqual "trust-replace" (Right ["k2"]) (keys ["trusted-public-keys = k1", "trusted-public-keys = k2"]), + runTest "a higher source with extra- widens the trusted set" $ + assertEqual "trust-widen" (Right ["k1", "k2"]) (keys ["trusted-public-keys = k1", "extra-trusted-public-keys = k2"]), + runTest "fallback is a Boolean, off by default, and build-fallback aliases it" $ + assertEqual "default" (Right False) (fallback []) + `andThen` assertEqual "on" (Right True) (fallback ["fallback = true"]) + `andThen` assertEqual "alias" (Right True) (fallback ["build-fallback = yes"]) + `andThen` assertEqual "replaced" (Right False) (fallback ["fallback = true", "fallback = false"]) + `andThen` assertEqual "typo" (Left "Boolean setting 'fallback' has invalid value 'ture'") (fallback ["fallback = ture"]), + runTest "an unknown setting is ignored, not an error" $ + assertEqual "unknown" (Right ["https://a"]) (subs ["cores = 4\nsubstituters = https://a"]), + runTest "blank and comment-only lines are skipped" $ + assertEqual "blanks" (Right ["https://a"]) (subs ["# a comment\n\nsubstituters = https://a\n"]), + runTest "a line missing = is a syntax error quoting the line as truncated, untrimmed" $ + let expected = "nix.conf: syntax error in configuration line ' substituters https://a ' in '" <> T.pack (root "src" "1.conf") <> "'" + in assertEqual "syntax" (Left expected) (resolveTexts [" substituters https://a # comment"]), + runTest "the default config is empty" $ + assertEqual "default" (Right []) (subs []), + -- Tokens, as upstream's tokenizeString splits them: on space, tab, + -- CR and LF only, which nix config show 2.33.2 agrees with. + runTest "a value splits on space, tab and CR, and not on other spaces" $ + assertEqual + "separators" + (Right ["https://a\xA0https://b\vhttps://c\fhttps://d", "https://e", "https://f", "https://g"]) + (uris ["allowed-uris = https://a\xC2\xA0https://b\vhttps://c\fhttps://d https://e\rhttps://f\thttps://g"]), + runTest "a CRLF line ends where its LF does" $ + assertEqual "crlf" (Right ["https://a"]) (subs ["substituters = https://a\r\n"]), + runTest "a Boolean value ending in a no-break space is upstream's invalid-value error" $ + assertEqual "nbsp-bool" (Left "Boolean setting 'pure-eval' has invalid value 'true\xA0'") (ncPureEval <$> resolveTexts ["pure-eval = true\xC2\xA0"]), + -- Bytes with no UTF-8 reading in a setting. + runTest "a comment and an unknown setting holding a byte with no UTF-8 reading are never decoded" $ + assertEqual "bytes-ignored" (Right ["https://a"]) (substitutersOf Map.empty [] (Just ("trusted-users = " <> latin1 <> "\nsubstituters = https://a # " <> latin1))), + runTest "a list setting holding a byte with no UTF-8 reading is refused under its own name" $ + let expected = "setting 'substituters' has invalid value 'https://caf\xFFFD.example': not valid UTF-8" + in assertEqual "list-bytes" (Left expected) (substitutersOf Map.empty [] (Just ("extra-binary-caches = https://" <> latin1 <> ".example"))), + runTest "a Boolean or integer setting holding such a byte is upstream's invalid-value error" $ + assertEqual + "scalar-bytes" + (Left "Boolean setting 'pure-eval' has invalid value 'true\xFFFD'", Left "setting 'max-call-depth' has invalid value '5\xFFFD'") + (ncPureEval <$> resolveTexts ["pure-eval = true\xE9"], depthOf "5\xE9"), + -- max-call-depth: a scalar under upstream's unsigned-integer grammar. + runTest "max-call-depth defaults to upstream's 10000" $ + assertEqual "depth-default" (Right 10000) (depth []), + runTest "max-call-depth parses a decimal" $ + assertEqual "depth-decimal" (Right 5) (depthOf "5"), + runTest "a higher source replaces max-call-depth" $ + assertEqual "depth-replace" (Right 7) (depth ["max-call-depth = 5", "max-call-depth = 7"]), + runTest "max-call-depth takes a binary unit suffix in either case" $ + assertEqual "depth-unit" (Right [10240, 5120, 1048576]) (traverse depthOf ["10K", "5k", "1M"]), + runTest "max-call-depth takes a leading plus and leading zeros" $ + assertEqual "depth-plus" (Right [5, 7]) (traverse depthOf ["+5", "007"]), + runTest "max-call-depth accepts the top of unsigned int" $ + assertEqual "depth-top" (Right 4294967295) (depthOf "4294967295"), + runTest "an invalid max-call-depth is refused with upstream's words" $ + assertEqual "depth-invalid" (Left "setting 'max-call-depth' has invalid value 'abc'") (depthOf "abc"), + runTest "max-call-depth refuses a sign, a fraction, hex, an unknown unit, an empty value and a second token" $ + assertEqual "depth-refused" (True, 6) (all refused rejects, length rejects), + runTest "max-call-depth refuses a value past unsigned int, a unit product included" $ + assertEqual "depth-range" True (refused "4294967296" && refused "5G"), + runTest "extra-max-call-depth is an unknown name, not an append" $ + assertEqual "depth-extra" (Right 10000) (depth ["extra-max-call-depth = 5"]), + -- Includes. + runTest "an include is spliced in at its line, resolved against the including file's directory" $ + let files = + fileMap + [ (systemConf, "substituters = https://a\ninclude site.conf\nextra-substituters = https://c"), + (etcNix "site.conf", "extra-substituters = https://b") + ] + in assertEqual "inline" (Right ["https://a", "https://b", "https://c"]) (substitutersOf files [asciiOsPath systemConf] Nothing), + runTest "a nested include resolves against the nested file, with .. collapsed" $ + let files = + fileMap + [ (systemConf, "include sub/one.conf"), + (etcNix "sub" "one.conf", "include ../two.conf"), + (etcNix "two.conf", "substituters = https://two") + ] + in assertEqual "nested" (Right ["https://two"]) (substitutersOf files [asciiOsPath systemConf] Nothing), + runTest "!include of a file that cannot be read is skipped" $ + let files = fileMap [(systemConf, "substituters = https://a\n!include missing.conf\nextra-substituters = https://b")] + in assertEqual "optional" (Right ["https://a", "https://b"]) (substitutersOf files [asciiOsPath systemConf] Nothing), + runTest "include of a missing file is an error in upstream's words, naming both files" $ + let files = fileMap [(systemConf, "include missing.conf")] + expected = "nix.conf: file '" <> T.pack (etcNix "missing.conf") <> "' included from '" <> T.pack systemConf <> "' not found" + in assertEqual "required" (Left expected) (substitutersOf files [asciiOsPath systemConf] Nothing), + -- A file that exists but will not open: upstream drops it, here a + -- required include of it is an error in its own words. + runTest "include of a file that exists but cannot be read is an error, not a silent drop" $ + let locked = etcNix "locked.conf" + readLocked path = Identity (if path == asciiOsPath locked then Left Config.ConfigFileUnreadable else Right "include locked.conf") + expected = "nix.conf: file '" <> T.pack locked <> "' included from '" <> T.pack systemConf <> "' cannot be read" + in assertEqual "unreadable" (Left expected) (ncSubstituters <$> runIdentity (Config.loadConfig readLocked [asciiOsPath systemConf] Nothing)), + runTest "!include of a file that exists but cannot be read is skipped" $ + let locked = etcNix "locked.conf" + readLocked path = Identity (if path == asciiOsPath locked then Left Config.ConfigFileUnreadable else Right "!include locked.conf\nsubstituters = https://a") + in assertEqual "unreadable-optional" (Right ["https://a"]) (ncSubstituters <$> runIdentity (Config.loadConfig readLocked [asciiOsPath systemConf] Nothing)), + runTest "an include cycle is refused rather than followed" $ + let files = fileMap [(systemConf, "include site.conf"), (etcNix "site.conf", "include nix.conf")] + in assertLeft "cycle" (substitutersOf files [asciiOsPath systemConf] Nothing), + runTest "an include with no path or two paths is a syntax error" $ + assertEqual "arity" [True, True, True] (map (either (const True) (const False) . resolveTexts . pure) ["include", "include a b", "!include"]), + runTest "a relative include from NIX_CONFIG is refused as not absolute" $ + let expected = "nix.conf: not an absolute path: '" <> T.pack ("." "rel.conf") <> "'" + in assertEqual "env-relative" (Left expected) (substitutersOf Map.empty [] (Just "include rel.conf")), + runTest "an absolute include from NIX_CONFIG is expanded" $ + let files = fileMap [(etcNix "x.conf", "substituters = https://x")] + in assertEqual "env-absolute" (Right ["https://x"]) (substitutersOf files [] (Just ("include " <> BS8.pack (etcNix "x.conf")))), + -- An include target is bytes from the line to the open (#244): the + -- file its bytes name is read, never the one a lossy decode names. + runTest "an include target with no UTF-8 reading opens the file its bytes name" $ + let target = latin1 <> ".conf" + including = fileMap [(systemConf, "include " <> target)] + decoy = maybe including (\name -> Map.insert (asciiOsPath etcNix OP. name) "substituters = https://replacement" including) (hostPathFromBytes (replaced <> ".conf")) + in case hostPathFromBytes target of + Just name -> + let files = Map.insert (asciiOsPath etcNix OP. name) "substituters = https://latin1" decoy + in assertEqual "include-bytes" (Right ["https://latin1"]) (substitutersOf files [asciiOsPath systemConf] Nothing) + Nothing -> + let expected = "nix.conf: file 'caf\xFFFD.conf' included from '" <> T.pack systemConf <> "' is not valid UTF-8, so it names no Windows file" + in assertEqual "include-bytes-windows" (Left expected) (substitutersOf decoy [asciiOsPath systemConf] Nothing), + runTest "!include of a target with no UTF-8 reading that names nothing goes on without it" $ + let files = fileMap [(systemConf, "!include " <> latin1 <> ".conf\nsubstituters = https://a")] + in assertEqual "optional-bytes" (Right ["https://a"]) (substitutersOf files [asciiOsPath systemConf] Nothing), + -- The directories a cascade names keep their bytes too, so the + -- system file under such a NIX_CONF_DIR, and an include beside a + -- file under such a config home, are the files those bytes name. + runTest "NIX_CONF_DIR holding a byte with no UTF-8 reading names the system file by its bytes" $ + let confDir = BS8.pack (etcNix ++ "-") <> latin1 + located = cascade {Config.clConfDir = Just confDir, Config.clUserConfFiles = Just ""} + in case hostPathFromBytes confDir of + Just dir -> + let files = Map.fromList [(dir OP. nixConfName, "include site.conf"), (dir OP. asciiOsPath "site.conf", "substituters = https://conf-dir")] + in assertEqual "conf-dir-bytes" (Right (Just (dir OP. nixConfName)), Right ["https://conf-dir"]) (firstPathOf located, substitutersAt files located Nothing) + Nothing -> assertLeft "conf-dir-bytes-windows" (firstPathOf located), + runTest "an include beside a user file under a config home holding such a byte resolves beneath it" $ + case hostPathFromBytes (BS8.pack (configHome ++ "-") <> latin1) of + Just home -> + let located = cascade {Config.clSystemConfDir = Nothing, Config.clConfigHome = home, Config.clConfigDirs = []} + userDir = home OP. asciiOsPath "nix" + files = Map.fromList [(userDir OP. nixConfName, "include more.conf"), (userDir OP. asciiOsPath "more.conf", "substituters = https://home-bytes")] + in assertEqual "home-bytes" (Right ["https://home-bytes"]) (substitutersAt files located Nothing) + Nothing -> assertEqual "home-bytes-windows" "mingw32" SI.os, + -- The cascade: which files, in which order, and who wins. + runTest "the cascade is the system file, XDG_CONFIG_DIRS back to front, then the config home" $ + assertEqual "order" (Right (map asciiOsPath [systemConf, xdgConf etcXdgLocal, xdgConf etcXdg, xdgConf configHome])) (Config.configFilePaths cascade), + runTest "the config home beats XDG_CONFIG_DIRS beats the system file" $ + assertEqual "home-wins" (Right ["https://home"]) (substitutersAt cascadeFiles cascade Nothing), + runTest "the first XDG_CONFIG_DIRS entry beats the later ones" $ + assertEqual "xdg-first" (Right ["https://xdg"]) (substitutersAt (Map.delete (asciiOsPath (xdgConf configHome)) cascadeFiles) cascade Nothing), + runTest "a listed file that cannot be read is absent, not an error" $ + assertEqual "absent" (Right ["https://system"]) (substitutersAt (Map.filterWithKey (\path _ -> path == asciiOsPath systemConf) cascadeFiles) cascade Nothing), + runTest "extra- in a stronger file widens what a weaker file set" $ + let files = fileMap [(systemConf, "trusted-public-keys = k1"), (xdgConf configHome, "extra-trusted-public-keys = k2")] + in assertEqual "widen-across-files" (Right ["k1", "k2"]) (fmap ncTrustedPublicKeys (Config.configFilePaths cascade >>= \paths -> resolveWith files paths Nothing)), + runTest "NIX_CONFIG beats every file" $ + assertEqual "env-wins" (Right ["https://env"]) (substitutersAt cascadeFiles cascade (Just "substituters = https://env")), + runTest "NIX_USER_CONF_FILES replaces the XDG files, first listed strongest" $ + let listed = cascade {Config.clUserConfFiles = Just (listVar [etcNix "a.conf", etcNix "b.conf"])} + in assertEqual "listed" (Right (map asciiOsPath [systemConf, etcNix "b.conf", etcNix "a.conf"])) (Config.configFilePaths listed), + runTest "an empty NIX_USER_CONF_FILES names no user files" $ + assertEqual "none" (Right [asciiOsPath systemConf]) (Config.configFilePaths cascade {Config.clUserConfFiles = Just ""}), + runTest "empty NIX_USER_CONF_FILES entries are dropped" $ + assertEqual "empties" (Right (map asciiOsPath [systemConf, etcNix "a.conf"])) (Config.configFilePaths cascade {Config.clUserConfFiles = Just (listVar ["", etcNix "a.conf", ""])}), + runTest "NIX_CONF_DIR moves the system file" $ + assertEqual "conf-dir" (Right (Just (asciiOsPath (etcXdg "nix.conf")))) (firstPathOf cascade {Config.clConfDir = Just (BS8.pack etcXdg)}), + runTest "an empty NIX_CONF_DIR is unset" $ + assertEqual "conf-dir-empty" (Right (Just (asciiOsPath systemConf))) (firstPathOf cascade {Config.clConfDir = Just ""}), + runTest "a relative NIX_CONF_DIR is refused with upstream's complaint" $ + assertEqual "conf-dir-relative" (Left "nix.conf: not an absolute path: 'rel'") (firstPathOf cascade {Config.clConfDir = Just "rel"}), + runTest "dot and dot-dot in NIX_CONF_DIR collapse, so the system file is named canonically" $ + assertEqual "conf-dir-canonical" (Right (Just (asciiOsPath systemConf))) (firstPathOf cascade {Config.clConfDir = Just (BS8.pack (root "etc" "x" ".." "." "nix"))}), + -- A UNC directory keeps its server on Windows, where System.FilePath + -- and std::filesystem both read it as the drive; a doubled POSIX + -- root is one root, as upstream's canonPath folds it. + runTest "a UNC NIX_CONF_DIR keeps its root, and its include resolves beneath it" $ + let (dir, expected) = + if SI.os == "mingw32" + then ("\\\\server\\share", "\\\\server\\share\\nix.conf") + else ("//server/share", "/server/share/nix.conf") + uncConf = takeDirectory expected "site.conf" + files = fileMap [(expected, "include site.conf"), (uncConf, "substituters = https://unc")] + unc = cascade {Config.clConfDir = Just (BS8.pack dir), Config.clUserConfFiles = Just ""} + in assertEqual "unc" (Right (Just (asciiOsPath expected)), Right ["https://unc"]) (firstPathOf unc, substitutersAt files unc Nothing), + runTest "a platform with no machine-wide directory has no system file" $ + assertEqual "no-system-dir" (Right (map asciiOsPath [xdgConf etcXdgLocal, xdgConf etcXdg, xdgConf configHome])) (Config.configFilePaths cascade {Config.clSystemConfDir = Nothing}), + runTest "NIX_CONF_DIR names a system file even where the platform has no directory for one" $ + assertEqual "conf-dir-no-default" (Right (Just (asciiOsPath (etcXdg "nix.conf")))) (firstPathOf cascade {Config.clSystemConfDir = Nothing, Config.clConfDir = Just (BS8.pack etcXdg)}) + ] + where + rejects = ["-1", "1.5", "0x10", "5X", "", "5 6"] + +-- | A test path as the config expander names it. Test paths spelled +-- this way are ASCII, which 'OP.unsafeFromChar' narrows to one path unit +-- exactly on every platform. +asciiOsPath :: FilePath -> OsPath +asciiOsPath = OP.pack . map OP.unsafeFromChar + +-- | Narinfo field validation gates the pipeline ahead of the signed +-- fingerprint: a malformed field must fail as a parse error before its +-- text can reach the fingerprint or anything downstream. +testNarInfoValidation :: IO [Bool] +testNarInfoValidation = do + putStrLn "substituter/narinfo-field-validation" + sequence + [ runTest "well-formed narinfo passes" $ + assertEqual "valid" (Right ()) (Subst.validateNarInfoFields sigTestNarInfo), + runTest "malformed StorePath rejected" $ + assertLeft "bad store path" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niStorePath = "/nix/store/zzz"}), + runTest "derivation StorePath rejected" $ + assertLeft "drv path" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niStorePath = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0.drv"}), + runTest "malformed reference rejected" $ + assertLeft "bad reference" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niReferences = ["../escape"]}), + runTest "malformed NarHash rejected" $ + assertLeft "bad narhash" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niNarHash = "sha256:nope"}), + runTest "negative NarSize rejected" $ + assertLeft "negative narsize" (Subst.validateNarInfoFields sigTestNarInfo {NarInfo.niNarSize = -1}), + runTest "field validation reports ahead of signature verification" $ + case sigTestSetup of + Left err -> Fail (T.pack err) + Right (cache, validSig, _) -> + case Subst.judgeNarInfo cache sigTestPath sigTestNarInfo {NarInfo.niStorePath = "/nix/store/zzz", NarInfo.niSigs = [validSig]} of + Subst.NarInfoFailed err + | "invalid narinfo" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected the field-validation error, got: " <> err) + other -> Fail ("expected a failed query, got: " <> T.pack (show other)), + -- Upstream skips a substitute for another path and one no trusted + -- key signed, and fails on a trusted key it cannot parse. + runTest "a narinfo for another path or unsigned is passed over, and a malformed key fails" $ + case sigTestSetup of + Left err -> Fail (T.pack err) + Right (cache, validSig, _) -> + let signed = sigTestNarInfo {NarInfo.niSigs = [validSig]} + malformedKey = case Subst.judgeNarInfo (sigTestCache "not-a-key") sigTestPath signed of + Subst.NarInfoFailed err | "invalid public key" `T.isPrefixOf` err -> Pass + other -> Fail ("expected a failed query, got: " <> T.pack (show other)) + in assertEqual "usable" (Subst.NarInfoUsable signed) (Subst.judgeNarInfo cache sigTestPath signed) + `andThen` assertEqual "unsigned" (Subst.NarInfoPassedOver "narinfo has no signatures") (Subst.judgeNarInfo cache sigTestPath sigTestNarInfo) + `andThen` assertEqual + "another path" + (Subst.NarInfoPassedOver ("narinfo names " <> NarInfo.niStorePath sigTestNarInfo)) + (Subst.judgeNarInfo cache (StorePath (T.replicate 32 "c") "hello-1.0") signed) + `andThen` malformedKey + ] + where + sigTestPath = StorePath (T.replicate 32 "a") "hello-1.0" + +-- --------------------------------------------------------------------------- +-- Tests: resolver static globals stay in sync with the root env +-- --------------------------------------------------------------------------- + +-- | The names upstream 2.24.9's base environment binds with default +-- settings, recorded from its source: every @addConstant@ and @addPrimOp@ +-- in @createBaseEnv@ (src/libexpr/primops.cc) and every @RegisterPrimOp@ +-- in libexpr and libflake not gated on an experimental feature, under the +-- name it registers. @__importNative@ and @__exec@ need +-- @allow-unsafe-native-code-during-evaluation@ and are not here. +upstreamBaseEnvNames :: Set.Set Text +upstreamBaseEnvNames = + Set.fromList + [ "__add", + "__addDrvOutputDependencies", + "__addErrorContext", + "__all", + "__any", + "__appendContext", + "__attrNames", + "__attrValues", + "__bitAnd", + "__bitOr", + "__bitXor", + "__catAttrs", + "__ceil", + "__compareVersions", + "__concatLists", + "__concatMap", + "__concatStringsSep", + "__convertHash", + "__currentSystem", + "__currentTime", + "__deepSeq", + "__div", + "__elem", + "__elemAt", + "__fetchurl", + "__filter", + "__filterSource", + "__findFile", + "__floor", + "__foldl'", + "__fromJSON", + "__functionArgs", + "__genList", + "__genericClosure", + "__getAttr", + "__getContext", + "__getEnv", + "__groupBy", + "__hasAttr", + "__hasContext", + "__hashFile", + "__hashString", + "__head", + "__intersectAttrs", + "__isAttrs", + "__isBool", + "__isFloat", + "__isFunction", + "__isInt", + "__isList", + "__isPath", + "__isString", + "__langVersion", + "__length", + "__lessThan", + "__listToAttrs", + "__mapAttrs", + "__match", + "__mul", + "__nixPath", + "__nixVersion", + "__parseDrvName", + "__partition", + "__path", + "__pathExists", + "__readDir", + "__readFile", + "__readFileType", + "__replaceStrings", + "__seq", + "__sort", + "__split", + "__splitVersion", + "__storeDir", + "__storePath", + "__stringLength", + "__sub", + "__substring", + "__tail", + "__toFile", + "__toJSON", + "__toPath", + "__toXML", + "__trace", + "__traceVerbose", + "__tryEval", + "__typeOf", + "__unsafeDiscardOutputDependency", + "__unsafeDiscardStringContext", + "__unsafeGetAttrPos", + "__warn", + "__zipAttrsWith", + "abort", + "baseNameOf", + "break", + "builtins", + "derivation", + "derivationStrict", + "dirOf", + "false", + "fetchGit", + "fetchMercurial", + "fetchTarball", + "fromTOML", + "import", + "isNull", + "map", + "null", + "placeholder", + "removeAttrs", + "scopedImport", + "throw", + "toString", + "true" + ] + +-- | The two @addConstant@ calls marked @impureOnly@, which upstream skips +-- under @pure-eval@. +upstreamImpureOnlyNames :: Set.Set Text +upstreamImpureOnlyNames = Set.fromList ["__currentSystem", "__currentTime"] + +-- | Binding accepts exactly the names upstream's base environment holds, +-- and the root environment binds exactly the names binding accepts, under +-- each policy, every one of them to a value that forces. +testStaticGlobalsSync :: IO [Bool] +testStaticGlobalsSync = do + putStrLn "resolve/static-globals-sync" + let pureNames = Set.difference upstreamBaseEnvNames upstreamImpureOnlyNames + unrestrictedRoot <- rootEnvNames unrestrictedPolicy + pureRoot <- rootEnvNames purePolicy + sequence + [ runTest "binding accepts upstream's base environment" $ + assertSameNames "static globals" upstreamBaseEnvNames staticGlobalNames, + runTest "pure evaluation drops upstream's impure-only constants" $ + assertEqual "impure-only" upstreamImpureOnlyNames impureOnlyGlobalNames + `andThen` assertSameNames "pure scope" pureNames (rootScopeNames purePolicy), + runTest "the root env binds exactly those names" $ + assertSameNames "root env" upstreamBaseEnvNames unrestrictedRoot + `andThen` assertSameNames "pure root env" pureNames pureRoot, + runTest "every root env name forces" $ + assertEqual + "names that fail to force" + [] + [ name + | name <- Set.toList upstreamBaseEnvNames, + evalNix ("builtins.seq " <> name <> " true") /= Right (VBool True) + ] + ] + where + rootEnvNames policy = case builtinEnv policy 0 [] of + Env envPtr -> do + scopePtr <- cenvLazyScope envPtr + pure (Set.fromList (attrSetKeys (AttrSet (castPtr scopePtr)))) + assertSameNames label expected actual = + assertEqual + (label <> ": (missing, extra)") + ([], []) + (Set.toList (Set.difference expected actual), Set.toList (Set.difference actual expected)) + +-- --------------------------------------------------------------------------- +-- Tests: variables are bound before evaluation (upstream's bindVars) +-- --------------------------------------------------------------------------- + +-- | Assert that binding rejects a source for the named variable, before +-- anything is evaluated. +assertUnbound :: Text -> Text -> Text -> TestResult +assertUnbound label source name = case parseNix testBaseDir testOrigin (TE.encodeUtf8 source) of + Left err -> assertEqual label (UndefinedVariable name) err + Right expr -> Fail (label <> ": bound, got " <> T.pack (show expr)) + +-- | Assert that every variable in a source binds. +assertBinds :: Text -> Text -> TestResult +assertBinds label source = assertRight label (parseNix testBaseDir testOrigin (TE.encodeUtf8 source)) (const Pass) + +-- | Upstream rejects a variable no scope binds and no @with@ could supply +-- while binding (nixexpr.cc, ExprVar::bindVars), wherever it sits; only a +-- name under a @with@ waits for evaluation. Each expectation here is +-- nix-instantiate 2.33.2's. +testUndefinedVariables :: IO [Bool] +testUndefinedVariables = do + putStrLn "resolve/undefined-variables" + sequence + [ runTest "an unbound variable in an unused let binding is rejected" $ + assertUnbound "unused-let" "let x = y; in 1" "y", + runTest "an unbound variable on a branch not taken is rejected" $ + assertUnbound "untaken-branch" "if true then 1 else y" "y", + runTest "tryEval has nothing to catch: binding fails first" $ + assertUnbound "tryEval" "builtins.tryEval (let x = y; in 1)" "y", + runTest "the failure reads as upstream's" $ + assertEvalError "message" "builtins.tryEval (let x = y; in 1)" "undefined variable 'y'", + runTest "the first unbound variable in source order is reported" $ + assertUnbound "first" "let a = b; c = d; in 1" "b", + runTest "a name under a with binds" $ + assertBinds "with-binds" "with {}; y", + runTest "a name no with supplies fails when evaluated" $ + assertEvalError "with-eval" "with {}; y" "undefined variable 'y'", + runTest "an unused binding may read a name only a with could supply" $ + assertEval "with-unused" "with {}; let x = y; in 1" (VInt 1), + runTest "a with supplies a name a let binding reads" $ + assertEval "with-let" "with { y = 3; }; let x = y; in x" (VInt 3), + runTest "a nested let shadows the enclosing one" $ + assertEval "let-shadow" "let y = 1; in let y = 2; x = y; in x" (VInt 2), + runTest "a nested rec reads the enclosing rec" $ + assertEval "rec-nested" "rec { a = 1; b = rec { c = a; }.c; }.b" (VInt 1), + runTest "a rec reading a name it does not define is rejected" $ + assertUnbound "rec-missing" "rec { a = b; }" "b", + runTest "a lambda formal shadows a with" $ + assertEval "formal-over-with" "(x: with { x = 2; }; x) 1" (VInt 1), + runTest "a formal default reads a sibling formal" $ + assertEval "formal-default" "({ a, b ? a }: b) { a = 3; }" (VInt 3), + runTest "an unbound formal default is rejected" $ + assertUnbound "formal-default-unbound" "{ a ? b }: a" "b", + runTest "inherit of an unbound name in a let is rejected" $ + assertUnbound "let-inherit" "let inherit x; in 1" "x", + runTest "inherit of an unbound name in a set is rejected" $ + assertUnbound "set-inherit" "{ inherit x; }" "x", + runTest "inherit of an unbound name in a rec is rejected" $ + assertUnbound "rec-inherit" "rec { inherit x; }" "x", + runTest "inherit reads a name only a with supplies" $ + assertEval "with-inherit" "with { x = 5; }; rec { inherit x; }.x" (VInt 5), + runTest "inherit under an empty with fails only when selected" $ + assertEvalError "with-inherit-missing" "with {}; { inherit x; }.x" "undefined variable 'x'", + runTest "inherit in a rec reads the enclosing binding, not its own" $ + assertEval "rec-inherit-outer" "(x: rec { inherit x; y = x; }.y) 4" (VInt 4), + runTest "inherit from an unbound source is rejected" $ + assertUnbound "inherit-from-unbound" "{ inherit (s) x; }" "s", + runTest "inherit from selects lazily" $ + assertEval "inherit-from-lazy" "let s = {}; in builtins.attrNames { inherit (s) x; } == [ \"x\" ]" (VBool True), + runTest "inherit from fails when the attribute is selected" $ + assertEvalFail "inherit-from-missing" "let s = {}; in { inherit (s) x; }.x", + runTest "an inherit clause cannot repeat a name" $ + assertParseFail "inherit-repeat" "let x = 1; in { inherit x x; }", + runTest "an inherit-from clause cannot repeat a name" $ + assertParseFail "inherit-from-repeat" "let s = { x = 1; }; in { inherit (s) x x; }", + runTest "__curPos is upstream syntax, not a variable" $ + assertEval "curpos" "if false then __curPos else 1" (VInt 1), + runTest "inherit in a static-key rec reads the enclosing rec" $ + assertEval "rec-inherit-static" "rec { q = 0; x = 1; y = rec { a = 1; inherit x; }; }.y.x" (VInt 1), + runTest "a __-prefixed builtin on a branch not taken binds" $ + assertEval "prefixed-untaken" "if false then __typeOf 1 else 2" (VInt 2), + runTest "a __-prefixed builtin is the builtin" $ + assertEval "prefixed-value" "__typeOf 1 == \"int\"" (VBool True), + runTest "a global is not shadowed by a with" $ + assertEval "prefixed-over-with" "with { __typeOf = 1; }; __typeOf 2 == \"int\"" (VBool True), + runTest "fetchMercurial binds as a builtin" $ + assertEval "fetchMercurial-binds" "builtins.typeOf fetchMercurial == \"lambda\"" (VBool True), + runTest "calling fetchMercurial fails as a builtin nova-nix lacks" $ + assertEvalError "fetchMercurial-call" "fetchMercurial {}" "unknown builtin 'fetchMercurial'", + runTest "pure evaluation leaves upstream's impure-only constants unbound" $ + assertEqual "pure-currentTime" (Left "undefined variable '__currentTime'") (evalNixWith purePolicy "if false then __currentTime else 1"), + runTest "pure evaluation binds the other globals" $ + assertEqual "pure-typeOf" (Right (VInt 1)) (evalNixWith purePolicy "if false then __typeOf else 1") + ] + +-- | The same check for files: upstream binds each file as it parses it, so +-- an import fails on an unbound variable the importing code never reaches, +-- and @scopedImport@ binds its scope's names around the file. The inherit +-- cases whose regression is a self-reference run here too. +testUndefinedVariablesIO :: IO [Bool] +testUndefinedVariablesIO = do + putStrLn "resolve/undefined-variables-io" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-undefined-variables" + branchFile = nixQuotedPath (testDir "branch.nix") + scopedFile = nixQuotedPath (testDir "scoped.nix") + scopedWithFile = nixQuotedPath (testDir "scoped-with.nix") + expectError label source expected = do + result <- evalNixIO testDir source + runTest label $ case result of + Left err -> assertEqual label expected err + Right val -> Fail (label <> ": expected an error, got " <> T.pack (show val)) + bracket_ + ( do + createDirectoryIfMissing True testDir + TIO.writeFile (testDir "branch.nix") "{ flag }:\nif flag then 1 else unboundName\n" + TIO.writeFile (testDir "scoped.nix") "if false then notInScope else fromScope\n" + TIO.writeFile (testDir "scoped-with.nix") "with { fromScope = \"with\"; }; fromScope\n" + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ expectError + "an import fails on an unbound variable on a branch not taken" + ("(import " <> branchFile <> ") { flag = true; }") + "undefined variable 'unboundName'", + expectError + "tryEval cannot catch an import that fails to bind" + ("builtins.tryEval (import " <> branchFile <> ")") + "undefined variable 'unboundName'", + runTestIO + "an import that is never forced does not fail" + testDir + ("let f = import " <> branchFile <> "; in 1") + (VInt 1), + expectError + "scopedImport binds against its scope" + ("builtins.scopedImport { fromScope = 7; } " <> scopedFile) + "undefined variable 'notInScope'", + runTestIO + "scopedImport scope names bind" + testDir + ("builtins.scopedImport { fromScope = 7; notInScope = 1; } " <> scopedFile) + (VInt 7), + runTestIO + "a scopedImport scope name is not shadowed by a with" + testDir + ("builtins.scopedImport { fromScope = 7; } " <> scopedWithFile) + (VInt 7), + -- Evaluated where a self-reference is caught as infinite recursion + -- rather than looping, which is what reading the inherited name + -- from the rec's own scope used to do. + runTestIO + "inherit in a dynamic-key rec reads the enclosing rec, not its own" + testDir + "rec { ${\"q\"} = 0; x = 1; y = rec { ${\"a\"} = 1; inherit x; }; }.y.x" + (VInt 1), + expectError + "inherit of a name no with supplies is undefined, not the rec's own" + "with {}; rec { ${\"a\"} = 1; inherit x; }.x" + "undefined variable 'x'" + ] + +-- --------------------------------------------------------------------------- +-- Main +-- --------------------------------------------------------------------------- + +-- --------------------------------------------------------------------------- +-- Tests: byte-indexed string semantics (issue #34) +-- --------------------------------------------------------------------------- + +-- | The pinned byte-semantics suite: a Nix string is a byte string, so +-- lengths, slices, regexes, and replaceStrings all index BYTES, and the +-- hash of a value is the hash of exactly its bytes. Multibyte content +-- enters through source literals here (the parser interns their UTF-8); +-- arbitrary/invalid bytes enter via readFile in the IO group below. +testByteStringSemantics :: IO [Bool] +testByteStringSemantics = do + putStrLn "eval/byte-strings" + sequence + [ -- stringLength / substring index bytes + runTest "stringLength counts bytes" $ + assertEval "len-bytes" "builtins.stringLength \"\228\"" (VInt 2), + runTest "substring slices at byte offsets" $ + assertEval "substr-bytes" "builtins.stringLength (builtins.substring 0 1 \"\228\")" (VInt 1), + runTest "mid-codepoint slices reassemble byte-exactly" $ + assertEval + "substr-reassemble" + "builtins.substring 0 1 \"\228\" + builtins.substring 1 1 \"\228\" == \"\228\"" + (VBool True), + -- the hash sees exactly the value's bytes + runTest "hashString of a mid-codepoint slice is the raw byte's sha256" $ + assertEval + "hash-midbyte" + "builtins.hashString \"sha256\" (builtins.substring 0 1 \"\228\")" + (mkStr (Hash.bytesToHexText (sha256Digest (BS.take 1 (TE.encodeUtf8 "\228"))))), + runTest "hashString of valid UTF-8 is unchanged by the byte layer" $ + assertEval + "hash-utf8-stable" + "builtins.hashString \"sha256\" \"\228\"" + (mkStr (Hash.bytesToHexText (sha256Digest (TE.encodeUtf8 "\228")))), + -- regexes run over bytes ('.' matches ONE byte) + runTest "match . does not match a 2-byte char" $ + assertEval "match-one-byte" "builtins.match \".\" \"\228\"" VNull, + runTest "match .. matches a 2-byte char" $ + assertEval "match-two-bytes" "builtins.match \"..\" \"\228\" == []" (VBool True), + runTest "a multibyte pattern matches its own bytes" $ + assertEval "match-multibyte-pattern" "builtins.match \"\228\" \"\228\" == []" (VBool True), + -- replaceStrings with an empty 'from' steps one BYTE + runTest "replaceStrings empty-from inserts between bytes" $ + assertEval + "replace-empty-from" + "builtins.stringLength (builtins.replaceStrings [\"\"] [\"-\"] \"\228\")" + (VInt 5), + runTest "replaceStrings empty-from result is byte-exact" $ + assertEval + "replace-empty-from-bytes" + "builtins.replaceStrings [\"\"] [\"-\"] \"\228\" == \"-\" + builtins.substring 0 1 \"\228\" + \"-\" + builtins.substring 1 1 \"\228\" + \"-\"" + (VBool True), + -- strict-decode boundaries reject bytes that are not UTF-8 + runTest "toJSON rejects invalid UTF-8" $ + assertEvalFail "tojson-invalid" "builtins.toJSON (builtins.substring 0 1 \"\228\")", + runTest "getAttr rejects an invalid-UTF-8 attr name" $ + assertEvalFail "getattr-invalid" "builtins.getAttr (builtins.substring 0 1 \"\228\") {}", + -- toXML passes bytes through raw (upstream's serializer never validates) + runTest "toXML passes a mid-codepoint byte through" $ + assertEval + "toxml-bytes" + "builtins.stringLength (builtins.toXML (builtins.substring 0 1 \"\228\")) == builtins.stringLength (builtins.toXML \"x\")" + (VBool True), + -- a search-path miss is a CATCHABLE error (upstream ThrownError; + -- nixpkgs' impure.nix relies on tryEval catching it) + runTest "search-path miss is tryEval-catchable" $ + assertEval + "findFile-catchable" + "(builtins.tryEval (builtins.findFile builtins.nixPath \"nope-missing\")).success" + (VBool False) + ] + +-- | readFile returns the file's RAW BYTES: BOMs survive, UTF-16 is not +-- transcoded, invalid UTF-8 is representable, and only NUL is rejected. +-- The expected hashes are computed from the fixture bytes themselves, so +-- the assertions pin "hash of the value = hash of the file's bytes". +testByteStringSemanticsIO :: IO [Bool] +testByteStringSemanticsIO = do + putStrLn "eval/readfile-bytes-io" + tmpDir <- getTemporaryDirectory + let testDir = tmpDir "nova-nix-bytefile-test" + bomBytes = BS.pack [0xEF, 0xBB, 0xBF] <> "hi" + -- UTF-16LE BOM + U+0101 (both payload bytes nonzero, so no NUL): + -- raw passthrough is observable as 4 bytes instead of a decoded char. + utf16Bytes = BS.pack [0xFF, 0xFE, 0x01, 0x01] + -- UTF-16LE ASCII interleaves NUL bytes - upstream readFile REJECTS it. + utf16AsciiBytes = BS.pack [0xFF, 0xFE, 0x68, 0x00, 0x69, 0x00] + invalidBytes = "a" <> BS.singleton 0xFF <> "b" + nulBytes = "a" <> BS.singleton 0x00 <> "b" + bracket_ + ( do + createDirectoryIfMissing True testDir + BS.writeFile (testDir "bom.bin") bomBytes + BS.writeFile (testDir "utf16.bin") utf16Bytes + BS.writeFile (testDir "utf16-ascii.bin") utf16AsciiBytes + BS.writeFile (testDir "invalid.bin") invalidBytes + BS.writeFile (testDir "nul.bin") nulBytes + BS.writeFile (testDir "umlaut.bin") (TE.encodeUtf8 "\228") + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ runTestIO + "readFile keeps a BOM (raw bytes)" + testDir + "builtins.stringLength (builtins.readFile ./bom.bin)" + (VInt 5), + runTestIO + "readFile does not transcode UTF-16" + testDir + "builtins.stringLength (builtins.readFile ./utf16.bin)" + (VInt 4), + runTestIOFail + "readFile rejects UTF-16 ASCII (its NUL bytes)" + testDir + "builtins.readFile ./utf16-ascii.bin", + runTestIO + "readFile passes invalid UTF-8 through" + testDir + "builtins.stringLength (builtins.readFile ./invalid.bin)" + (VInt 3), + runTestIO + "readFile bytes hash as read (BOM file)" + testDir + "builtins.hashString \"sha256\" (builtins.readFile ./bom.bin)" + (mkStr (Hash.bytesToHexText (sha256Digest bomBytes))), + runTestIO + "readFile bytes hash as read (UTF-16 file)" + testDir + "builtins.hashString \"sha256\" (builtins.readFile ./utf16.bin)" + (mkStr (Hash.bytesToHexText (sha256Digest utf16Bytes))), + runTestIO + "readFile of invalid UTF-8 hashes its raw bytes" + testDir + "builtins.hashString \"sha256\" (builtins.readFile ./invalid.bin)" + (mkStr (Hash.bytesToHexText (sha256Digest invalidBytes))), + runTestIO + "readFile round-trips a multibyte literal" + testDir + "builtins.readFile ./umlaut.bin == \"\228\"" + (VBool True), + runTestIOFail + "readFile rejects an embedded NUL" + testDir + "builtins.readFile ./nul.bin" + ] + +-- | A file is lexed as its bytes, as upstream reads it (eval.cc, +-- @parseExprFromFile@ at 2.24.9): a string literal in one keeps a byte +-- that is not UTF-8. A byte order mark selects UTF-16, read as its UTF-8, +-- or marks UTF-8. +testSourceBytesIO :: IO [Bool] +testSourceBytesIO = do + putStrLn "parser/source-bytes-io" + tmpDir <- getTemporaryDirectory + let testDir = tmpDir "nova-nix-source-bytes-test" + invalid = BS.pack [0x61, 0xFF, 0x62] + named = "{ name = \"caf\233\"; }" + name = VStr (TE.encodeUtf8 "caf\233") emptyContext + bracket_ + ( do + createDirectoryIfMissing True testDir + BS.writeFile (testDir "invalid.nix") ("\"" <> invalid <> "\"") + BS.writeFile (testDir "utf16le.nix") (BS.pack [0xFF, 0xFE] <> TE.encodeUtf16LE named) + BS.writeFile (testDir "utf16be.nix") (BS.pack [0xFE, 0xFF] <> TE.encodeUtf16BE named) + BS.writeFile (testDir "utf8mark.nix") (BS.pack [0xEF, 0xBB, 0xBF] <> TE.encodeUtf8 named) + ) + ( do + exists <- doesDirectoryExist testDir + when exists (removeDirectoryRecursive testDir) + ) + $ sequence + [ runTestIO "a string literal in a file keeps a byte that is not UTF-8" testDir "import ./invalid.nix" (VStr invalid emptyContext), + runTestIO "a UTF-16 LE file with a byte order mark is read" testDir "(import ./utf16le.nix).name" name, + runTestIO "a UTF-16 BE file with a byte order mark is read" testDir "(import ./utf16be.nix).name" name, + runTestIO "a UTF-8 file with a byte order mark is read" testDir "(import ./utf8mark.nix).name" name + ] + +main :: IO () +main = + getArgs >>= \case + [flag, name] | flag == arenaGuardChildFlag -> arenaGuardChild name + [flag, source] | flag == evalChildFlag -> bracket_ arenaInit arenaDestroy (evalChild source) + _ -> withRunTempRoot (bracket_ arenaInit arenaDestroy runSuite) + +-- | Give the run a temporary root of its own and point the process's +-- temporary directory at it, so every fixture the suite derives from +-- 'getTemporaryDirectory' (each under a fixed name) is this run's alone +-- and two suites running at once cannot delete each other's (#254). +-- @TMPDIR@ is what POSIX reads, @TMP@ and @TEMP@ what Windows' +-- @GetTempPath@ reads; a child process inherits them. The root is named +-- for this process, so no live run shares it, and one a crashed run left +-- under the same PID is cleared first. +withRunTempRoot :: IO a -> IO a +withRunTempRoot action = do + base <- getTemporaryDirectory + pid <- Proc.getCurrentPid + let root = base ("nova-nix-test-" <> show pid) + Dir.removePathForcibly root + Dir.createDirectory root + mapM_ (`setEnv` root) ["TMPDIR", "TMP", "TEMP"] + action `finally` Dir.removePathForcibly root + +-- | Every group, under the one arena bracket. +runSuite :: IO () +runSuite = do + hSetBuffering stdout LineBuffering + putStrLn "nova-nix test suite" + putStrLn "===================" + results <- + concat + <$> sequence + [ testExprTypes, + testStorePaths, + testDerivation, + testTrivialBuildIO, + testBuildLogIO, + testSourceDateEpochIO, + testScrubbedBuildEnvIO, + testUnpackBuildIO, + testDependentBuildIO, + testReferenceClosureIO, + testOutputOrderIO, + testOutputCycleBuildIO, + testEvalFidelity, + testUpstreamConformance, + testHashHelpers, + testFetchMirrors, + testSubstituterRetry, + testPkgsFetchurl, + testStage0Pe32Chain, + testMesWindows, + testNarKnownAnswer, + testFetchGitTransport, + testFetchGitShallow, + testFetchGitPins, + testPathInterp, + testOutPathCoercion, + testFetchCache, + testExecWrapper, + testAttrPath, + testScratchDirs, + testEvalLiterals, + testEvalVariables, + testEvalArithmetic, + testEvalComparison, + testEvalLogic, + testEvalStrings, + testEvalIfAssert, + testEvalLet, + testEvalAttrs, + testValuePrinter, + testCoercionErrors, + testResultPrinter, + testEvalRecAttrs, + testEvalLists, + testEvalLambda, + testEvalWith, + testEvalBuiltins, + testFromTOML, + testEvalErrors, + testListCoercion, + testEvalHigherOrder, + testBuiltinArgumentOrder, + testLexer, + testLineEndings, + testParserExprs, + testParserErrors, + testSourceBytes, + testParserIntegration, + testStaticGlobalsSync, + testUndefinedVariables, + testUndefinedVariablesIO, + testBatch1, + testBatch2, + testBatch3, + testBatch4, + testBatch5, + testBatch6, + testBatch7, + testImportPure, + testImportIO, + testUnsafeGetAttrPos, + testBlackholeRecoveryIO, + testDerivationTraceIO, + testFirstArgumentOrderIO, + testTraceVerboseOff, + testStorePathLinksIO, + testDeepContextClosureIO, + testDerivationFields, + testDerivationPathFieldsIO, + testPathArguments, + testPathArgumentsIO, + testPathFilterIO, + testPathSymlinkIO, + testInterpolatedSymlinkIO, + testSourceErrorMessage, + testSourceReadErrorsIO, + testBatchA, + testBatchAIO, + testEnvironmentBytes, + testBatchB, + testBatchC, + testBatchCIO, + testBlackhole, + testCallDepth, + testBatchD, + testBatchE, + testBatchEIO, + testBatchF, + testBatchG, + testBatchH, + testDerivationWrapper, + testStringContext, + testContextHelpers, + testContextPropagation, + testDrvContext, + testStructuredAttrs, + testDepGraph, + testRealise, + testSubstituter, + testCaseSensitiveVolumeIO, + testFoldingVolumeIO, + testPathLocks, + testExecBit, + testVerifySigs, + testNarInfoValidation, + testNixConfig, + testPushPure, + testPushClosureIO, + testBuildOrchestrator, + testPassAsFile, + testStoreDB, + testParseStorePath, + testStoreOps, + testStoreDelete, + testGcPure, + testStoreGC, + testSymlinkWalksIO, + testLinkOrdering, + testFromATerm, + testBuilder, + testE2E, + testExecWrapperCLI, + testUncaughtIOFailureCLI, + testPhase4, + testPhase4IO, + testToJSONPathIO, + testByteStringSemantics, + testByteStringSemanticsIO, + testSourceBytesIO, + testSymbol, + testCAttrSet, + testCThunk, + testArenaGuard, + testBytecodeCompile, + testBytecodeCountSpill, + testBytecodePerElement, + testValueCountWidths, + testStoreNameSinks, + testNarNameSafety, + testStoreNameSinksIO, + testClassIFollowups, + testClassIFollowupsIO, + testAbsolutePathStrings, + testEvalPolicyRules, + testEvalPolicyIO, + testDrivelessPathsIO, + testEvalPolicyCLI, + testResultPrinterCLI, + testConfigBytesCLI, + testInterruptsPropagate + ] + let total = length results + passed = length (filter id results) + failed = total - passed + putStrLn $ "\n" ++ show passed ++ "/" ++ show total ++ " passed" + if failed > 0 + then do + putStrLn $ show failed ++ " FAILED" + exitFailure + else do + putStrLn "All tests passed." + exitSuccess + +-- --------------------------------------------------------------------------- +-- Tests: evaluation policy - restricted and pure modes (#75) +-- --------------------------------------------------------------------------- + +-- | A string naming a relative path is refused wherever a path is coerced +-- from a string, as upstream's coerceToPath refuses it ("string '%s' +-- doesn't represent an absolute path", observed from nix-instantiate +-- 2.33.2 in every mode). Load bearing for the access policy: a relative +-- string would be checked against one location and opened at another. +testAbsolutePathStrings :: IO [Bool] +testAbsolutePathStrings = do + putStrLn "eval/absolute-path-strings" + tmpBase <- getTemporaryDirectory + let testDir = tmpBase "nova-nix-test-abs-strings" + relativeRefused label source = + runTestM label $ do + result <- evalNixIO testDir source + pure $ case result of + Left err + | "string 'foo' doesn't represent an absolute path" `T.isInfixOf` err -> Pass + | otherwise -> Fail ("expected the absolute-path refusal, got: " <> err) + Right val -> Fail ("expected a refusal, got: " <> T.pack (show val)) + bracket_ + (createDirectoryIfMissing True testDir >> BS.writeFile (testDir "foo") "1\n") + (forceRemoveIfExists testDir) + $ sequence + [ relativeRefused "readFile of a relative string" "builtins.readFile \"foo\"", + relativeRefused "import of a relative string" "import \"foo\"", + relativeRefused "pathExists of a relative string is an error, not false" "builtins.pathExists \"foo\"", + relativeRefused "readDir of a relative string" "builtins.readDir \"foo\"", + relativeRefused "readFileType of a relative string" "builtins.readFileType \"foo\"", + relativeRefused "hashFile of a relative string" "builtins.hashFile \"sha256\" \"foo\"", + relativeRefused "scopedImport of a relative string" "builtins.scopedImport { } \"foo\"", + -- The search-path miss carries upstream's hint, byte for byte. + runTest "a search path miss names the hint" $ + assertEqual + "miss" + (Left "file 'nope' was not found in the Nix search path (add it using $NIX_PATH or -I)") + (evalNix "") + ] + +-- | The policies under test. +restrictedPolicy, purePolicy :: EvalPolicy +restrictedPolicy = unrestrictedPolicy {epRestrictEval = True} +purePolicy = unrestrictedPolicy {epPureEval = True} + +-- | Parse and evaluate in 'PureEval' with the given policy's builtins +-- table, for the constants the table itself decides. +evalNixWith :: EvalPolicy -> Text -> Either Text NixValue +evalNixWith policy source = case parseNixWithScope (rootScopeNames policy) testBaseDir testOrigin (TE.encodeUtf8 source) of + Left err -> Left (sourceFailure err) + Right expr -> runPureEval (eval (builtinEnv policy 0 []) expr) + +-- | The pure rules behind the modes, each pinned to upstream's code at +-- 2.24.9: CanonPath::isAllowed over the allow list, isAllowedURI and +-- checkURI over allowed-uris, the git input's URL form, the nix.conf +-- settings, and the builtins table under pure-eval. +testEvalPolicyRules :: IO [Bool] +testEvalPolicyRules = do + putStrLn "eval/policy-rules" + let oneRoot = allowPathIn "/a/b" noAllowedPaths + twoRoots = allowPathIn "/x" oneRoot + driveRoot = allowPathIn "C:/a/b" noAllowedPaths + github = ["https://github.com/NixOS"] + -- Successive nix.conf texts, weakest first, served to the expander + -- as files. + config texts = + let paths = [asciiOsPath ("/policy/" ++ show index ++ ".conf") | index <- [1 .. length texts]] + files = Map.fromList (zip paths texts) + readFrom path = Identity (maybe (Left Config.ConfigFileMissing) Right (Map.lookup path files)) + in runIdentity (Config.loadConfig readFrom paths Nothing) + cfgPure = fmap ncPureEval . config + cfgRestrict = fmap ncRestrictEval . config + cfgUris = fmap ncAllowedUris . config + sequence + [ -- CanonPath::isAllowed + runTest "an allowed prefix admits itself" $ + assertEqual "self" True (isAllowedPath oneRoot "/a/b"), + runTest "an allowed prefix admits what lies within it" $ + assertEqual "within" True (isAllowedPath oneRoot "/a/b/c/d"), + runTest "an allowed prefix admits its ancestors" $ + assertEqual "ancestor" True (isAllowedPath oneRoot "/a") `andThen` assertEqual "root" True (isAllowedPath oneRoot "/"), + runTest "a sibling sharing a text prefix is not within" $ + assertEqual "sibling" False (isAllowedPath oneRoot "/a/bc"), + runTest "a path beside the prefix is refused" $ + assertEqual "beside" False (isAllowedPath oneRoot "/a/c") `andThen` assertEqual "elsewhere" False (isAllowedPath twoRoots "/y"), + runTest "nothing allowed admits nothing, the root included" $ + assertEqual "empty" False (isAllowedPath noAllowedPaths "/") `andThen` assertEqual "empty-etc" False (isAllowedPath noAllowedPaths "/etc"), + runTest "the spelling of an allowed prefix is canonicalized" $ + assertEqual "canon" True (isAllowedPath (allowPathIn "/a//b/./" noAllowedPaths) "/a/b/c"), + -- The rules are platform-independent, so a Windows path value + -- (C:/..., the drive designator its first component) is decided + -- the same on every host. + runTest "a drive designator is the first component" $ + assertEqual "within" True (isAllowedPath driveRoot "C:/a/b/c") + `andThen` assertEqual "self" True (isAllowedPath driveRoot "C:/a/b") + `andThen` assertEqual "drive-root" True (isAllowedPath driveRoot "C:/") + `andThen` assertEqual "beside" False (isAllowedPath driveRoot "C:/a/c") + `andThen` assertEqual "sibling" False (isAllowedPath driveRoot "C:/a/bc") + `andThen` assertEqual "other-drive" False (isAllowedPath driveRoot "D:/a/b/c") + `andThen` assertEqual "rootless" False (isAllowedPath driveRoot "/a/b/c") + `andThen` assertEqual "first" "C:/" (joinComponents (take 1 (pathComponents "C:/a/b"))) + `andThen` assertEqual "first-posix" "/a" (joinComponents (take 1 (pathComponents "/a/b"))), + -- isAllowedURI + runTest "a URI equal to a prefix is allowed" $ + assertEqual "equal" True (isAllowedUri github "https://github.com/NixOS"), + runTest "a URI under a prefix at a slash boundary is allowed" $ + assertEqual "subpath" True (isAllowedUri github "https://github.com/NixOS/patchelf.git"), + runTest "a prefix does not admit a longer name" $ + assertEqual "github.co" False (isAllowedUri ["https://github.co"] "https://github.com") + `andThen` assertEqual "NixOSx" False (isAllowedUri github "https://github.com/NixOSx"), + runTest "a prefix ending in a slash admits below it but not itself" $ + assertEqual "below" True (isAllowedUri ["https://a/dir/"] "https://a/dir/x") + `andThen` assertEqual "itself" False (isAllowedUri ["https://a/dir/"] "https://a/dir"), + runTest "a bare scheme prefix admits its whole scheme" $ + assertEqual "https:" True (isAllowedUri ["https:"] "https://anything/at/all") + `andThen` assertEqual "git+file:" True (isAllowedUri ["git+file:"] "git+file:///repo?exportIgnore=1") + `andThen` assertEqual "http:" False (isAllowedUri ["https:"] "http://x"), + -- checkURI + runTest "nothing is checked unless restrict-eval is on" $ + assertEqual "off" (Right ()) (uriAccess defaultStoreDir purePolicy noAllowedPaths "https://x"), + runTest "a URI outside the list is refused with upstream's wording" $ + assertEqual "refused" (Left "access to URI 'https://x/y' is forbidden in restricted mode") (uriAccess defaultStoreDir restrictedPolicy noAllowedPaths "https://x/y"), + runTest "a path URI is checked against the allowed paths" $ + assertEqual "allowed" (Right ()) (uriAccess defaultStoreDir restrictedPolicy oneRoot "/a/b/f") + `andThen` assertEqual "refused" (Left "access to absolute path '/etc/passwd' is forbidden in restricted mode") (uriAccess defaultStoreDir restrictedPolicy oneRoot "/etc/passwd"), + runTest "a file URL is checked as its path, rooted" $ + assertEqual "allowed" (Right ()) (uriAccess defaultStoreDir restrictedPolicy oneRoot "file:///a/b/f") + `andThen` assertEqual "rooted" (Left "access to absolute path '/etc/passwd' is forbidden in restricted mode") (uriAccess defaultStoreDir restrictedPolicy oneRoot "file://etc/passwd"), + runTest "a file URL with a drive is checked as that drive's path" $ + assertEqual "allowed" (Right ()) (uriAccess defaultStoreDir restrictedPolicy driveRoot "file://C:/a/b/f") + `andThen` assertEqual "refused" (Left "access to absolute path 'C:/a/c' is forbidden in restricted mode") (uriAccess defaultStoreDir restrictedPolicy driveRoot "file://C:/a/c"), + -- The path a file URL names with no drive is checked on the store's + -- drive, where the fetch reads it, not on the current one. + runTest "a path or file URL with no drive is checked on the store's drive" $ + assertEqual "path" (Right ()) (uriAccess windowsStoreDir restrictedPolicy driveRoot "/a/b/f") + `andThen` assertEqual "url" (Right ()) (uriAccess windowsStoreDir restrictedPolicy driveRoot "file:///a/b/f") + `andThen` assertEqual "rootless" (Right ()) (uriAccess windowsStoreDir restrictedPolicy driveRoot "file://a/b/f") + `andThen` assertEqual "named" (Left "access to absolute path 'C:/etc/passwd' is forbidden in restricted mode") (uriAccess windowsStoreDir restrictedPolicy driveRoot "file:///etc/passwd") + `andThen` assertEqual "other-drive" (Left "access to absolute path 'D:/a/b/f' is forbidden in restricted mode") (uriAccess (StoreDir "D:\\s") restrictedPolicy driveRoot "/a/b/f"), + runTest "the path refusal names pure mode when it is on" $ + assertEqual "pure" "access to absolute path '/etc' is forbidden in pure evaluation mode (use '--impure' to override)" (forbiddenPathMessage purePolicy "/etc") + `andThen` assertEqual "both" "access to absolute path '/etc' is forbidden in pure evaluation mode (use '--impure' to override)" (forbiddenPathMessage purePolicy {epRestrictEval = True} "/etc"), + -- Input::toURLString for a git input (strings observed from + -- nix-instantiate 2.33.2, whose renderer is 2.24.9's) + runTest "an https url renders with git+ and exportIgnore" $ + assertEqual "https" "git+https://github.com/NixOS/patchelf.git?exportIgnore=1" (gitInputUrl (gitInput "https://github.com/NixOS/patchelf.git")), + runTest "a ref follows exportIgnore in key order" $ + assertEqual "ref" "git+https://github.com/NixOS/patchelf.git?exportIgnore=1&ref=master" (gitInputUrl (gitInput "https://github.com/NixOS/patchelf.git") {fgaRef = Just "master"}), + runTest "a rev renders lowercase after ref" $ + assertEqual "rev" "git+https://h/r?exportIgnore=1&ref=main&rev=aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" (gitInputUrl (gitInput "https://h/r") {fgaRef = Just "main", fgaRev = Just "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"}), + runTest "shallow renders as a flag" $ + assertEqual "shallow" "git+ssh://git@github.com/NixOS/patchelf.git?exportIgnore=1&shallow=1" (gitInputUrl (gitInput "ssh://git@github.com/NixOS/patchelf.git") {fgaShallow = True}), + runTest "submodules replaces exportIgnore" $ + assertEqual "submodules" "git+https://h/r?submodules=1" (gitInputUrl (gitInput "https://h/r") {fgaSubmodules = True}), + runTest "a bare path becomes a file URL" $ + assertEqual "path" "git+file:///p/repo?exportIgnore=1" (gitInputUrl (gitInput "/p/repo")), + runTest "an scp-like remote becomes ssh" $ + assertEqual "scp" "git+ssh://git@github.com/NixOS/patchelf.git?exportIgnore=1" (gitInputUrl (gitInput "git@github.com:NixOS/patchelf.git")), + runTest "the git scheme keeps its name" $ + assertEqual "git" "git://h/r?exportIgnore=1" (gitInputUrl (gitInput "git://h/r")), + runTest "a path is percent-encoded as upstream encodes it" $ + assertEqual "space" "git+file:///p/my%20repo?exportIgnore=1" (gitInputUrl (gitInput "/p/my repo")), + -- What a fetch hands curl and git: a local path on the drive the + -- evaluator reads it on, in the file://C:/ form the URI gate reads. + runTest "a file URL with no drive reaches the tool on the store's drive" $ + assertEqual "file" (Right "file://C:/probe/f.txt") (onWindowsStore (localFileUrl "file:///probe/f.txt")) + `andThen` assertEqual "drive" (Right "file://D:/probe/f.txt") (onWindowsStore (localFileUrl "file://D:/probe/f.txt")) + `andThen` assertEqual "rootless" (Right "file://probe/f.txt") (onWindowsStore (localFileUrl "file://probe/f.txt")) + `andThen` assertEqual "store" (Right "file:///nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x") (onWindowsStore (localFileUrl "file:///nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-x")) + `andThen` assertEqual "https" (Right "https://h/x") (onWindowsStore (localFileUrl "https://h/x")) + `andThen` assertEqual "posix" (Right "file:///probe/f.txt") (onPosixStore (localFileUrl "file:///probe/f.txt")), + runTest "a local git remote with no drive reaches git on the store's drive" $ + assertEqual "bare" (Right "C:/probe/repo") (onWindowsStore (gitRemote "/probe/repo")) + `andThen` assertEqual "file" (Right "file://C:/probe/repo") (onWindowsStore (gitRemote "file:///probe/repo")) + `andThen` assertEqual "scp" (Right "git@github.com:NixOS/patchelf.git") (onWindowsStore (gitRemote "git@github.com:NixOS/patchelf.git")) + `andThen` assertEqual "unc" (Right "//server/share/repo") (onWindowsStore (gitRemote "//server/share/repo")) + `andThen` assertEqual "unc-url" (Right "file:////server/share/repo") (onWindowsStore (gitRemote "file:////server/share/repo")) + `andThen` assertEqual "https" (Right "https://h/r") (onWindowsStore (gitRemote "https://h/r")) + `andThen` assertEqual "posix" (Right "/probe/repo") (onPosixStore (gitRemote "/probe/repo")), + -- nix.conf + runTest "pure-eval and restrict-eval parse upstream's Boolean spellings" $ + assertEqual "true" (Right True) (cfgPure ["pure-eval = true"]) + `andThen` assertEqual "yes" (Right True) (cfgPure ["pure-eval = yes"]) + `andThen` assertEqual "1" (Right True) (cfgRestrict ["restrict-eval = 1"]) + `andThen` assertEqual "false" (Right False) (cfgPure ["pure-eval = true", "pure-eval = false"]) + `andThen` assertEqual "no" (Right False) (cfgRestrict ["restrict-eval = no"]) + `andThen` assertEqual "0" (Right False) (cfgRestrict ["restrict-eval = 0"]), + runTest "a misspelled Boolean is an error with upstream's wording" $ + assertEqual "typo" (Left "Boolean setting 'pure-eval' has invalid value 'ture'") (cfgPure ["pure-eval = ture"]), + runTest "allowed-uris is a list and extra- appends to it" $ + assertEqual "uris" (Right ["https://a", "https://b", "https://c"]) (cfgUris ["allowed-uris = https://a https://b", "extra-allowed-uris = https://c"]), + runTest "extra- on a Boolean names no setting and is ignored" $ + assertEqual "extra-bool" (Right False) (cfgPure ["extra-pure-eval = true"]), + runTest "the default config has both modes off" $ + assertEqual "defaults" (Right (False, False, [])) ((\c -> (ncRestrictEval c, ncPureEval c, ncAllowedUris c)) <$> config []), + -- the builtins table + runTest "currentTime and currentSystem are absent under pure-eval" $ + assertEqual "time" (Right (VBool False)) (evalNixWith purePolicy "builtins ? currentTime") + `andThen` assertEqual "system" (Right (VBool False)) (evalNixWith purePolicy "builtins ? currentSystem") + `andThen` assertEqual "time-restricted" (Right (VBool True)) (evalNixWith restrictedPolicy "builtins ? currentTime") + `andThen` assertEqual "time-default" (Right (VBool True)) (evalNixWith unrestrictedPolicy "builtins ? currentSystem") + ] + where + onWindowsStore = runStubStoreEvalWith (stubEnv Map.empty) {seStoreDir = windowsStoreDir} + onPosixStore = runStubStoreEvalWith (stubEnv Map.empty) + gitInput url = + FetchGitArgs + { fgaUrl = url, + fgaName = "source", + fgaRef = Nothing, + fgaRev = Nothing, + fgaSubmodules = False, + fgaShallow = False, + fgaAllRefs = False, + fgaNarHash = Nothing + } + +-- | 'evalNixIO' under a policy: the roots are allowed first, and the +-- search path is what the caller passes, as the CLI would pass it. +evalPolicyIO :: EvalPolicy -> [Text] -> [Thunk] -> FilePath -> Text -> IO (Either Text NixValue) +evalPolicyIO policy roots searchPaths baseDir source = do + storeDir <- evalNixIOStoreDir + case parseNixWithScope (rootScopeNames policy) baseDir testOrigin (TE.encodeUtf8 source) of + Left err -> pure (Left (T.pack (show err))) + Right expr -> do + st0 <- newEvalState storeDir baseDir + let st = st0 {esPolicy = policy, esSearchPaths = searchPaths} + mapM_ (allowEvalPath st) roots + runEvalIO st (eval (builtinEnv policy (esTimestamp st) searchPaths) expr) + +-- | The battery the modes were pinned against, run through EvalIO: every +-- expression here was run through nix-instantiate under restrict-eval and +-- pure-eval, and the expected text is what upstream printed, except where +-- the oracle version (2.24.9) differs from the installed 2.33.2 and the +-- oracle's source wins (which prefix a refusal names, the fetchGit +-- wording). The fixture lives at a symlink-free root: a root behind a +-- symlinked directory is refused by upstream too, since its allow list +-- holds the spelling given and the walk resolves the link. +testEvalPolicyIO :: IO [Bool] +testEvalPolicyIO = do + putStrLn "eval/policy-io" + tmpBase <- getTemporaryDirectory >>= Dir.canonicalizePath + links <- symlinksAvailable + let root = tmpBase "nova-nix-test-policy" + allowed = root "allowed" + outside = root "outside" + repo = allowed "repo" + pathText = canonPathValue . T.pack + forbidden policy p = "access to absolute path '" <> pathText p <> "' is forbidden " <> modeText policy + modeText policy + | epPureEval policy = "in pure evaluation mode (use '--impure' to override)" + | otherwise = "in restricted mode" + -- The first prefix the walk pushes: /tmp on Linux, /private on + -- macOS, the drive root C:/ on Windows. + firstComponent = joinComponents (take 1 (pathComponents (pathText allowed))) + -- A fixture path as a path literal, relative to the base directory + -- (allowed): the one spelling that lexes as a path on every + -- platform, since a drive-letter path (C:/...) is a URI token to + -- upstream's lexer and to this one. + lit p = "../" <> pathText (makeRelative root p) + quoted p = "\"" <> pathText p <> "\"" + run policy roots = evalPolicyIO policy roots [] allowed + restricted = run restrictedPolicy [pathText allowed] + pureRun = run purePolicy [pathText allowed] + withUris uris = run restrictedPolicy {epAllowedUris = uris} [pathText allowed] + expectLeft label expected action = + runTestM label $ do + result <- action + pure $ case result of + Left err -> assertEqual label expected err + Right val -> Fail (label <> ": expected a refusal, got " <> T.pack (show val)) + expectRight label expected action = + runTestM label $ assertRight label <$> action <*> pure (assertEqual label expected) + expectRightWith label check action = + runTestM label $ (\r -> assertRight label r check) <$> action + repoUrl = "git+file://" <> pathText repo <> "?exportIgnore=1" + unrestricted = run unrestrictedPolicy [] + symlinkMessage p = "path '" <> pathText p <> "' is a symlink" + -- A case that needs a symlink on disk, or the record of why it did + -- not run. + linked label mk = if links then mk label else runTest (label <> " (skipped: no symlinks here)") Pass + bracket_ + ( do + forceRemoveIfExists root + createDirectoryIfMissing True (allowed "sub") + createDirectoryIfMissing True outside + BS.writeFile (allowed "data.txt") "hello\n" + BS.writeFile (allowed "sub" "data.txt") "inner\n" + BS.writeFile (allowed "y.nix") "7\n" + BS.writeFile (outside "x.nix") "42\n" + BS.writeFile (outside "secret.txt") "secret\n" + when links $ do + Dir.createFileLink (outside "secret.txt") (allowed "link") + Dir.createDirectoryLink outside (allowed "dirlink") + Dir.createFileLink "nowhere" (allowed "dangling") + createDirectoryIfMissing True (allowed "dir") + Dir.createFileLink (outside "x.nix") (allowed "dir" "default.nix") + createDirectoryIfMissing True repo + _ <- fixtureGit repo ["init", "--quiet"] + BS.writeFile (repo "f.txt") "in repo\n" + _ <- fixtureGit repo ["add", "-A"] + _ <- fixtureGit repo ["commit", "--quiet", "-m", "init"] + pure () + ) + (forceRemoveIfExists root) + $ do + rev <- T.strip <$> fixtureGit repo ["rev-parse", "HEAD"] + -- The fetch cache writes under XdgCache; point it at the fixture for + -- the duration so the suite never touches the developer's cache. + savedCacheHome <- lookupEnv "XDG_CACHE_HOME" + setEnv "XDG_CACHE_HOME" (root "cache") + results <- + sequence + [ -- restricted: the allow list + expectRight "a file under an allowed root reads" (mkStr "hello\n") (restricted ("builtins.readFile " <> lit (allowed "data.txt"))), + expectRight "a file deeper under an allowed root reads" (mkStr "inner\n") (restricted ("builtins.readFile " <> lit (allowed "sub" "data.txt"))), + expectLeft "a file beside the allowed root is refused, naming the first prefix outside the list" (forbidden restrictedPolicy outside) (restricted ("builtins.readFile " <> lit (outside "secret.txt"))), + expectLeft "with nothing allowed the refusal names the first component" (forbidden restrictedPolicy (T.unpack firstComponent)) (run restrictedPolicy [] ("builtins.readFile " <> lit (allowed "data.txt"))), + expectLeft "a string spelling the path is refused the same way" (forbidden restrictedPolicy outside) (restricted ("builtins.readFile " <> quoted (outside "secret.txt"))), + expectRight "import under the root works" (VInt 7) (restricted ("import " <> lit (allowed "y.nix"))), + expectLeft "import beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("import " <> lit (outside "x.nix"))), + expectRight "pathExists is true under the root" (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "data.txt"))), + expectRight "pathExists is false beside it, not an error" (VBool False) (restricted ("builtins.pathExists " <> lit (outside "secret.txt"))), + expectRightWith "readDir under the root lists" (\case VAttrs attrs -> assertEqual "entries" True (attrSetSize attrs == 1); other -> Fail (T.pack (show other))) (restricted ("builtins.readDir " <> lit (allowed "sub"))), + expectLeft "readDir beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("builtins.readDir " <> lit outside)), + expectLeft "readFileType names the path asked for, no walk" (forbidden restrictedPolicy (outside "secret.txt")) (restricted ("builtins.readFileType " <> lit (outside "secret.txt"))), + expectLeft "hashFile walks like readFile" (forbidden restrictedPolicy outside) (restricted ("builtins.hashFile \"sha256\" " <> lit (outside "secret.txt"))), + expectRight "getEnv answers empty" (mkStr "") (restricted "builtins.getEnv \"PATH\""), + expectRight "a toFile result is readable afterwards" (mkStr "y") (restricted "builtins.readFile (builtins.toFile \"x\" \"y\")"), + expectRightWith "a source copy under the root is allowed" (\case VStr s _ -> assertEqual "store" True (BS.isPrefixOf "/nix/store/" s); other -> Fail (T.pack (show other))) (restricted "\"${./data.txt}\""), + expectLeft "a source copy beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("\"${" <> lit (outside "secret.txt") <> "}\"")), + expectLeft "builtins.path beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("builtins.path { path = " <> lit (outside "secret.txt") <> "; }")), + expectLeft "filterSource beside the root is refused" (forbidden restrictedPolicy outside) (restricted ("builtins.filterSource (p: t: true) " <> lit outside)), + expectLeft "tryEval does not catch a refusal" (forbidden restrictedPolicy outside) (restricted ("builtins.tryEval (builtins.readFile " <> lit (outside "secret.txt") <> ")")), + linked "a symlink under the root pointing outside is refused at its target" (\label -> expectLeft label (forbidden restrictedPolicy outside) (restricted ("builtins.readFile " <> lit (allowed "link")))), + linked "a directory import whose default.nix is a symlink outside the root is refused at the link's target" (\label -> expectLeft label (forbidden restrictedPolicy outside) (restricted ("import " <> lit (allowed "dir")))), + linked "scopedImport of that directory is refused the same way" (\label -> expectLeft label (forbidden restrictedPolicy outside) (restricted ("builtins.scopedImport {} " <> lit (allowed "dir")))), + linked "pathExists checks a symlink to a forbidden file in place: true" (\label -> expectRight label (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "link")))), + linked "pathExists checks a symlink to a forbidden directory in place: true" (\label -> expectRight label (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "dirlink")))), + linked "pathExists of a dangling symlink is true" (\label -> expectRight label (VBool True) (restricted ("builtins.pathExists " <> lit (allowed "dangling")))), + linked "pathExists through a symlinked directory follows the ancestor, which is refused: false" (\label -> expectRight label (VBool False) (restricted ("builtins.pathExists " <> lit (allowed "dirlink" "secret.txt")))), + linked "pathExists with a trailing slash follows the final link, which is refused: false" (\label -> expectRight label (VBool False) (restricted ("builtins.pathExists \"" <> pathText (allowed "dirlink") <> "/\""))), + linked "readFileType through a symlinked directory is refused at the symlink" (\label -> expectLeft label (symlinkMessage (allowed "dirlink")) (restricted ("builtins.readFileType " <> lit (allowed "dirlink" "secret.txt")))), + linked "readFileType through a symlinked directory is refused in the default mode too" (\label -> expectLeft label (symlinkMessage (allowed "dirlink")) (unrestricted ("builtins.readFileType " <> lit (allowed "dirlink" "secret.txt")))), + linked "pathExists of a dangling symlink is true in the default mode too" (\label -> expectRight label (VBool True) (unrestricted ("builtins.pathExists " <> lit (allowed "dangling")))), + linked "builtins.path resolves a symlink root and stores its target" (\label -> expectRight label (mkStr "directory") (unrestricted ("builtins.readFileType (builtins.path { path = " <> lit (allowed "dirlink") <> "; })"))), + linked "filterSource resolves a symlink root and stores its target" (\label -> expectRight label (mkStr "directory") (unrestricted ("builtins.readFileType (builtins.filterSource (p: t: true) " <> lit (allowed "dirlink") <> ")"))), + expectRight "pathExists with a trailing slash on a file is false" (VBool False) (unrestricted ("builtins.pathExists \"" <> pathText (allowed "data.txt") <> "/\"")), + expectRight "pathExists with a trailing slash on a directory is true" (VBool True) (unrestricted ("builtins.pathExists \"" <> pathText (allowed "sub") <> "/\"")), + expectRight "pathExists with a trailing slash and dot on a directory is true" (VBool True) (unrestricted ("builtins.pathExists \"" <> pathText (allowed "sub") <> "/.\"")), + -- restricted: URIs + expectLeft "a fetch of an unlisted URI is refused before any download" "access to URI 'https://example.invalid/x' is forbidden in restricted mode" (restricted "builtins.fetchurl \"https://example.invalid/x\""), + expectLeft "a file URL beside the root is refused as its path" (forbidden restrictedPolicy (outside "secret.txt")) (restricted ("builtins.fetchurl \"file://" <> pathText (outside "secret.txt") <> "\"")), + expectRightWith "a file URL under the root fetches" (\case VPath p -> assertEqual "store" True (T.isPrefixOf "/nix/store/" p); other -> Fail (T.pack (show other))) (restricted ("builtins.fetchurl { url = \"file://" <> pathText (allowed "data.txt") <> "\"; sha256 = \"5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03\"; }")), + expectLeft "fetchTarball of an unlisted URI is refused" "access to URI 'https://example.invalid/x.tar.gz' is forbidden in restricted mode" (restricted "builtins.fetchTarball \"https://example.invalid/x.tar.gz\""), + expectLeft "an allowed-uris prefix admits only its subpaths" "access to URI 'https://example.invalid/dir2/x' is forbidden in restricted mode" (withUris ["https://example.invalid/dir"] "builtins.fetchurl { url = \"https://example.invalid/dir2/x\"; sha256 = \"5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03\"; }"), + runTestM "an allowed-uris prefix lets the fetch proceed to the network" $ do + result <- withUris ["https://example.invalid/dir"] "builtins.fetchurl { url = \"https://example.invalid/dir/x\"; sha256 = \"5891b5b522d5df086d0ff0b110fbd9d21bb4fc7163af34d08286a2e846f6be03\"; }" + pure $ case result of + Left err | "is forbidden" `T.isInfixOf` err -> Fail ("the gate refused an allowed URI: " <> err) + _ -> Pass, + expectLeft "fetchGit of an allowed path is still a URI, checked in its git+file form" ("access to URI '" <> repoUrl <> "' is forbidden in restricted mode") (restricted ("builtins.fetchGit " <> quoted repo)), + expectRight "an allowed git+file prefix admits the fetch and its tree is readable afterwards" (mkStr "in repo\n") (withUris ["git+file://" <> pathText allowed] ("builtins.readFile ((builtins.fetchGit " <> quoted repo <> ").outPath + \"/f.txt\")")), + -- restricted: the search path + expectRight "a search path root is where resolves and reads" (VInt 7) (evalPolicyIO restrictedPolicy [pathText allowed] (parseNixPath (TE.encodeUtf8 ("allowed=" <> pathText allowed))) allowed "import "), + expectLeft "a search path miss carries the NIX_PATH hint and is catchable" "file 'nope' was not found in the Nix search path (add it using $NIX_PATH or -I)" (restricted ""), + expectRight "tryEval catches the miss" (VBool False) (restricted "(builtins.tryEval ).success"), + -- pure + expectLeft "pure mode refuses with its own clause" (forbidden purePolicy outside) (pureRun ("builtins.readFile " <> lit (outside "secret.txt"))), + expectRight "pure mode still reads under an allowed root" (mkStr "hello\n") (pureRun ("builtins.readFile " <> lit (allowed "data.txt"))), + expectRight "pure mode has no currentTime" (VBool False) (pureRun "builtins ? currentTime"), + expectLeft "pure mode words the search path miss differently" "cannot look up '' in pure evaluation mode (use '--impure' to override)" (pureRun ""), + expectRight "the pure miss is catchable too" (VBool False) (pureRun "(builtins.tryEval ).success"), + expectLeft "storePath is refused in pure mode before its argument is read" "'builtins.storePath' is not allowed in pure evaluation mode" (pureRun "builtins.storePath 42"), + expectLeft "fetchurl needs a hash in pure mode, checked before any download" "in pure evaluation mode, 'fetchurl' requires a 'sha256' argument" (pureRun "builtins.fetchurl \"https://example.invalid/x\""), + expectLeft "fetchTarball needs a hash in pure mode" "in pure evaluation mode, 'fetchTarball' requires a 'sha256' argument" (pureRun "builtins.fetchTarball \"https://example.invalid/x.tar.gz\""), + expectLeft "fetchGit without a rev is unlocked in pure mode" ("in pure evaluation mode, 'fetchGit' will not fetch unlocked input '" <> repoUrl <> "'") (pureRun ("builtins.fetchGit " <> quoted repo)), + expectRight "fetchGit with a rev is locked and fetches in pure mode" (mkStr "in repo\n") (pureRun ("builtins.readFile ((builtins.fetchGit { url = " <> quoted repo <> "; rev = \"" <> rev <> "\"; }).outPath + \"/f.txt\")")), + expectLeft "a home-relative literal cannot resolve in pure mode" "the path '~/x' can not be resolved in pure mode" (pureRun "~/x"), + expectRight "pure mode's getEnv answers empty" (mkStr "") (pureRun "builtins.getEnv \"PATH\""), + expectRight "a path literal is a value, read or not" (mkStr (pathText (outside "secret.txt"))) (pureRun ("builtins.toString " <> lit (outside "secret.txt"))), + -- unrestricted stays unrestricted + expectRight "the default policy reads anywhere" (mkStr "secret\n") (run unrestrictedPolicy [] ("builtins.readFile " <> lit (outside "secret.txt"))) + ] + maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") savedCacheHome + pure results + +-- | A rooted path with no drive opens what its drive-qualified spelling +-- opens when the store is on that drive, at every site a path value +-- reaches the filesystem and under the access policy. The suite's store +-- is under the temporary directory, so it shares that directory's drive, +-- and on Windows CI the working directory is on another (D:), so a path +-- resolved on the current drive misses. On POSIX the two spellings are +-- one path. +testDrivelessPathsIO :: IO [Bool] +testDrivelessPathsIO = do + putStrLn "eval/driveless-paths-io" + tmpBase <- Dir.canonicalizePath =<< getTemporaryDirectory + let dir = tmpBase "nova-nix-test-driveless" + qualified = canonPathValue (T.pack dir) + driveless = canonPathValue (T.pack ("/" <> dropDrive dir)) + quoted = nixQuotedPath . T.unpack + -- A fixture by its drive-less spelling, as a string and as a path. + str name = quoted (driveless <> "/" <> name) + pathOf name = "(/. + " <> str name <> ")" + gives label = runTestIO label dir + -- The drive-qualified side is a relative literal, which resolves + -- against the fixture directory with its drive, or a string that + -- spells the drive where a fetch takes no path. + same label drivelessSide qualifiedSide = gives label ("(" <> drivelessSide <> ") == (" <> qualifiedSide <> ")") (VBool True) + restricted roots = evalPolicyIO restrictedPolicy roots [] dir + readsUnder label roots source = + runTestM label $ (\r -> assertRight label r (assertEqual label (mkStr "probe"))) <$> restricted roots source + bracket_ + ( do + forceRemoveIfExists dir + createDirectoryIfMissing True (dir "repo") + createDirectoryIfMissing True (dir "sub") + BS.writeFile (dir "f.txt") "probe" + BS.writeFile (dir "g.nix") "7\n" + BS.writeFile (dir "sub" "h.txt") "inner\n" + BS.writeFile (dir "repo" "r.txt") "in repo\n" + _ <- fixtureGit (dir "repo") ["init", "--quiet"] + _ <- fixtureGit (dir "repo") ["add", "-A"] + _ <- fixtureGit (dir "repo") ["commit", "--quiet", "-m", "init"] + pure () + ) + (forceRemoveIfExists dir) + $ sequence + [ gives "pathExists of a string" ("builtins.pathExists " <> str "f.txt") (VBool True), + gives "pathExists of a path" ("builtins.pathExists " <> pathOf "f.txt") (VBool True), + gives "readFile" ("builtins.readFile " <> str "f.txt") (mkStr "probe"), + gives "readDir" ("builtins.attrNames (builtins.readDir " <> quoted driveless <> ") == [ \"f.txt\" \"g.nix\" \"repo\" \"sub\" ]") (VBool True), + gives "readFileType" ("builtins.readFileType " <> str "f.txt") (mkStr "regular"), + gives "import" ("import " <> str "g.nix") (VInt 7), + gives "scopedImport" ("builtins.scopedImport { } " <> str "g.nix") (VInt 7), + gives "findFile" ("builtins.readFile (builtins.findFile [ { prefix = \"d\"; path = " <> quoted driveless <> "; } ] \"d/f.txt\")") (mkStr "probe"), + same "hashFile" ("builtins.hashFile \"sha256\" " <> str "f.txt") "builtins.hashFile \"sha256\" ./f.txt", + same "a copy by interpolation" ("\"${" <> pathOf "f.txt" <> "}\"") "\"${./f.txt}\"", + same "builtins.path" ("builtins.path { path = " <> pathOf "sub" <> "; }") "builtins.path { path = ./sub; }", + same "filterSource" ("builtins.filterSource (p: t: true) " <> pathOf "sub") "builtins.filterSource (p: t: true) ./sub", + same "fetchurl of a file URL" ("builtins.fetchurl \"file://" <> driveless <> "/f.txt\"") ("builtins.fetchurl \"file://" <> qualified <> "/f.txt\""), + same "fetchGit of a local path" ("(builtins.fetchGit " <> str "repo" <> ").outPath") ("(builtins.fetchGit " <> quoted (qualified <> "/repo") <> ").outPath"), + readsUnder "a root allowed with no drive admits its drive-qualified spelling" [driveless] ("builtins.readFile " <> quoted (qualified <> "/f.txt")), + readsUnder "a root allowed with its drive admits the drive-less spelling" [qualified] ("builtins.readFile " <> str "f.txt") + ] + +-- | The flags and settings through the binary: the modes and +-- @trace-verbose@ select themselves from the command line and from +-- NIX_CONFIG, and a refusal surfaces as the eval error it is. Under +-- @trace-verbose@, @builtins.traceVerbose@ is upstream's @prim_trace@ +-- (primops.cc at 2.24.9). +testEvalPolicyCLI :: IO [Bool] +testEvalPolicyCLI = do + putStrLn "cli/eval-policy" + tmpBase <- getTemporaryDirectory >>= Dir.canonicalizePath + ambient <- getEnvironment + cwd <- Dir.getCurrentDirectory + let root = tmpBase "nova-nix-test-cli-policy" + -- Where a channel: entry would land if it were taken for a path. + cwdChannelEntry = T.unpack (canonPathValue (T.pack (cwd "channel:nova-probe"))) + allowed = root "allowed" + -- A string, since a drive-letter path (C:/...) is a URI token and + -- a native spelling (C:\...) is no token at all; an absolute + -- string is coerced to a path on every platform. + outsideFile = T.unpack (canonPathValue (T.pack (root "outside.txt"))) + isolate extraConfig = + ("NIX_CONFIG", "substituters =\ntrusted-public-keys =\n" <> extraConfig) + : ("XDG_CONFIG_HOME", root "config") + : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME", "NIX_PATH"]) ambient + runCLI extraConfig args = + Proc.readCreateProcessWithExitCode + ((Proc.proc "cabal" (["run", "-v0", "nova-nix", "--"] ++ args)) {Proc.env = Just (isolate extraConfig)}) + "" + expectOut label extraConfig args expected = + runTestM ("CLI " <> label) $ do + (code, out, err) <- runCLI extraConfig args + pure $ case (code, lines out) of + (ExitSuccess, line : _) -> assertEqual label expected line + _ -> Fail ("CLI: " <> T.pack (show code) <> "; stdout=" <> T.pack out <> "; stderr=" <> T.pack err) + expectErr label extraConfig args needle = + runTestM ("CLI " <> label) $ do + (code, _, err) <- runCLI extraConfig args + pure $ + if code /= ExitSuccess && needle `T.isInfixOf` T.pack err + then Pass + else Fail ("expected a failure mentioning " <> needle <> ", got " <> T.pack (show (code, err))) + -- The whole run: the exit code, then stdout and stderr line by line. + expectRun label extraConfig args expected = + runTestM ("CLI " <> label) $ do + (code, out, err) <- runCLI extraConfig args + pure (assertEqual label expected (code, lines out, lines err)) + traceVerboseHi = ["eval", "--expr", "builtins.traceVerbose \"hi\" 1"] + bracket_ + ( do + forceRemoveIfExists root + createDirectoryIfMissing True allowed + BS.writeFile (allowed "data.txt") "hello\n" + BS.writeFile (root "outside.txt") "no\n" + ) + (forceRemoveIfExists root) + $ sequence + [ expectOut "--pure-eval hides currentTime" "" ["eval", "--pure-eval", "--expr", "builtins ? currentTime"] "false", + expectOut "--restrict-eval empties getEnv" "" ["eval", "--restrict-eval", "--expr", "builtins.getEnv \"HOME\""] "\"\"", + expectOut "pure-eval from NIX_CONFIG" "pure-eval = true\n" ["eval", "--expr", "builtins ? currentSystem"] "false", + expectOut "a --nix-path root is readable under --restrict-eval" "" ["eval", "--restrict-eval", "--nix-path", "allowed=" ++ allowed, "--expr", "builtins.readFile "] "\"hello\\n\"", + expectErr "a read outside the roots fails the command" "" ["eval", "--restrict-eval", "--expr", "builtins.readFile \"" ++ outsideFile ++ "\""] "is forbidden in restricted mode", + expectErr "a channel: search path entry allows nothing" "" ["eval", "--restrict-eval", "--nix-path", "nixpkgs=channel:nova-probe", "--expr", "builtins.readFile \"" ++ cwdChannelEntry ++ "\""] "is forbidden in restricted mode", + expectOut "build accepts the flag before its target" "" ["build", "--pure-eval", "--help"] "Usage: nova-nix [--nix-path NAME=PATH] ", + expectRun "traceVerbose prints nothing by default" "" traceVerboseHi (ExitSuccess, ["1"], []), + expectRun "--trace-verbose makes traceVerbose trace" "" ("--trace-verbose" : traceVerboseHi) (ExitSuccess, ["1"], ["trace: hi"]), + expectRun "trace-verbose from NIX_CONFIG makes traceVerbose trace" "trace-verbose = true\n" traceVerboseHi (ExitSuccess, ["1"], ["trace: hi"]), + expectRun "under --trace-verbose traceVerbose forces its first argument" "" ["eval", "--trace-verbose", "--expr", "builtins.traceVerbose (throw \"a\") 1"] (ExitFailure 1, [], ["error: a"]), + expectRun "under --trace-verbose traceVerbose prints before its second argument fails" "" ["eval", "--trace-verbose", "--expr", "builtins.traceVerbose \"hi\" (throw \"b\")"] (ExitFailure 1, [], ["trace: hi", "error: b"]), + -- prim_trace runs only once it has both arguments (callFunction, + -- eval.cc at 2.24.9), so a partial application forces nothing. + expectRun "under --trace-verbose a partial traceVerbose leaves its argument unforced" "" ["eval", "--trace-verbose", "--expr", "builtins.seq (builtins.traceVerbose (throw \"a\")) 1"] (ExitSuccess, ["1"], []), + expectOut "build accepts --trace-verbose before its target" "" ["build", "--trace-verbose", "--help"] "Usage: nova-nix [--nix-path NAME=PATH] " + ] + +-- | The eval result through the binary: stdout carries the printer's bytes +-- and a bare newline, with no text encoding or newline translation between. +testResultPrinterCLI :: IO [Bool] +testResultPrinterCLI = do + putStrLn "cli/eval-result" + tmpBase <- getTemporaryDirectory + ambient <- getEnvironment + let root = tmpBase "nova-nix-test-cli-result" + file = root "latin1" + notUtf8 = "a" <> BS.singleton 0xfc <> "b" + -- A string, as in testEvalPolicyCLI: a drive-letter path is no + -- path literal. + fileString = T.unpack (canonPathValue (T.pack file)) + isolated = + ("XDG_CONFIG_HOME", root "config") + : filter (\(key, _) -> key `notElem` ["NIX_CONFIG", "XDG_CONFIG_HOME"]) ambient + evalProcess = + (Proc.proc "cabal" ["run", "-v0", "nova-nix", "--", "eval", "--expr", "builtins.readFile \"" ++ fileString ++ "\""]) + { Proc.env = Just isolated, + Proc.std_out = Proc.CreatePipe + } + bracket_ + (forceRemoveIfExists root >> createDirectoryIfMissing True root >> BS.writeFile file notUtf8) + (forceRemoveIfExists root) + $ sequence + [ runTestM "CLI eval writes a string's bytes and a bare newline" $ + Proc.withCreateProcess evalProcess $ \_ stdoutPipe _ process -> case stdoutPipe of + Nothing -> pure (Fail "no stdout pipe") + Just out -> do + printed <- BS.hGetContents out + code <- Proc.waitForProcess process + pure $ case code of + ExitSuccess -> assertEqual "cli-result" ("\"" <> notUtf8 <> "\"\n") printed + ExitFailure _ -> Fail ("CLI: " <> T.pack (show code)) + ] + +-- | nix.conf bytes through the binary (#244): an include target, the +-- system directory and NIX_CONFIG reach the file system and the settings +-- as the bytes they hold. Each case reads whether pure-eval came on, +-- which hides currentSystem. A name that is not UTF-8 exists only on a +-- volume that holds one, so a case needing such a name makes it first +-- and skips, with the reason, where the temp volume refuses it: APFS +-- refuses the name, and HFS+ holds it but opens no path beneath a +-- directory so named. A Windows name or variable is UTF-16 and holds no +-- such byte at all. The decoy cases need no such name: a file named by +-- U+FFFD's UTF-8, which a lossy decode of the byte would open instead, +-- must stay unread, as it does under nix-instantiate 2.33.2. +testConfigBytesCLI :: IO [Bool] +testConfigBytesCLI = do + putStrLn "cli/config-bytes" + tmpBase <- getTemporaryDirectory + ambient <- getEnvironment + let root = tmpBase "nova-nix-test-cli-config-bytes" + confDir = root "etc" + noConfDir = root "none" + configVars = ["NIX_CONFIG", "NIX_CONF_DIR", "NIX_USER_CONF_FILES", "XDG_CONFIG_DIRS"] + -- An empty NIX_USER_CONF_FILES names no user files, so only the + -- system file under NIX_CONF_DIR and NIX_CONFIG are read. + runCLI dir nixConfig = + Proc.readCreateProcessWithExitCode + ( (Proc.proc "cabal" ["run", "-v0", "nova-nix", "--", "eval", "--expr", "builtins ? currentSystem"]) + { Proc.env = Just (("NIX_CONF_DIR", dir) : ("NIX_USER_CONF_FILES", "") : ("NIX_CONFIG", nixConfig) : filter ((`notElem` configVars) . fst) ambient) + } + ) + "" + expectAnswer label expected dir nixConfig = do + (code, out, err) <- runCLI dir nixConfig + pure $ case (code, lines out) of + (ExitSuccess, line : _) -> assertEqual label expected line + _ -> Fail ("CLI: " <> T.pack (show code) <> "; stdout=" <> T.pack out <> "; stderr=" <> T.pack err) + expectPure label = expectAnswer label "false" + expectImpure label = expectAnswer label "true" + expectRefusal nixConfig needle = do + (code, _, err) <- runCLI noConfDir nixConfig + pure $ + if code /= ExitSuccess && needle `T.isInfixOf` T.pack err + then Pass + else Fail ("expected a failure mentioning " <> needle <> ", got " <> T.pack (show (code, err))) + -- A case whose name or value holds bytes, spelled as the + -- platform's strings carry them. + spelledCase label bytes check = do + spelled <- envSpelling bytes + case spelled of + Nothing -> True <$ putStrLn (" SKIP " <> T.unpack label <> ": a Windows name or variable cannot hold a byte with no UTF-8 reading") + Just spelling -> check spelling + envCase label bytes check = spelledCase label bytes (runTestM label . check) + -- A case over a file whose name holds bytes, made before the case + -- runs and skipped where the temp volume refuses it. + -- A decoy's name is UTF-8, which every volume holds. + decoyCase label bytes make check = spelledCase label bytes $ \name -> make name >> runTestM label (check name) + fileCase label bytes make check = spelledCase label bytes $ \name -> do + made <- try (make name) + case made of + -- The error string alone: the path in the full message holds + -- the very byte stdout's encoding cannot write. + Left (err :: IOException) -> True <$ putStrLn (" SKIP " <> T.unpack label <> ": the temp volume cannot hold a name that is not UTF-8 (" <> ioeGetErrorString err <> ")") + Right () -> runTestM label (check name) + latin1 = "caf\xE9" :: BS.ByteString + -- The name a lossy decode of latin1 spells: U+FFFD's UTF-8. + decoy = "caf\xEF\xBF\xBD" :: BS.ByteString + decoyDir = root "decoy" + bracket_ + (forceRemoveIfExists root >> createDirectoryIfMissing True confDir >> createDirectoryIfMissing True decoyDir) + (forceRemoveIfExists root) + $ sequence + [ fileCase + "CLI an include target with no UTF-8 reading opens the file it names" + (latin1 <> ".conf") + ( \name -> do + BS.writeFile (confDir name) "pure-eval = true\n" + BS.writeFile (confDir "nix.conf") ("include " <> latin1 <> ".conf\n") + ) + (const (expectPure "include-bytes" confDir "")), + fileCase + "CLI a NIX_CONF_DIR holding a byte with no UTF-8 reading names the system file" + latin1 + ( \name -> do + createDirectoryIfMissing True (root name) + BS.writeFile (root name "nix.conf") "pure-eval = true\n" + ) + (\name -> expectPure "conf-dir-bytes" (root name) ""), + decoyCase + "CLI an !include target with no UTF-8 reading leaves the U+FFFD-named file unread" + (decoy <> ".conf") + ( \name -> do + BS.writeFile (decoyDir name) "pure-eval = true\n" + BS.writeFile (decoyDir "nix.conf") ("!include " <> latin1 <> ".conf\n") + ) + (const (expectImpure "include-decoy" decoyDir "")), + spelledCase "CLI a NIX_CONF_DIR holding such a byte leaves the U+FFFD-named directory unread" latin1 $ \confName -> + decoyCase + "CLI a NIX_CONF_DIR holding such a byte leaves the U+FFFD-named directory unread" + decoy + ( \name -> do + createDirectoryIfMissing True (decoyDir name) + BS.writeFile (decoyDir name "nix.conf") "pure-eval = true\n" + ) + (const (expectImpure "conf-dir-decoy" (decoyDir confName) "")), + envCase + "CLI NIX_CONFIG holding such a byte in a comment and an unknown setting applies the rest" + ("trusted-users = " <> latin1 <> "\npure-eval = true # " <> latin1 <> "\n") + (expectPure "env-bytes-ignored" noConfDir), + envCase + "CLI NIX_CONFIG holding such a byte in a list setting is refused" + ("pure-eval = true\nextra-substituters = https://" <> latin1 <> ".example\n") + (`expectRefusal` "setting 'substituters' has invalid value"), + envCase + "CLI a Boolean ending in a no-break space is invalid, as upstream splits the line" + "pure-eval = true\xC2\xA0\n" + (`expectRefusal` "Boolean setting 'pure-eval' has invalid value") + ] + +-- --------------------------------------------------------------------------- +-- Tests: an interrupt stops the operation it reaches (#251) +-- --------------------------------------------------------------------------- + +-- | How long 'interruptedAfterStall' lets an action run before +-- interrupting it: far longer than any of these actions takes to reach +-- the read it stalls in. +stallMicros :: Int +stallMicros = 200000 + +-- | Run an action in a thread of its own, deliver a user interrupt to it +-- once it has had time to stall, and report how it ended: @Left@ the +-- exception that stopped it, or @Right@ the value it returned instead. +interruptedAfterStall :: IO a -> IO (Either SomeException a) +interruptedAfterStall action = + withAsync action $ \running -> do + threadDelay stallMicros + throwTo (asyncThreadId running) UserInterrupt + waitCatch running + +-- | Pass when the interrupt is what stopped the action. +interruptPropagated :: (Show a) => Either SomeException a -> TestResult +interruptPropagated outcome = case outcome of + Left err + | fromException err == Just UserInterrupt -> Pass + | otherwise -> Fail ("stopped by another exception: " <> T.pack (show err)) + Right value -> Fail ("the interrupt became a value: " <> T.pack (show value)) + +-- | Run an action while a FIFO sits at the path with a writer that never +-- writes, so a read of the path blocks until something interrupts the +-- reader. A FIFO with no writer at all reads as empty at once, because +-- GHC opens a file non-blocking. +withStalledFifo :: FilePath -> IO a -> IO a +withStalledFifo path action = + bracket_ (Proc.callProcess "mkfifo" [path]) (Dir.removePathForcibly path) $ + withBinaryFile path ReadWriteMode (const action) + +-- | Each of these operations caught every exception and turned an +-- interrupt into its fallback value: an unreadable file, a cache miss, a +-- failed push. An interrupt now stops it. A file read is made to stall +-- on a FIFO ('withStalledFifo') and interrupted there from another +-- thread, so those cases need POSIX; the request a push makes stalls on +-- the loopback fixture on every platform. A fetch cache write never +-- blocks, so its interrupt is raised from inside the write. The removal +-- behind a build's cleanup neither blocks nor forces anything the caller +-- supplies, so no case reaches it. +testInterruptsPropagate :: IO [Bool] +testInterruptsPropagate = do + putStrLn "exceptions/interrupts-propagate" + tmpBase <- getTemporaryDirectory + let root = tmpBase "nova-nix-test-interrupts" + storeDir = StoreDir (root "store") + cacheHome = root "cache" + inStore = storePathToFilePath storeDir + pushTo base = PushConfig {pcCacheUrl = base, pcApiKey = Nothing, pcCompression = PushNone} + plainDrv = + Derivation + { drvOutputs = [], + drvInputDrvs = Map.empty, + drvInputSrcs = [], + drvPlatform = currentPlatform, + drvBuilder = builtinUnpackBuilder, + drvArgs = [], + drvEnv = Map.empty + } + unpacking archive = plainDrv {drvEnv = Map.singleton envSrcs (TE.encodeUtf8 (storePathToText defaultStoreDir archive))} + withCacheHome = + bracket + (lookupEnv "XDG_CACHE_HOME" <* setEnv "XDG_CACHE_HOME" cacheHome) + (maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME")) + . const + fifoCase name test + | SI.os == "mingw32" = True <$ putStrLn (" SKIP " ++ T.unpack name ++ ": needs a FIFO") + | otherwise = runTestM name test + forceRemoveIfExists root + createDirectoryIfMissing True (unStoreDir storeDir) + results <- bracket (openStore storeDir) closeStore $ \store -> + sequence + [ runTestM "an interrupt during a push request stops the push" $ + withHttpServer (\_ _ -> Trickle) $ \base _ requested -> do + outcome <- withAsync (pushPaths (pushTo base) store [StorePath (T.replicate 32 "a") "pushed"]) $ \pushing -> do + requested + throwTo (asyncThreadId pushing) UserInterrupt + waitCatch pushing + pure (interruptPropagated outcome), + fifoCase "an interrupt serialising a path for a push stops the push" $ + withHttpServer (\_ _ -> Send (httpResponse "200 OK" "")) $ \base _ _ -> do + let sp = StorePath (T.replicate 32 "b") "stalled-output" + outcome <- withStalledFifo (inStore sp) (interruptedAfterStall (pushPaths (pushTo base) store [sp])) + pure (interruptPropagated outcome), + fifoCase "an interrupt reading the API key file is not an unreadable key" $ do + let keyFile = root "stalled-key" + outcome <- withStalledFifo keyFile (interruptedAfterStall (loadApiKeyFile keyFile)) + pure (interruptPropagated outcome), + fifoCase "an interrupt verifying a source tree on disk is not a mismatch" $ do + let sp = StorePath (T.replicate 32 "c") "stalled-source" + sources = Map.singleton (T.pack (root "absent-source")) (storePathToText defaultStoreDir sp) + outcome <- withStalledFifo (inStore sp) (interruptedAfterStall (materializeEvalSources store sources)) + pure (interruptPropagated outcome), + fifoCase "an interrupt reading a store derivation is not a missing one" $ do + st <- newEvalState storeDir root + let sp = StorePath (T.replicate 32 "d") "stalled.drv" + outcome <- withStalledFifo (inStore sp) (interruptedAfterStall (runEvalIO st (readStoreDerivation sp))) + pure (interruptPropagated outcome), + -- The entry's path is the cache's layout: one file per key, named + -- by the key's SHA-256 (fetchCacheFile). + fifoCase "an interrupt reading the fetch cache is not a cache miss" $ + withCacheHome $ do + st <- newEvalState storeDir root + let key = "stalled-entry" + entry = cacheHome "nova-nix" "fetch" T.unpack (Hash.bytesToHexText (sha256Digest (TE.encodeUtf8 key))) + createDirectoryIfMissing True (takeDirectory entry) + outcome <- withStalledFifo entry (interruptedAfterStall (runEvalIO st (lookupFetchCache key))) + pure (interruptPropagated outcome), + -- The entry's text is the interrupt, raised when the write forces it. + runTestM "an interrupt writing the fetch cache is not an unwritable cache" $ + withCacheHome $ do + st <- newEvalState storeDir root + outcome <- try (runEvalIO st (writeFetchCache "interrupted-entry" (throw UserInterrupt))) + pure (interruptPropagated outcome), + fifoCase "an interrupt unpacking an archive is not a failed unpack" $ do + let archive = StorePath (T.replicate 32 "f") "stalled.tar" + outcome <- withStalledFifo (inStore archive) (interruptedAfterStall (runBuiltinUnpack storeDir defaultUnpackLimits (unpacking archive) [("out", root "stalled-out")])) + pure (interruptPropagated outcome), + fifoCase "an interrupt reading an input derivation is not an unreadable one" $ do + let input = StorePath (T.replicate 32 "g") "stalled-input.drv" + rootDrv = plainDrv {drvInputDrvs = Map.singleton input ["out"]} + config = (defaultBuildConfig storeDir) {bcTmpDir = root "build"} + outcome <- withStalledFifo (inStore input) (interruptedAfterStall (buildWithDeps config store rootDrv (StorePath (T.replicate 32 "h") "root.drv"))) + pure (interruptPropagated outcome), + -- The failures the unpacker does catch: the zstd decoder reports a + -- corrupt frame with 'error', the gzip decoder throws a + -- DecompressError, and a missing archive is an IOException. Each + -- is the archive's failure, not an escape. + runTestM "a corrupt zstd or gzip archive and a missing one fail the unpack" $ do + let corrupt = StorePath (T.replicate 32 "i") "corrupt.tar.zst" + corruptGzip = StorePath (T.replicate 32 "k") "corrupt.tar.gz" + missing = StorePath (T.replicate 32 "j") "missing.tar" + BS.writeFile (inStore corrupt) "not a zstd frame" + BS.writeFile (inStore corruptGzip) "not a gzip stream" + corruptOutcome <- runBuiltinUnpack storeDir defaultUnpackLimits (unpacking corrupt) [("out", root "corrupt-out")] + corruptGzipOutcome <- runBuiltinUnpack storeDir defaultUnpackLimits (unpacking corruptGzip) [("out", root "corrupt-gzip-out")] + missingOutcome <- runBuiltinUnpack storeDir defaultUnpackLimits (unpacking missing) [("out", root "missing-out")] + pure $ case (corruptOutcome, corruptGzipOutcome, missingOutcome) of + (Left (1, corruptMsg), Left (1, corruptGzipMsg), Left (1, missingMsg)) + | "corrupt.tar.zst" `T.isInfixOf` corruptMsg + && "corrupt.tar.gz" `T.isInfixOf` corruptGzipMsg + && not ("unsupported archive format" `T.isInfixOf` corruptGzipMsg) + && "missing.tar" `T.isInfixOf` missingMsg -> + Pass + other -> Fail ("expected all three unpacks to fail: " <> T.pack (show other)) ] forceRemoveIfExists root pure results