diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,79 @@ # Changelog +## 0.11.0.1 - 2026-08-21 + +- **`NovaCache.Bzip2` accepts trailing bytes that do not begin another stream, matching upstream.** The decoder re-initialized at every clean stream end while input remained and fed whatever followed to libbz2's magic check, so a stray NUL, a newline, or any non-stream trailer after the last stream failed the decode. Upstream C++ Nix no longer has a bzip2 sink of its own: `compression.cc` drives every libarchive-supported codec through `ArchiveDecompressionSource`, and libarchive decodes the payload and ignores such a trailer. Measured against libarchive 3.8.2 driven exactly as Nix drives it (`filter_all` + `format_raw` + `format_empty`), four of seven cases diverged, so a historical `.nar.bz2` carrying one stray byte substituted under `nix copy` and failed here, falling through to a source build while the operator was told the cache object was corrupt. Trailing bytes that do begin a stream header are still decoded as a concatenated stream, and a truncated one is still refused: libarchive refuses those too, and silently truncating a real stream is the failure mode a bounded decoder exists to prevent. One divergence is deliberate and documented in place: a trailer that is a well-formed header carrying no block data (`BZh9` alone) is refused here and accepted by libarchive, which buffers past it, and refusing is the safer side of a case that does not arise in practice. +- **The bzip2 decoder is released on every exit instead of at a GC finalizer's leisure.** `decompress` and `withBzip2Source` handed their `bz_stream` to a `ForeignPtr` finalizer and never ended it themselves, so libbz2's block table (up to 3.6 MB at the largest block size, `malloc`'d and therefore invisible to the RTS allocation counter) stayed live on every path, including clean completion. Because that memory creates no GC pressure of its own and is not bounded by `+RTS -M`, sequential decodes accumulated decoder state in proportion to how rarely the collector ran, and a large nursery made the accumulation large. Both entry points now finalize in a bracket, the discipline `NovaCache.Zstd` already had and the one `NovaCache.Xz` documents as unavailable to it because `lzma-static` exposes no live-stream teardown. Concatenated streams within a single decode were never affected. + +## 0.11.0.0 - 2026-08-21 + +- **A failed `withXzSource` or `withZstdSource` pull latches any exception, matching `NovaCache.Bzip2`.** Both sources held only their own decoder errors (`XzError`, `ZstdError`) for replay on later pulls; an exception thrown by the compressed source itself - an HTTP failure, a capped body source refusing to read on - left the state untouched, so a consumer that caught the failure and pulled again at exactly a stream or frame boundary of a concatenated payload could read the empty chunk, the clean-end signal, and take a prefix for complete output. Any exception escaping a pull now marks the transfer unfinishable and is rethrown on every later pull, the breadth `NovaCache.Bzip2` shipped with. +- **Bounded bzip2: the new `NovaCache.Bzip2`, a public `nova-cache:bzip2` sublibrary.** Historical cache.nixos.org narinfos declare `Compression: bzip2`, and upstream C++ Nix reads an absent `Compression` field as bzip2, so substituting those paths needs the codec. `decompress` takes the narinfo's declared NarSize as its inclusive output bound and fails past it, and `withBzip2Source` decompresses a chunk source into a chunk source under the same limits - the xz discipline, ported. There is no decoder-memory knob because bzip2 carries no attacker-chosen dictionary size: decoding allocates a fixed small amount (about 4 MiB at the format's largest block size), a constant of the format rather than a parameter. Concatenated streams decode as one output, matching upstream's bzip2 decompression sink, which re-initializes the decoder at stream end while input remains; trailing bytes that do not start a valid stream are refused, and truncated input is refused. A failed pull from the streaming source stays failed: later pulls rethrow the failure instead of reading as a clean end, so a consumer that catches and retries cannot mistake a failed transfer for complete output. No existing binding bundles libbz2's C sources on every platform (`bzlib` links the system library outside Windows), so the module drives libbz2 directly over `bzip2-clib`, which is nothing but the bundled sources - no system library anywhere. +- **The publish workflow gates on a dated changelog and survives its own docs half failing.** v0.9.0.0 reached Hackage with its changelog section still headed "## Unreleased" (the dating commit landed after the tag), and the docs build then failed after the sdist was live, so the re-run died on Hackage's duplicate-version 400 and the release stayed docless; a Hackage tarball is immutable, so both scars are permanent. The workflow now refuses to upload anything until the changelog's top section is exactly the tagged version with its date, and an already-published sdist is skipped instead of fatal, so a failed docs upload can be re-run to completion. +- **The docs re-upload workflow handles every shipped release, not only 0.10-and-later trees.** Its purpose is re-uploading documentation for versions that predate it, yet it hardcoded the current tree's shape: on v0.8.0.0 the haddock run missed the then-flag-gated xz module, the sublibrary graft loop died on an unmatched glob, and the fixed verification greps failed, while on v0.9.0.0 the zstandard grep failed. The graft now skips when the tag built no sublibraries, verification checks module HTML for exactly the sublibraries actually grafted, and the xz flag is enabled only where the tag's cabal declares it. +- **The NAR parser accepts upstream's grammar; Windows-hazard names move to the new `isWindowsHazardName`.** The streaming parser rejected, on every platform, Windows reserved device stems (`aux.c`, `con.h`), names ending in a dot or space, and names containing a colon or backslash. Upstream's C++ restore accepts all of these on Unix, and real cache.nixos.org archives carry them (perl man pages named `ExtUtils::MakeMaker.3`, kernel trees carrying `aux.c`), so substitution failed where upstream succeeds - and `serialise` emitted hazard names that `deserialise` (the same machine, whole-input) refused, so a tree readable from disk did not round-trip through its own NAR. `checkEntryName` now enforces exactly upstream's grammar (no empty name, `.`, `..`, `/`, or NUL, and strict entry order), and the Windows categories live in `isWindowsHazardName` (exported from `NovaCache.NAR.Stream` and re-exported from `NovaCache.NAR`) for store writers to apply at materialization when the target filesystem needs it. +- **`narStreamBounded` clamps its bound with alignment headroom.** The bound was clamped to `maxBound :: Int`, but the parser demands a declared length plus its padding in `Int`, so a declared length near the ceiling wrapped that demand negative and a huge structural string "parsed" instantly as empty at an unmoved position. The clamp now sits `narAlignment - 1` below `Int`'s ceiling, so such an archive fails the parse as upstream would at end of input. +- **`withNarSource` no longer leaks a handle when sizing a planned file fails.** If `hFileSize` threw after a successful open (the path swapped for a FIFO between plan and pull), the handle was not yet recorded in the source state and nothing ever closed it. The open and the state hand-off now transfer ownership atomically under `bracketOnError`. +- **`NovaCache.Zstd` owns its decoder lifecycle: the codec now drives `ZSTD_decompressStream` through the binding's FFI module instead of its high-level streaming driver.** The driver freed decompression contexts only at GC finalization and hid the stream's end state, and four defects traced back to that one root. The context's window buffer (sized by the incoming frame header, i.e. by the peer, up to libzstd's 128 MiB default ceiling) is now created and freed in a bracket, released deterministically on every exit: success, bound violation, corrupt frame, or an exception in the consumer. End of input is now judged by the library's own frame-boundary signal, so a frame cut off mid-way and trailing bytes after the last frame (one to four of which the old path silently accepted) both refuse with `ZstdStreamError`, restoring the complete-stream contract `NovaCache.Xz` already had; the truncation-tolerance divergence documented in 0.10.0.0 is gone. A pull after a failure now rethrows the error instead of reporting a phantom clean end of stream. Concatenated frames still decode as one output, and the inclusive NarSize bound is unchanged. Breaking: `compress` now takes a `ZstdCompressionLevel` (smart constructor `zstdCompressionLevel`, validated against the re-exported `maxCompressionLevel`) instead of a raw `Int`, because the binding's compressor calls `error` on an out-of-range level under `unsafePerformIO`; `defaultCompressionLevel` is a value of the new type, so callers passing it (nova-nix's push) only re-typecheck. +- **A failed `withXzSource` pull stays failed, and terminal decoder statuses read as diagnoses.** Every failure path in the streaming pull used to mark the source drained before throwing, and a drained source returns the empty chunk - the clean end-of-output signal - so a consumer that caught the error and pulled again saw truncated output presented as complete; the source now holds the `XzError` and every later pull re-throws it. Separately, unmapped liblzma statuses were shown raw, so a zero-byte input failed with the message `LzmaRetOK` (which reads as success) and a truncated one with `LzmaRetBufError`; the terminal statuses now map to real diagnoses, and the truncated-or-empty-input message is exported as `truncatedInputMessage` so consumers can match the condition. The inclusive output-bound decision is now one shared function under both the pure and streaming paths, with the streaming path tested at exactly the bound, since a narinfo's NarSize is exact. Teardown of a live decoder remains GC-dependent - the `lzma-static` binding exposes no live-stream teardown - and is documented in place with its undo condition. + +## 0.10.0.0 - 2026-08-20 + +- **Bounded zstd: the new `NovaCache.Zstd`, a public `nova-cache:zstandard` sublibrary.** The modern caches (Cachix, attic, FlakeHub) serve NARs zstd-compressed, and a cache of our own wants the same: near-xz ratio on binaries with decompression an order of magnitude faster, cheap enough to compress at push time (`compress`, frame content size recorded; `defaultCompressionLevel` is libzstd's own 3). `decompress` takes the narinfo's declared NarSize as its output bound and fails past it, and `withZstdSource` decompresses a chunk source into a chunk source under the same limits, pairing with streaming NAR consumption - the xz discipline, ported. Two deliberate divergences from `NovaCache.Xz`, documented in place: decoder-state memory is capped by libzstd's default window limit (128 MiB; the binding exposes no tunable), and a truncated input yields truncated output at this layer - the signed NarSize and NarHash checks above are the arbiter of completeness. Concatenated frames decode as one output, as upstream's sink accepts. The `zstd` dependency bundles libzstd's C sources; no system library on any platform. (`zstandard`, not `zstd`: an in-package component name shadows the like-named dependency, so a sublibrary called `zstd` could never depend on the `zstd` binding.) + +## 0.9.0.0 - 2026-08-20 + +- **`NovaCache.Xz` moves to the public `nova-cache:xz` sublibrary; the `xz` flag is gone.** A dependency's flag cannot be set from a consumer's `.cabal` file, so reaching the decoder forced a mirrored flag plus a matching `constraints: nova-cache +xz` in every downstream - two knobs that had to agree and that the solver could not see. `build-depends: nova-cache:xz` now expresses the need directly, and consumers without it still never build the bundled liblzma, keeping the 0.5.0.0 lesson. Builds that passed `-f xz` drop the flag and add the dependency; the module and its API are unchanged. + +## 0.8.0.0 - 2026-08-20 + +- **Bounded xz decompression returns: the new `NovaCache.Xz`, behind a manual, off-by-default `xz` flag.** 0.5.0.0 removed xz support for having no consumer; foreign-cache substitution (cache.nixos.org serves `.nar.xz`) is the consumer, and the decoder comes back shaped for untrusted input. The consumer knows the narinfo's declared NarSize before decompressing, so `decompress` takes that bound and fails past it - a small compressed input cannot expand to arbitrary memory ahead of the hash check - and the decoder's own state is capped too (`xzMaxDecoderMemoryBytes`; the dictionary size is an attacker-chosen number read from the stream header, and upstream passes no limit there). `withXzSource` decompresses a chunk source into a chunk source under the same limits, pairing with streaming NAR consumption. Concatenated streams decode as one output, matching upstream's `LZMA_CONCATENATED` decoder. The `lzma-static` dependency bundles liblzma's C sources, so the flag needs no system library on any platform - and it stays off by default anyway: the 0.5.0.0 lesson was a compression dependency nobody asked for in every install. +- **Streaming NAR parsing: the new `NovaCache.NAR.Stream`.** A pure, chunk-fed event machine over the NAR grammar: feed chunks as they arrive (a download, a decompressor) and act on events as entries complete, with regular-file contents passing through as slices of the fed chunks. Memory is bounded by the largest structural wire string - names, targets, and tokens are capped at 64 KiB, since without a bound one hostile 8-byte length prefix could demand an arbitrary allocation - never by archive or file size, which is what let nova-nix's substituter document an RSS spike the size of the path being fetched. `deserialise` is now the whole-input instantiation of the same machine (its structural bound is the input's own length, so it accepts exactly what it always accepted): the grammar exists once, and the entire existing NAR test suite runs against the shared core. +- **Streaming NAR serialisation: `NovaCache.NAR.withNarSource`.** Serialises a filesystem tree as a pull source of chunks without ever holding a file's contents in memory: structure (names, kinds, targets) is planned up front with the same case-hack resolution, bytewise entry order, and loud special-file/collision failures as `serialiseFromPath`, then regular files stream through 128 KiB reads. A file's size is read once when its streaming starts and exactly that many bytes are emitted, as upstream's dump does; a shrinking file fails loudly rather than emitting a torn archive. The empty-chunk end convention matches `writeNarStreaming`, so the two ends compose directly. +- **Incremental hashing: `hashInit`/`hashUpdate`/`hashFinalize` in `NovaCache.Hash`.** Pure persistent SHA-256 contexts, so a consumer can hash a NAR in the same pass that streams it and verify a narinfo's NarHash without materializing the archive. +- **The Windows reserved-device guard covers the platform's full set.** `isReservedDeviceName` - the shared predicate behind the NAR entry-name check and the store-key allowlist - compared the raw stem before the first dot against `con`/`prn`/`aux`/`nul` and `com1`-`com9`/`lpt1`-`lpt9`. Win32 device parsing also trims trailing spaces from the stem (`NUL .txt` still opens the device) and reserves `COM0`/`LPT0` and the superscript-digit forms (U+00B9/U+00B2/U+00B3, matched as their UTF-8 bytes), so archives naming `lpt0`, a space-padded device stem, or a superscript-digit device were accepted and would resolve to a device under a Windows extractor. The guard now matches Microsoft's documented reserved set - and the twin check nova-nix applies at materialization, which already rejected all three. +- **Size fields are capped at the uint64 maximum.** The 20-digit length bound on `NarSize`/`FileSize` still admitted values between 2^64 and 10^20 - 1; upstream's `string2Int` refuses those, so such a narinfo would be validated and signed here and then rejected as corrupt by every real Nix client. Values above 18446744073709551615 now fail the parse. +- **Toolchain: GHC 9.14.1 (the first GHC LTS release)** - CI, the deploy and release pipelines, and the README badge move from GHC 9.8.4 to 9.14.1, matching nova-nix. GHC 9.14 opens GHC's new LTS scheme (a minimum of two years of bugfix releases), and under that scheme every earlier series stops receiving fixes, so no version in between had a future. Dependency bounds already admitted the newer compiler and the full set resolves on it. The project targets the LTS alone: base >= 4.22, and foldl' comes from the Prelude, so its one redundant Data.List import is gone. + +## 0.7.0.0 - 2026-07-21 + +- **NAR entry names and symlink targets are byte strings.** The format imposes no text encoding on either, and upstream carries both verbatim; decoding them as UTF-8 at parse rejected archives real Nix accepts. `NarEntry` now carries `ByteString` for directory entry names and symlink targets (the breaking change behind the major bump), the parser stops decoding, and entry order is defined bytewise. For names both representations accept - valid UTF-8 - code-point order and byte order coincide, so previously-valid archives keep their exact bytes and hashes. The `checkName` rejection categories apply unchanged to the byte form; they are ASCII-structural, so they now also catch hazards inside names that do not decode (a `nul.` device stem followed by undecodable bytes used to fail as bad UTF-8 and still fails - for the real reason). +- **`serialiseFromPath` walks the filesystem byte-true.** The walk moves to the platform-native path type (`System.Directory.OsPath`). On POSIX, names and symlink targets enter the archive as the raw bytes the filesystem reports - previously a non-UTF-8 on-disk name was silently rewritten with replacement characters, changing the archived name and hash. On Windows, names are the UTF-8 encoding of their UTF-16 spelling, and a name holding an unpaired surrogate (no UTF-8 form exists, and upstream defines no byte spelling) fails loudly instead of guessing. Public signatures are unchanged. +- **`NovaCache.SafeName` predicates take bytes.** `isReservedDeviceName` and `hasTrailingDotOrSpace` operate on `ByteString`, the form NAR entry names have; Text callers (the store-key allowlist) encode first. +- **`caseHackSuffix` is a `ByteString`**, matching the entry names it marks. +- Dependency floors rise to `directory >= 1.3.8` and `filepath >= 1.4.100` (the `OsPath` API); both the 1.4 and 1.5 `filepath` lineages are supported. + +## 0.6.0.0 - 2026-07-20 + +- **NAR serialisation understands upstream's case-hack.** A case-folding store filesystem (Windows NTFS, default macOS APFS) cannot hold two sibling names differing only by case, so an extractor there materializes the collision with upstream's reversible `~nix~case~hack~` suffix. `serialiseFromPath` now strips the suffix on those platforms - entries are emitted under their NAR names, ordered by them - so a hacked tree reproduces its original NAR bytes; two on-disk names stripping to the same entry fail loudly. New `serialiseFromPathWith` takes the mode explicitly (`CaseHack`, `defaultCaseHack`, `caseHackSuffix` exported); on other platforms a file legitimately named with the suffix still serialises verbatim. The platform-dependent default of `serialiseFromPath` is the behavior change behind the major bump. +- **NAR entry names are checked against Windows resolution hazards.** `checkName` now also rejects a colon anywhere (drive prefix `C:evil`, alternate data stream `a:b`), Windows reserved device names (`nul`, `con`, `com1`..., matched on the portion before the first dot), and names ending in a dot or space (NTFS strips both, so the on-disk name would silently diverge from the NAR name). An extractor relying on `checkName` can no longer be steered outside its target directory or into a device by an archive entry name. +- **`sanitizePath` rejects a trailing dot.** The store-key allowlist already excluded spaces and leading dots; a trailing dot slipped through and NTFS would strip it, landing the file under a different name than the one validated. The Windows-unsafe categories now live in one shared module, `NovaCache.SafeName`, used by both the store-key and NAR entry-name guards. +- **Store-path names reject dot segments.** `parseBaseName` accepted `.`, `..`, and their `.-x` / `..-y` prefixed forms, so paths no Nix client parses could be stored and signed. The rule is upstream's: the first dash-separated component may not be `.` or `..`, while other dot-leading names (`.config-1.0`) stay valid. +- **Size fields are length-bounded before parsing.** `NarSize`/`FileSize` parsed into an unbounded `Integer` digit by digit - quadratic in the field length. Sizes are uint64 on the wire (at most 20 digits); longer fields are rejected before the parse, making its cost constant. +- **Duplicate scalar narinfo keys resolve last-wins**, matching upstream's assign-as-read parser. `Sig` remains the intentionally repeatable key. +- **The NAR executable marker must be empty.** The parser accepted any marker value where the format fixes it as the empty string; a nonempty value is now rejected, as upstream does. +- **`SecretKey` no longer derives `Show` or `Eq`.** The derived `Show` rendered the raw Ed25519 key bytes through any enclosing `Show` (config records, debug traces), and the derived `Eq` compared secret material in input-dependent time. `Show` now renders the key name and a redaction marker; `Eq` compares the bytes in constant time. +- **New `NovaCache.Server.newTTLCache`**, and the bundled server's landing page uses it: the unauthenticated root route paid a full narinfo-store scan per request to render the path-count stat; the count now refreshes at most once per minute, keeping per-request work bounded regardless of store size. + +## 0.5.0.0 - 2026-07-12 + +- **Signing: fingerprints sort and deduplicate references.** C++ Nix computes and verifies narinfo fingerprints over a sorted, deduplicated store-path set; signing in the narinfo's file order produced signatures real Nix clients reject while nova-cache's own `verify` (recomputing from the same order) passed and masked the divergence. References are now sorted by basename and deduplicated before signing. +- **Removed `NovaCache.Compression`, the `compression` flag, and the `lzma` dependency.** The module had no consumer, and the default-on manual flag made every Hackage install require system liblzma dev files, which plain Windows and minimal Linux machines lack - `cabal install` of downstream packages failed while CI (which pins the flag off inside the repo) stayed green. xz support returns with its first real consumer as a size-bounded decoder suitable for untrusted cache data. +- **Wire-format strictness now matches upstream Nix.** `validateNarInfo` requires the StorePath field to be absolute and references to be bare basenames (the other spellings produce narinfos real clients reject at parse time, and a bare StorePath also derived an empty store dir inside the signed fingerprint); store-path names are ASCII-only and capped at 211 characters; NAR parsing rejects backslashes in entry names (the Windows traversal vector) and nonzero string padding; and key parsing rejects an empty name or empty key material at load time instead of producing signatures no trust anchor can match. New `parseStorePathBaseName` and `parseAbsoluteStorePath` expose the per-field parsers. +- **Upstream-optional narinfo fields are now optional.** Only StorePath, URL, NarHash, and NarSize are required; `Compression` defaults to bzip2 as upstream, and `FileHash`/`FileSize` are `Maybe` (breaking record change, covered by the major bump). Valid narinfos from foreign caches no longer fail to parse over absent optional fields. +- **New `NovaCache.Server` module: the cache's HTTP protocol as a WAI `Application`.** Routing, write authentication, request-body limits, and the narinfo validation/signing pipeline move from the server executable into tested library API. Deployment branding stays out of the library: embedders supply their own root-page response, and the bundled executable carries its landing page itself. Adds `wai` and `http-types` to the library dependencies. +- **`GET /narinfo-hashes` requires the write key and is `Cache-Control: no-store`.** The listing enumerates the whole store - something the public cache protocol deliberately never offers - and lists a directory per hit; it exists only for the push tool, which already holds the write key. +- **NAR bodies no longer transit memory.** Uploads stream to a temp file under a running size cap and rename into place atomically (`NovaCache.Store.writeNarStreaming`); downloads are served from disk via WAI's `responseFile` (`NovaCache.Store.narFilePath`). A multi-GB NAR previously occupied that much RAM per request in both directions. +- **`HEAD` is answered wherever `GET` is.** Clients probing narinfo existence with `HEAD` previously got 404. +- **The server refuses to start when `CACHE_API_KEY` normalizes to empty** (BOM or whitespace only - the copy-paste artifact). An empty armed key would authenticate an empty bearer token. +- **The server refuses to start when a configured signing key fails to load.** It previously logged a warning and ran unsigned, persisting narinfos no trust anchor can verify - the same misconfiguration class the key parser now rejects, closed at the process boundary too. +- **Configurable bind host: `--host` / `HOST`.** The default stays all interfaces, so existing deployments do not silently rebind. +- The deploy workflow pins cloudflared by version and checksum instead of pulling `latest`, and builds the server on GitHub's hosted arm64 image (same Ubuntu as the production box), shipping the binary over the Access tunnel - the production host deliberately carries no compiler toolchain. +- **The sdist ships `NOTICE`.** Apache-2.0 section 4(d) asks redistributions to carry it; the file existed in the repo but not in the released tarball. +- **CI builds from the sdist in isolation**, so tree-vs-tarball divergences (files missing from the tarball, dev-only project settings) fail the pipeline instead of surfacing at install time. CI also compiles the server executable and test suites under `-Werror` on every platform. +- Dropped the server executable's unused `crypton` dependency. +- Workflows run with a read-only `GITHUB_TOKEN`. + ## 0.4.2.1 - 2026-06-12 - **Relicensed from BSD-3-Clause to Apache-2.0.** Apache adds an explicit patent grant and trademark terms, and a `NOTICE` file now carries the copyright (Novavero AI Inc.). Earlier releases on Hackage remain under their original licenses. diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -0,0 +1,6 @@ +nova-cache +Copyright 2026 Novavero AI Inc. and contributors + +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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,11 +1,11 @@

nova-cache

The Nix binary cache protocol, in Haskell.

-

nix-base32, NAR archives, narinfo, store paths, and Ed25519 signing - with an optional WAI cache server. A pure core; IO is confined to the compression, storage, and server boundaries.

+

nix-base32, NAR archives (strict and streaming), narinfo, store paths, Ed25519 signing, and bounded xz, zstd, and bzip2 codecs as the public nova-cache:xz, nova-cache:zstandard, and nova-cache:bzip2 sublibraries (decompression bounded, zstd compression for the push direction) - with an optional WAI cache server. A pure core; IO is confined to the storage and server boundaries.

[![CI](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml/badge.svg)](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/nova-cache.svg)](https://hackage.haskell.org/package/nova-cache) -![GHC](https://img.shields.io/badge/GHC-9.8-purple) +![GHC](https://img.shields.io/badge/GHC-9.14-purple) ![License](https://img.shields.io/badge/license-Apache--2.0-blue)
@@ -18,9 +18,6 @@ build-depends: nova-cache ``` -The `compression` flag (on by default) requires the system `liblzma`. Build -with `-f-compression` if you only need hashing, NAR, or narinfo. - ## Usage ```haskell @@ -51,17 +48,41 @@ Left errs -> reject errs ``` +```haskell +import NovaCache.NAR (defaultCaseHack, withNarSource) +import qualified NovaCache.Hash as Hash + +-- Stream a tree's NAR and hash it in one pass; the archive never +-- exists in memory. The parsing side is NovaCache.NAR.Stream, a +-- chunk-fed event machine; the nova-cache:xz, nova-cache:zstandard, +-- and nova-cache:bzip2 sublibraries add decompression bounded by a +-- narinfo's declared NarSize, and the zstd side also compresses for +-- the push direction. +narHash <- withNarSource defaultCaseHack path $ \pull -> + let go ctx = do + chunk <- pull + if BS.null chunk + then pure (Hash.hashFinalize ctx) + else go (Hash.hashUpdate ctx chunk) + in go Hash.hashInit +``` + ## Server ```bash cabal run --flag server nova-cache-server -- --port 5000 --store ./nix-cache ``` +The protocol itself lives in the `NovaCache.Server` library module as a WAI +`Application`, so any operator can embed the cache in their own server with +their own root page; the bundled executable is one such embedding. + ### Configuration | Variable | Description | | --- | --- | -| `PORT` | Listen port (default: 5000) | +| `PORT` | Listen port (default: 5000; also `--port`) | +| `HOST` | Bind host (default: all interfaces; also `--host`) | | `NIX_CACHE_DIR` | Store directory (default: `./nix-cache`) | | `CACHE_API_KEY` | Bearer token required for `PUT`. The server refuses to start without it unless `--allow-open-writes` is passed. | | `SIGNING_KEY_FILE` | Ed25519 secret key file for server-side narinfo signing | @@ -73,12 +94,14 @@ | --- | --- | --- | | `GET` | `/` | Landing page: live stats and the cache public key | | `GET` | `/nix-cache-info` | Cache metadata | -| `GET` | `/narinfo-hashes` | All cached narinfo hashes, newline-delimited | +| `GET` | `/narinfo-hashes` | All cached narinfo hashes, newline-delimited (authenticated) | | `GET` | `/.narinfo` | Fetch a narinfo | -| `GET` | `/nar/` | Fetch a NAR | +| `GET` | `/nar/` | Fetch a NAR (streamed from disk) | | `PUT` | `/.narinfo` | Upload a narinfo (authenticated, validated) | -| `PUT` | `/nar/` | Upload a NAR (authenticated) | +| `PUT` | `/nar/` | Upload a NAR (authenticated, streamed to disk) | +`HEAD` is answered wherever `GET` is. + ### Public cache A public instance runs at `cache.novavero.ai`: @@ -95,7 +118,7 @@ cabal test ``` -Optional flags: `-f-compression` skips the `liblzma` dependency, and `--flag server` builds the cache server. Requires GHC 9.8+ and cabal-install 3.10+. +Optional extras: `--flag server` builds the cache server, and the public `nova-cache:xz`, `nova-cache:bzip2`, and `nova-cache:zstandard` sublibraries carry the bounded codecs (liblzma, libbz2, and libzstd are bundled - no system libraries needed) - consumers depend on them with `build-depends: nova-cache:xz` and the like. Requires GHC 9.14+ and cabal-install 3.10+. --- diff --git a/cbits/nova_bzip2.c b/cbits/nova_bzip2.c new file mode 100644 --- /dev/null +++ b/cbits/nova_bzip2.c @@ -0,0 +1,63 @@ +#include "nova_bzip2.h" + +#include + +/* calloc so every field starts zeroed: libbz2 reads NULL allocator + hooks as "use malloc/free", and a NULL state field makes the + destroy below safe on a stream that was never initialized. */ +bz_stream *nova_bzip2_stream_new(void) +{ + return (bz_stream *) calloc(1, sizeof(bz_stream)); +} + +/* ForeignPtr finalizer. BZ2_bzDecompressEnd on an uninitialized or + already-ended stream is a harmless BZ_PARAM_ERROR, so this is safe + in every decoder state; a NULL strm (failed calloc) is a no-op. */ +void nova_bzip2_stream_destroy(bz_stream *strm) +{ + if (strm != NULL) { + (void) BZ2_bzDecompressEnd(strm); + free(strm); + } +} + +/* verbosity 0 and small 0 (the fast algorithm), the arguments + upstream Nix's decompression sink passes. BZ2_bzDecompressInit + itself rejects a NULL strm with BZ_PARAM_ERROR, so a failed calloc + surfaces as a status, not a crash. */ +int nova_bzip2_decompress_init(bz_stream *strm) +{ + return BZ2_bzDecompressInit(strm, 0, 0); +} + +/* Between concatenated streams: tear down and start fresh on the + same struct, as upstream's decompression sink does at stream end + while input remains. */ +int nova_bzip2_decompress_reinit(bz_stream *strm) +{ + int ret = BZ2_bzDecompressEnd(strm); + if (ret != BZ_OK) { + return ret; + } + return BZ2_bzDecompressInit(strm, 0, 0); +} + +/* One BZ2_bzDecompress call: feed input, fill output, report both + counts. libbz2 only reads through next_in, but the field is not + const-qualified, so the parameter is plain char *. */ +int nova_bzip2_decompress_step(bz_stream *strm, + char *input, unsigned int input_len, + char *output, unsigned int output_len, + unsigned int *consumed, + unsigned int *produced) +{ + int ret; + strm->next_in = input; + strm->avail_in = input_len; + strm->next_out = output; + strm->avail_out = output_len; + ret = BZ2_bzDecompress(strm); + *consumed = input_len - strm->avail_in; + *produced = output_len - strm->avail_out; + return ret; +} diff --git a/cbits/nova_bzip2.h b/cbits/nova_bzip2.h new file mode 100644 --- /dev/null +++ b/cbits/nova_bzip2.h @@ -0,0 +1,19 @@ +/* Shim over libbz2 for NovaCache.Bzip2. The bz_stream struct stays + on the C side, where the compiler knows its layout, so the Haskell + binding carries no struct offsets to drift across platforms. */ +#ifndef NOVA_BZIP2_H +#define NOVA_BZIP2_H + +#include + +bz_stream *nova_bzip2_stream_new(void); +void nova_bzip2_stream_destroy(bz_stream *strm); +int nova_bzip2_decompress_init(bz_stream *strm); +int nova_bzip2_decompress_reinit(bz_stream *strm); +int nova_bzip2_decompress_step(bz_stream *strm, + char *input, unsigned int input_len, + char *output, unsigned int output_len, + unsigned int *consumed, + unsigned int *produced); + +#endif diff --git a/exe/LandingPage.hs b/exe/LandingPage.hs new file mode 100644 --- /dev/null +++ b/exe/LandingPage.hs @@ -0,0 +1,114 @@ +-- | The cache.novavero.ai landing page. +-- +-- Deployment branding lives here, in the executable: the +-- "NovaCache.Server" library is brand-free, taking whatever root +-- response its embedder supplies, so other operators running their own +-- cache never ship this page. +module LandingPage (landingResponse) where + +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Types as HTTP +import Network.Wai (Response, responseLBS) +import NovaCache.Store (CacheInfo (..), FileStore, getCacheInfo) + +-- | Build the @GET \/@ response: the branded page around live values +-- (store-path count, store dir, signing status, public key). +-- +-- The count comes from the injected action, not a store scan here: this +-- route is unauthenticated, so its per-request work must stay bounded - +-- the caller supplies a TTL-cached counter ('NovaCache.Server.newTTLCache'). +landingResponse :: IO Int -> FileStore -> Bool -> Maybe Text -> IO Response +landingResponse countPaths store signingEnabled pubKey = do + pathCount <- countPaths + let body = TE.encodeUtf8 (landingHtml (getCacheInfo store) signingEnabled pubKey pathCount) + pure (responseLBS HTTP.status200 htmlHeaders (BL.fromStrict body)) + +-- | The landing page markup. Static apart from four live values; styled +-- to match novavero.ai. Nothing user-supplied is interpolated - the key +-- line is operator configuration - so no escaping is needed. +landingHtml :: CacheInfo -> Bool -> Maybe Text -> Int -> Text +landingHtml info signingEnabled pubKey pathCount = + T.unlines + [ "", + "", + "", + "", + "", + "cache.novavero.ai - Nix binary cache", + "", + " novaveroLogoSvgEscaped <> "\" />", + "", + "", + "", + "
", + "
" <> novaveroLogoSvg <> "

cache.novavero.ai

", + "

Nix binary cache - serving store paths for nova-nix, the Windows-native Nix.

", + "
", + "
" <> T.pack (show pathCount) <> "
store paths
", + "
" <> (if signingEnabled then "ed25519" else "off") <> "
signing
", + "
" <> T.pack (show (ciPriority info)) <> "
priority
", + "
", + "

Use it

", + "
substituters = https://cache.novavero.ai" <> trustAnchorLine <> "
", + "

Store dir: " <> ciStoreDir info <> " · protocol endpoints: /nix-cache-info, /<hash>.narinfo, /nar/<file>

", + "

What this is

", + "

The binary cache behind the Novavero Nix toolchain. Powered by nova-cache, a Haskell implementation of the Nix binary cache protocol. Read about the first package built by Nix natively on Windows on the blog.

", + "
Novavero AI · Waterloo, Canada
", + "
", + "", + "" + ] + where + trustAnchorLine = maybe "" ("\ntrusted-public-keys = " <>) pubKey + +-- | The Novavero mark (the novavero.ai favicon), inlined so the page stays +-- a single self-contained response with no external assets. +novaveroLogoSvg :: Text +novaveroLogoSvg = + "" + <> "" + <> "" + <> "" + +-- | The same mark, URL-escaped for a data-URI favicon link. +novaveroLogoSvgEscaped :: Text +novaveroLogoSvgEscaped = + T.concatMap escapeForDataUri novaveroLogoSvg + where + escapeForDataUri c = case c of + '<' -> "%3C" + '>' -> "%3E" + '"' -> "%22" + '#' -> "%23" + other -> T.singleton other + +-- | Content-Type and caching headers for the landing page. Stats change as +-- paths are added, so it stays briefly cacheable but revalidates. +htmlHeaders :: HTTP.ResponseHeaders +htmlHeaders = + [ (HTTP.hContentType, "text/html; charset=utf-8"), + (HTTP.hCacheControl, "public, max-age=300, must-revalidate") + ] diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,36 +1,19 @@ module Main (main) where -import Control.Exception (SomeException) +import Control.Applicative ((<|>)) import Data.Bifunctor (first) -import Data.ByteArray (constEq) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromMaybe, isJust) +import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import qualified Network.HTTP.Types as HTTP -import Network.Wai - ( Application, - Request, - RequestBodyLength (..), - Response, - ResponseReceived, - getRequestBodyChunk, - pathInfo, - requestBodyLength, - requestHeaders, - requestMethod, - responseLBS, - ) +import LandingPage (landingResponse) import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger (logStdout) -import NovaCache.NarInfo (NarInfo (..), parseNarInfo, renderNarInfo) -import NovaCache.Signing (SecretKey, normalizeKeyText, parseSecretKey, renderPublicKey, sign, toPublicKey) -import NovaCache.Store (CacheInfo (..), FileStore, getCacheInfo, listNarInfoHashes, newFileStore, readNar, readNarInfo, writeNar, writeNarInfo) -import NovaCache.StorePath (defaultStoreDir, parseStorePath, storePathHashString) -import NovaCache.Validate (validateNarInfo) +import NovaCache.Server (ServerConfig (..), cacheApp, newTTLCache, onExceptionResponse) +import NovaCache.Signing (SecretKey, normalizeKeyText, parseSecretKey, renderPublicKey, toPublicKey) +import NovaCache.Store (listNarInfoHashes, newFileStore) import System.Environment (getArgs, lookupEnv) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -44,10 +27,36 @@ defaultPort :: Int defaultPort = 5000 +-- | Default bind host. @*@ binds every interface - the server's +-- historical behavior, kept as the default so existing deployments do +-- not silently rebind; a deployment opts into loopback itself via +-- @--host@ or @HOST@. +defaultBindHost :: String +defaultBindHost = "*" + -- | Default store directory. defaultStoreRoot :: FilePath defaultStoreRoot = "./nix-cache" +-- | How long the landing page's store-path count may serve stale, in +-- seconds. The count is a display stat; a minute of staleness is +-- invisible, and the bound keeps the unauthenticated root route at +-- constant cost regardless of request rate or store size. +pathCountTTLSeconds :: Double +pathCountTTLSeconds = 60 + +-- | Environment variable for the server port. +portEnvVar :: String +portEnvVar = "PORT" + +-- | Environment variable for the bind host. +hostEnvVar :: String +hostEnvVar = "HOST" + +-- | Environment variable for the store root directory. +storeEnvVar :: String +storeEnvVar = "NIX_CACHE_DIR" + -- | Environment variable for the write API key. apiKeyEnvVar :: String apiKeyEnvVar = "CACHE_API_KEY" @@ -60,39 +69,16 @@ requestLogEnvVar :: String requestLogEnvVar = "LOG_REQUESTS" --- | Maximum narinfo request body - narinfo is small text, so a tight cap. -maxNarInfoBodySize :: Int -maxNarInfoBodySize = 4 * 1024 * 1024 -- 4 MB - --- | Maximum NAR request body. A real store path's NAR can be very large --- (toolchains, GHC, LLVM), so this is far higher than the narinfo cap while --- still bounding memory. -maxNarBodySize :: Int -maxNarBodySize = 4 * 1024 * 1024 * 1024 -- 4 GB - -- --------------------------------------------------------------------------- --- Server configuration --- --------------------------------------------------------------------------- - --- | Runtime server configuration. -data Config = Config - { cfgStore :: !FileStore, - cfgApiKey :: !(Maybe BS.ByteString), - cfgSigningKey :: !(Maybe SecretKey), - -- | The rendered @name:base64@ public key line, derived from the - -- signing key at startup; shown on the landing page. - cfgPublicKey :: !(Maybe Text) - } - --- --------------------------------------------------------------------------- -- Main -- --------------------------------------------------------------------------- main :: IO () main = do args <- getArgs - portEnv <- lookupEnv "PORT" - storeEnv <- lookupEnv "NIX_CACHE_DIR" + portEnv <- lookupEnv portEnvVar + hostEnv <- lookupEnv hostEnvVar + storeEnv <- lookupEnv storeEnvVar apiKeyEnv <- lookupEnv apiKeyEnvVar sigKeyPath <- lookupEnv signingKeyEnvVar logRequestsEnv <- lookupEnv requestLogEnvVar @@ -105,32 +91,37 @@ port = case argValue "--port" >>= readMaybe of Just p -> p Nothing -> maybe defaultPort (fromMaybe defaultPort . readMaybe) portEnv + bindHost = fromMaybe defaultBindHost (argValue "--host" <|> hostEnv) storeRoot = fromMaybe (fromMaybe defaultStoreRoot storeEnv) (argValue "--store") allowOpenWrites = "--allow-open-writes" `elem` args store <- newFileStore storeRoot + apiKey <- loadApiKey apiKeyEnv sigKey <- loadSigningKey sigKeyPath pubKey <- derivePublicKeyLine sigKey + -- The landing page's store-path count rescans at most once per TTL; + -- the unauthenticated root route must not pay a full store scan per hit. + countPaths <- newTTLCache pathCountTTLSeconds (length <$> listNarInfoHashes store) let cfg = - Config - { cfgStore = store, - cfgApiKey = TE.encodeUtf8 . normalizeKeyText . T.pack <$> apiKeyEnv, - cfgSigningKey = sigKey, - cfgPublicKey = pubKey + ServerConfig + { scStore = store, + scApiKey = apiKey, + scSigningKey = sigKey, + scRootResponse = landingResponse countPaths store (isJust sigKey) pubKey } let logRequests = logRequestsEnv /= Just "0" requestLogger = if logRequests then logStdout else id - putStrLn ("nova-cache-server listening on port " ++ show port) + putStrLn ("nova-cache-server listening on " ++ bindHost ++ ":" ++ show port) putStrLn ("store root: " ++ storeRoot) putStrLn ("signing: " ++ maybe "disabled" (const "enabled") sigKey) mapM_ (\k -> putStrLn ("public key: " ++ T.unpack k)) pubKey - putStrLn ("write auth: " ++ maybe "disabled (open writes!)" (const "enabled") (cfgApiKey cfg)) + putStrLn ("write auth: " ++ maybe "disabled (open writes!)" (const "enabled") apiKey) putStrLn ("request logging: " ++ if logRequests then "enabled" else "disabled (LOG_REQUESTS=0)") - case cfgApiKey cfg of + case apiKey of Nothing | not allowOpenWrites -> do hPutStrLn stderr $ @@ -144,19 +135,44 @@ _ -> pure () let settings = - Warp.setPort port $ - Warp.setOnExceptionResponse onExceptionResponse Warp.defaultSettings - Warp.runSettings settings (requestLogger (app cfg)) + Warp.setHost (fromString bindHost) + $ Warp.setPort port + $ Warp.setOnExceptionResponse onExceptionResponse Warp.defaultSettings + Warp.runSettings settings (requestLogger (cacheApp cfg)) --- | Load a signing key from a file, if configured. +-- --------------------------------------------------------------------------- +-- Credential loading +-- --------------------------------------------------------------------------- + +-- | Normalize and validate the write API key. A key that normalizes to +-- empty (BOM or whitespace only - the classic copy-paste artifact) would +-- arm the auth gate with an empty secret that an empty bearer token +-- matches, so it is a startup error, never an armed guard. +loadApiKey :: Maybe String -> IO (Maybe BS.ByteString) +loadApiKey Nothing = pure Nothing +loadApiKey (Just raw) + | T.null normalized = do + hPutStrLn stderr $ + "FATAL: " + ++ apiKeyEnvVar + ++ " is set but empty after normalization - refusing to arm write auth with an empty key. " + ++ "Set a real key, or unset it and pass --allow-open-writes to run open." + exitFailure + | otherwise = pure (Just (TE.encodeUtf8 normalized)) + where + normalized = normalizeKeyText (T.pack raw) + +-- | Load a signing key from a file, if configured. A configured key that +-- fails to load is FATAL: falling back to unsigned would persist narinfos +-- no trust anchor can verify (the same fail-closed policy as signing). loadSigningKey :: Maybe FilePath -> IO (Maybe SecretKey) loadSigningKey Nothing = pure Nothing loadSigningKey (Just path) = do raw <- BS.readFile path case first show (TE.decodeUtf8' raw) >>= parseSecretKey . normalizeKeyText of Left err -> do - hPutStrLn stderr ("WARNING: failed to load signing key: " ++ err) - pure Nothing + hPutStrLn stderr ("FATAL: cannot load the signing key from " ++ path ++ ": " ++ err) + exitFailure Right sk -> pure (Just sk) -- | Derive the rendered public key line from the signing key, if any. @@ -169,344 +185,3 @@ hPutStrLn stderr ("WARNING: cannot derive the public key from the signing key: " ++ err) pure Nothing Right pk -> pure (Just (renderPublicKey pk)) - --- --------------------------------------------------------------------------- --- WAI application --- --------------------------------------------------------------------------- - --- | WAI application implementing the Nix binary cache HTTP protocol. -app :: Config -> Application -app cfg req respond = case (requestMethod req, pathInfo req) of - -- GET / - human-facing landing page (the protocol lives at the other routes) - ("GET", []) -> do - pathCount <- length <$> listNarInfoHashes (cfgStore cfg) - let info = getCacheInfo (cfgStore cfg) - signingEnabled = isJust (cfgSigningKey cfg) - body = TE.encodeUtf8 (landingHtml info signingEnabled (cfgPublicKey cfg) pathCount) - respond (responseLBS HTTP.status200 htmlHeaders (BL.fromStrict body)) - -- GET /nix-cache-info - ("GET", ["nix-cache-info"]) -> - respond (responseLBS HTTP.status200 textHeaders (BL.fromStrict (renderCacheInfo (cfgStore cfg)))) - -- GET /narinfo-hashes - ("GET", ["narinfo-hashes"]) -> do - hashes <- listNarInfoHashes (cfgStore cfg) - let body = TE.encodeUtf8 (T.unlines hashes) - respond (responseLBS HTTP.status200 textHeaders (BL.fromStrict body)) - -- GET /.narinfo - ("GET", [hashNarinfo]) - | Just hashKey <- T.stripSuffix ".narinfo" hashNarinfo -> do - result <- readNarInfo (cfgStore cfg) hashKey - case result of - Just content -> - respond (responseLBS HTTP.status200 narInfoHeaders (BL.fromStrict content)) - Nothing -> - respond notFound - -- GET /nar/ - ("GET", ["nar", fileName]) -> do - result <- readNar (cfgStore cfg) fileName - case result of - Just content -> - respond (responseLBS HTTP.status200 octetHeaders (BL.fromStrict content)) - Nothing -> - respond notFound - -- PUT /.narinfo (auth required, validated) - ("PUT", [hashNarinfo]) - | Just hashKey <- T.stripSuffix ".narinfo" hashNarinfo -> - requireAuth cfg req respond $ - withLimitedBody maxNarInfoBodySize req respond $ \body -> - case decodeAndValidate body of - Left err -> do - logWarn req ("INVALID: " <> T.unpack err) - respond (badRequest err) - Right ni - | not (narInfoHashMatches hashKey ni) -> do - logWarn req "HASHMISMATCH" - respond (badRequest "narinfo StorePath hash does not match request") - | otherwise -> do - signedResult <- signNarInfo (cfgSigningKey cfg) ni - case signedResult of - Left err -> do - logWarn req ("SIGNFAIL: " <> err) - respond (responseLBS HTTP.status500 textHeaders "signing failed") - Right signed -> do - ok <- writeNarInfo (cfgStore cfg) hashKey signed - if ok - then respond (responseLBS HTTP.status200 textHeaders "ok") - else do - logWarn req "BADPATH" - respond (badRequest "invalid path") - -- PUT /nar/ (auth required) - ("PUT", ["nar", fileName]) -> - requireAuth cfg req respond $ - withLimitedBody maxNarBodySize req respond $ \body -> do - ok <- writeNar (cfgStore cfg) fileName body - if ok - then respond (responseLBS HTTP.status200 textHeaders "ok") - else do - logWarn req "BADPATH" - respond (badRequest "invalid path") - -- Fallback - _ -> - respond notFound - --- --------------------------------------------------------------------------- --- Validation pipeline --- --------------------------------------------------------------------------- - --- | Decode a raw narinfo body and validate it in a single pure pipeline. --- --- Composes UTF-8 decoding, narinfo parsing, and field validation. Returns --- the validated 'NarInfo' on success, or a user-facing error message. -decodeAndValidate :: BS.ByteString -> Either Text NarInfo -decodeAndValidate body = do - decoded <- first (const "request body is not valid UTF-8") (TE.decodeUtf8' body) - ni <- first T.pack (parseNarInfo decoded) - first (T.unlines . map (T.pack . show)) (validateNarInfo ni) - --- | Whether the narinfo's declared StorePath actually carries the requested --- hash - so an authenticated writer cannot store a narinfo describing path X --- under path Y's key (a cache-poisoning / confused-deputy shape). -narInfoHashMatches :: Text -> NarInfo -> Bool -narInfoHashMatches hashKey ni = - case parseStorePath defaultStoreDir (niStorePath ni) of - Right sp -> storePathHashString sp == hashKey - Left _ -> False - --- --------------------------------------------------------------------------- --- Request body limiting --- --------------------------------------------------------------------------- - --- | Read the request body, rejecting payloads over the given limit. --- --- A declared @Content-Length@ over the limit is rejected up front; otherwise --- (including unsized/chunked transfers) the body is read in bounded chunks with --- a running size check that aborts before exceeding the limit, so memory stays --- bounded regardless of the declared length. -readBodyLimited :: Int -> Request -> IO (Maybe BS.ByteString) -readBodyLimited limit req = case requestBodyLength req of - KnownLength len - | len > fromIntegral limit -> pure Nothing - _ -> readChunks [] 0 - where - readChunks acc total = do - chunk <- getRequestBodyChunk req - if BS.null chunk - then pure (Just (BS.concat (reverse acc))) - else - let newTotal = total + BS.length chunk - in if newTotal > limit - then pure Nothing - else readChunks (chunk : acc) newTotal - --- | Run an action with the limited request body, responding 413 if too large. -withLimitedBody :: Int -> Request -> (Response -> IO ResponseReceived) -> (BS.ByteString -> IO ResponseReceived) -> IO ResponseReceived -withLimitedBody limit req respond action = do - bodyResult <- readBodyLimited limit req - case bodyResult of - Nothing -> do - logWarn req "OVERLIMIT" - respond (responseLBS HTTP.status413 textHeaders "request body too large") - Just body -> action body - --- --------------------------------------------------------------------------- --- Auth --- --------------------------------------------------------------------------- - --- | Gate a handler behind API key authentication. --- --- If no key is configured, all writes are permitted (open mode). --- Otherwise the request must carry @Authorization: Bearer \@. --- Uses constant-time comparison to prevent timing attacks. -requireAuth :: Config -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -> IO ResponseReceived -requireAuth cfg req respond action = case cfgApiKey cfg of - Nothing -> action - Just expected -> - let provided = lookup HTTP.hAuthorization (requestHeaders req) - expectedHeader = "Bearer " <> expected - in if maybe False (constEq expectedHeader) provided - then action - else do - logWarn req "REJECTED" - respond (responseLBS HTTP.status401 textHeaders "unauthorized") - --- --------------------------------------------------------------------------- --- Signing --- --------------------------------------------------------------------------- - --- | Sign a validated 'NarInfo' if a signing key is configured. --- --- With no key, returns the unsigned rendering (intentional - the operator --- configured none). With a key, FAILS CLOSED: a signing error returns 'Left' --- so the handler refuses the write rather than persisting an unsigned narinfo --- on a cache that is supposed to sign. -signNarInfo :: Maybe SecretKey -> NarInfo -> IO (Either String BS.ByteString) -signNarInfo Nothing ni = pure (Right (renderNarInfoBytes ni)) -signNarInfo (Just sk) ni = case sign sk ni of - Left err -> do - hPutStrLn stderr ("ERROR: signNarInfo: sign failed: " ++ err) - pure (Left err) - Right sig -> - let signed = ni {niSigs = niSigs ni ++ [sig]} - in pure (Right (renderNarInfoBytes signed)) - --- | Render a 'NarInfo' to its UTF-8 encoded wire format. -renderNarInfoBytes :: NarInfo -> BS.ByteString -renderNarInfoBytes = TE.encodeUtf8 . renderNarInfo - --- --------------------------------------------------------------------------- --- Logging --- --------------------------------------------------------------------------- - --- | Log a server-side warning to stderr with request context. -logWarn :: Request -> String -> IO () -logWarn req msg = - hPutStrLn stderr $ - msg - <> " " - <> BS8.unpack (requestMethod req) - <> " /" - <> T.unpack (T.intercalate "/" (pathInfo req)) - --- --------------------------------------------------------------------------- --- Response helpers --- --------------------------------------------------------------------------- - --- | Render the nix-cache-info response body. -renderCacheInfo :: FileStore -> BS.ByteString -renderCacheInfo store = - let info = getCacheInfo store - in TE.encodeUtf8 $ - T.unlines - [ "StoreDir: " <> ciStoreDir info, - "WantMassQuery: " <> boolText (ciWantMassQuery info), - "Priority: " <> T.pack (show (ciPriority info)) - ] - --- | Render a Bool as @1@ or @0@. -boolText :: Bool -> Text -boolText True = "1" -boolText False = "0" - --- | The landing page served at @GET /@. Static apart from four live --- values (store-path count, store dir, signing status, public key); styled --- to match novavero.ai. Nothing user-supplied is interpolated - the key --- line is operator configuration - so no escaping is needed. -landingHtml :: CacheInfo -> Bool -> Maybe Text -> Int -> Text -landingHtml info signingEnabled pubKey pathCount = - T.unlines - [ "", - "", - "", - "", - "", - "cache.novavero.ai - Nix binary cache", - "", - " novaveroLogoSvgEscaped <> "\" />", - "", - "", - "", - "
", - "
" <> novaveroLogoSvg <> "

cache.novavero.ai

", - "

Nix binary cache - serving store paths for nova-nix, the Windows-native Nix.

", - "
", - "
" <> T.pack (show pathCount) <> "
store paths
", - "
" <> (if signingEnabled then "ed25519" else "off") <> "
signing
", - "
" <> T.pack (show (ciPriority info)) <> "
priority
", - "
", - "

Use it

", - "
substituters = https://cache.novavero.ai" <> trustAnchorLine <> "
", - "

Store dir: " <> ciStoreDir info <> " · protocol endpoints: /nix-cache-info, /<hash>.narinfo, /nar/<file>

", - "

What this is

", - "

The binary cache behind the Novavero Nix toolchain. Powered by nova-cache, a Haskell implementation of the Nix binary cache protocol. Read about the first package built by Nix natively on Windows on the blog.

", - "
Novavero AI · Waterloo, Canada
", - "
", - "", - "" - ] - where - trustAnchorLine = maybe "" ("\ntrusted-public-keys = " <>) pubKey - --- | The Novavero mark (the novavero.ai favicon), inlined so the page stays --- a single self-contained response with no external assets. -novaveroLogoSvg :: Text -novaveroLogoSvg = - "" - <> "" - <> "" - <> "" - --- | The same mark, URL-escaped for a data-URI favicon link. -novaveroLogoSvgEscaped :: Text -novaveroLogoSvgEscaped = - T.concatMap escapeForDataUri novaveroLogoSvg - where - escapeForDataUri c = case c of - '<' -> "%3C" - '>' -> "%3E" - '"' -> "%22" - '#' -> "%23" - other -> T.singleton other - --- | Content-Type and caching headers for the landing page. Stats change as --- paths are added, so it stays briefly cacheable but revalidates. -htmlHeaders :: HTTP.ResponseHeaders -htmlHeaders = - [ (HTTP.hContentType, "text/html; charset=utf-8"), - (HTTP.hCacheControl, "public, max-age=300, must-revalidate") - ] - --- | 404 Not Found response. -notFound :: Response -notFound = responseLBS HTTP.status404 textHeaders "not found" - --- | 400 Bad Request with a text error message. -badRequest :: Text -> Response -badRequest msg = responseLBS HTTP.status400 textHeaders (BL.fromStrict (TE.encodeUtf8 msg)) - --- | Map any uncaught handler exception to a generic 500, so internal error --- detail (filesystem paths, exception text) is never leaked to clients. -onExceptionResponse :: SomeException -> Response -onExceptionResponse _ = responseLBS HTTP.status500 textHeaders "internal server error" - --- | Content-Type: text/plain headers. -textHeaders :: HTTP.ResponseHeaders -textHeaders = [(HTTP.hContentType, "text/plain")] - --- | Content-Type and caching headers for a narinfo response. --- A narinfo body is NOT immutable for a fixed key - re-uploading the same store --- path to add or rotate a signature changes it - so it is cacheable but must --- stay revalidatable (no @immutable@). -narInfoHeaders :: HTTP.ResponseHeaders -narInfoHeaders = - [ (HTTP.hContentType, "text/x-nix-narinfo"), - (HTTP.hCacheControl, "public, max-age=3600, must-revalidate") - ] - --- | Content-Type: application/octet-stream headers. --- NAR files are content-addressed (keyed by content hash) and immutable --- once written, so they are safe to cache indefinitely at the CDN edge. -octetHeaders :: HTTP.ResponseHeaders -octetHeaders = - [ (HTTP.hContentType, "application/octet-stream"), - (HTTP.hCacheControl, "public, max-age=31536000, immutable") - ] diff --git a/nova-cache.cabal b/nova-cache.cabal --- a/nova-cache.cabal +++ b/nova-cache.cabal @@ -1,11 +1,14 @@ cabal-version: 3.0 name: nova-cache -version: 0.4.2.1 +version: 0.11.0.1 synopsis: Pure-first Nix binary cache protocol library description: A pure-first library implementing the Nix binary cache protocol - - nix-base32, NAR serialization, narinfo parsing, Ed25519 signing, store - path handling, and content validation - with an optional WAI server. + nix-base32, NAR serialization (whole-tree and streaming), narinfo + parsing, Ed25519 signing, store path handling, and content + validation - with an optional WAI server, and bounded xz, bzip2, + and zstd codecs as the public @nova-cache:xz@, @nova-cache:bzip2@, + and @nova-cache:zstandard@ sublibraries. license: Apache-2.0 license-file: LICENSE @@ -17,50 +20,69 @@ category: Nix, Distribution stability: experimental build-type: Simple -tested-with: GHC == 9.8.4 +tested-with: GHC == 9.14.1 extra-doc-files: CHANGELOG.md + NOTICE README.md +extra-source-files: + cbits/nova_bzip2.h flag server - description: Build the cache server executable (pulls in warp/wai) + description: Build the cache server executable (pulls in warp and wai-extra) default: False manual: True -flag compression - description: Enable LZMA/XZ compression (requires system liblzma) - default: True - manual: True - library exposed-modules: NovaCache.Base32 NovaCache.Base64 NovaCache.Hash NovaCache.NAR + NovaCache.NAR.Stream NovaCache.NarInfo + NovaCache.SafeName + NovaCache.Server NovaCache.Signing NovaCache.Store NovaCache.StorePath NovaCache.Validate - if flag(compression) - exposed-modules: NovaCache.Compression - build-depends: lzma >= 0.0.1 && < 0.1 - build-depends: - base >= 4.16 && < 5 + base >= 4.22 && < 5 , base64-bytestring >= 1.2 && < 1.3 , bytestring >= 0.11 && < 0.13 , containers >= 0.6 && < 0.9 , crypton >= 1.1 && < 2 - , directory >= 1.3 && < 1.4 - , filepath >= 1.4 && < 1.6 + , directory >= 1.3.8 && < 1.4 + , filepath >= 1.4.100 && < 1.6 + , http-types >= 0.12 && < 0.13 , ram >= 0.20 && < 1 , text >= 2.0 && < 2.2 , vector >= 0.12 && < 0.14 + , wai >= 3.2 && < 3.3 + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + BangPatterns + OverloadedStrings + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns +-- The bounded xz decoder as a solver-visible opt-in: a consumer that +-- substitutes foreign caches writes build-depends: nova-cache:xz and +-- gets the module; everyone else never builds lzma-static's bundled +-- liblzma. This replaces the manual xz flag - a dependency's flag +-- cannot be set from a consumer's .cabal file, which forced mirror +-- flags and matching constraints downstream (nova-nix#27) - while +-- keeping the 0.5.0.0 lesson: xz stays out of the default install. +library xz + visibility: public + exposed-modules: NovaCache.Xz hs-source-dirs: src default-language: Haskell2010 default-extensions: @@ -72,11 +94,71 @@ -Wincomplete-record-updates -Wincomplete-uni-patterns + build-depends: + base >= 4.22 && < 5 + , bytestring >= 0.11 && < 0.13 + , lzma-static >= 5.2.5 && < 5.3 + +-- The bounded bzip2 decoder, the same solver-visible opt-in as xz. +-- Historical cache.nixos.org narinfos declare Compression: bzip2, and +-- upstream reads an absent Compression field as bzip2, so substituting +-- old paths needs the codec. No existing binding bundles libbz2's C +-- sources on every platform (bzlib links the system library outside +-- Windows), so the module drives libbz2 directly over bzip2-clib - +-- nothing but the bundled sources - through the cbits shim. +library bzip2 + visibility: public + exposed-modules: NovaCache.Bzip2 + hs-source-dirs: src + c-sources: cbits/nova_bzip2.c + include-dirs: cbits + default-language: Haskell2010 + default-extensions: + BangPatterns + OverloadedStrings + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + + build-depends: + base >= 4.22 && < 5 + , bytestring >= 0.11 && < 0.13 + , bzip2-clib >= 1.0.8 && < 1.1 + +-- The bounded zstd codec, the same solver-visible opt-in as xz. +-- Named zstandard, not zstd: an in-package component name shadows the +-- like-named external package in every build-depends of this package, +-- so a sublibrary called zstd could never depend on the zstd binding. +-- Consumers substituting from zstd caches (or pushing compressed) +-- depend on nova-cache:zstandard; the zstd package bundles libzstd's +-- C sources, so nobody else builds them. +library zstandard + visibility: public + exposed-modules: NovaCache.Zstd + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + BangPatterns + OverloadedStrings + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + + build-depends: + base >= 4.22 && < 5 + , bytestring >= 0.11 && < 0.13 + , zstd >= 0.1 && < 0.2 + executable nova-cache-server if !flag(server) buildable: False main-is: Main.hs + other-modules: LandingPage hs-source-dirs: exe default-language: Haskell2010 default-extensions: @@ -84,11 +166,9 @@ ghc-options: -Wall -Wcompat -threaded -rtsopts build-depends: - base >= 4.16 && < 5 + base >= 4.22 && < 5 , bytestring >= 0.11 && < 0.13 - , crypton >= 1.1 && < 2 , nova-cache - , ram >= 0.20 && < 1 , http-types >= 0.12 && < 0.13 , text >= 2.0 && < 2.2 , wai >= 3.2 && < 3.3 @@ -105,21 +185,35 @@ ghc-options: -Wall -Wcompat build-depends: - base >= 4.16 && < 5 + base >= 4.22 && < 5 , base64-bytestring >= 1.2 && < 1.3 , bytestring >= 0.11 && < 0.13 , crypton >= 1.1 && < 2 , directory >= 1.3 && < 1.4 + , http-types >= 0.12 && < 0.13 , nova-cache , ram >= 0.20 && < 1 , text >= 2.0 && < 2.2 + , wai >= 3.2 && < 3.3 + , wai-extra >= 3.1 && < 3.2 -test-suite nova-cache-compression-test - if !flag(compression) - buildable: False +test-suite nova-cache-xz-test + type: exitcode-stdio-1.0 + main-is: XzTest.hs + hs-source-dirs: test + default-language: Haskell2010 + default-extensions: + OverloadedStrings + ghc-options: -Wall -Wcompat + build-depends: + base >= 4.22 && < 5 + , bytestring >= 0.11 && < 0.13 + , nova-cache:xz + +test-suite nova-cache-bzip2-test type: exitcode-stdio-1.0 - main-is: CompressionTest.hs + main-is: Bzip2Test.hs hs-source-dirs: test default-language: Haskell2010 default-extensions: @@ -127,9 +221,23 @@ ghc-options: -Wall -Wcompat build-depends: - base >= 4.16 && < 5 + base >= 4.22 && < 5 , bytestring >= 0.11 && < 0.13 - , nova-cache + , nova-cache:bzip2 + +test-suite nova-cache-zstd-test + type: exitcode-stdio-1.0 + main-is: ZstdTest.hs + hs-source-dirs: test + default-language: Haskell2010 + default-extensions: + OverloadedStrings + ghc-options: -Wall -Wcompat + + build-depends: + base >= 4.22 && < 5 + , bytestring >= 0.11 && < 0.13 + , nova-cache:zstandard source-repository head type: git diff --git a/src/NovaCache/Bzip2.hs b/src/NovaCache/Bzip2.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/Bzip2.hs @@ -0,0 +1,465 @@ +-- EmptyDataDecls for the opaque 'BzStream' tag alone: the C struct +-- has no Haskell values, and a placeholder constructor would be +-- unused by construction (which -Werror rightly refuses). +{-# LANGUAGE EmptyDataDecls #-} + +-- | Bounded bzip2 decompression for untrusted cache data. +-- +-- Historical cache.nixos.org narinfos declare @Compression: bzip2@, +-- and upstream C++ Nix reads an absent @Compression@ field as bzip2 +-- (nova-cache's narinfo parser defaults the same way), so +-- substituting those paths needs this decoder. Substitution +-- decompresses bytes that arrive from the network BEFORE any hash +-- can vouch for them, so the decoder must not be steerable into +-- unbounded allocation. The consumer knows the narinfo's declared +-- NarSize before decompressing: decompression takes that bound and +-- fails past it ('bzip2MaxOutputBytes'). +-- +-- There is no decoder-memory knob like the xz codec's +-- @xzMaxDecoderMemoryBytes@: bzip2 carries no attacker-chosen +-- dictionary size, and decoding allocates a fixed small amount - +-- about 4 MiB at the format's largest block size (900k) - so decoder +-- memory is a constant of the format, not a parameter. +-- +-- Concatenated streams decode as one output, and trailing bytes that +-- do not begin another stream end the output rather than failing it: +-- upstream C++ Nix decompresses bzip2 through libarchive, which does +-- both. Truncated input is still refused, including a truncated +-- concatenated stream, since silently truncating output is the +-- failure mode a bounded decoder exists to avoid. +-- +-- Everything here is IO: the decoder is libbz2, driven over the FFI. +-- The binding goes directly over @bzip2-clib@ (nothing but the +-- bundled C sources) because no existing binding bundles them on +-- every platform - @bzlib@ links the system library outside Windows +-- - and the codec sublibraries promise no system library anywhere. +-- +-- This module lives in the public @nova-cache:bzip2@ sublibrary, the +-- same solver-visible opt-in as @nova-cache:xz@: consumers that +-- substitute bzip2 paths depend on it; everyone else never builds +-- the bundled libbz2. +module NovaCache.Bzip2 + ( Bzip2Limits (..), + Bzip2Error (..), + decompress, + withBzip2Source, + ) +where + +import Control.Exception (Exception, SomeException, finally, throwIO, toException, try) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe) +import Data.Word (Word64, Word8) +import Foreign.C.Types (CChar, CInt (..), CUInt (..)) +import Foreign.ForeignPtr (FinalizerPtr, ForeignPtr, finalizeForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) + +-- --------------------------------------------------------------------------- +-- Limits +-- --------------------------------------------------------------------------- + +-- | What a decode run may cost. The bound is inclusive: output of +-- exactly 'bzip2MaxOutputBytes' passes, one byte more fails - a +-- narinfo's NarSize is exact, so the declared size itself must be +-- reachable. Decoder-state memory is a small format constant (see +-- the module header), not a field here. +newtype Bzip2Limits = Bzip2Limits + { -- | Maximum decompressed output, in bytes: the narinfo's declared + -- NarSize. + bzip2MaxOutputBytes :: Word64 + } + deriving (Eq, Show) + +-- --------------------------------------------------------------------------- +-- Errors +-- --------------------------------------------------------------------------- + +-- | Everything a bounded decode can refuse. 'decompress' returns +-- these in 'Left'; the pull source behind 'withBzip2Source' throws +-- them (see the 'Exception' instance). +data Bzip2Error + = -- | The compressed stream is malformed, truncated, or carries + -- trailing bytes that do not start a valid stream (libbz2's + -- status, rendered). + Bzip2StreamError !String + | -- | Decompressed output would exceed the bound (carried here). + Bzip2OutputOverBound !Word64 + deriving (Eq, Show) + +-- | Thrown by the pull source 'withBzip2Source' hands its +-- continuation; a chunk convention has no error channel, and a +-- throwing pull composes with consumers built around one. +instance Exception Bzip2Error + +-- --------------------------------------------------------------------------- +-- Bounded decode +-- --------------------------------------------------------------------------- + +-- | Decompress one bzip2 payload under the given limits. Output +-- stops accumulating the moment it would pass the bound, so a +-- high-expansion input costs at most the bound plus one decoder +-- buffer, never what it claims to hold. +decompress :: Bzip2Limits -> ByteString -> IO (Either Bzip2Error ByteString) +decompress limits input = do + opened <- newDecoder + case opened of + Left err -> pure (Left err) + Right decoder -> + -- The decoder owns malloc'd libbz2 state (a block table up to + -- 3.6 MB) that the RTS cannot see, so it creates no GC pressure + -- and would otherwise be released at a finalizer's leisure. + -- Release it here on every exit, as the zstd codec does. + collectFrom decoder `finally` finalizeForeignPtr (decoderStream decoder) + where + collectFrom decoder = do + -- The IORef makes the whole input a one-shot chunk source + -- (input, then the empty end marker), so the strict path + -- drives the same engine as the streaming one. + remainingRef <- newIORef input + let source = do + held <- readIORef remainingRef + writeIORef remainingRef BS.empty + pure held + collect source decoder [] + + collect source decoder acc = do + outcome <- nextDecodedChunk limits source decoder + case outcome of + Left err -> pure (Left err) + Right Nothing -> pure (Right (BS.concat (reverse acc))) + Right (Just (chunk, next)) -> collect source next (chunk : acc) + +-- --------------------------------------------------------------------------- +-- Streaming bounded decode +-- --------------------------------------------------------------------------- + +-- | What the pull source is doing between calls. The 'IORef' +-- holding this is a deliberate, documented mutable boundary, the +-- same as the xz and zstd sources. A failure is a state of its own: +-- once a pull has thrown, every later pull rethrows - never the +-- empty chunk, which would let a consumer that catches and retries +-- mistake a failed transfer for complete output. +data Bzip2SourceState + = Bzip2Streaming !Decoder + | Bzip2Drained + | Bzip2Failed !SomeException + +-- | Decompress a chunk source into a chunk source, under the +-- limits. The continuation's pull yields decompressed chunks; the +-- empty chunk means end of output and repeats on further pulls. +-- The compressed source follows the same convention on its side. +-- Pairs with the incremental NAR parser and hashing, so a +-- substituter can fetch, decompress, hash, and unpack in one +-- bounded pass. +-- +-- Limit violations and malformed input are thrown as 'Bzip2Error' +-- from the pull. A pull that fails latches: every later pull +-- rethrows the same exception, so a catch-and-retry consumer can +-- never mistake an aborted transfer for a clean end of output. +withBzip2Source :: Bzip2Limits -> IO ByteString -> (IO ByteString -> IO a) -> IO a +withBzip2Source limits compressedSource consume = do + opened <- newDecoder + case opened of + Left err -> do + stateRef <- newIORef (Bzip2Failed (toException err)) + consume (pullDecompressed limits compressedSource stateRef) + Right decoder -> do + stateRef <- newIORef (Bzip2Streaming decoder) + -- Deterministic teardown on every exit - clean end, bound + -- violation, decode failure, or an exception in the consumer. + -- libbz2's block table is malloc'd and invisible to the RTS, so + -- leaving it to the ForeignPtr finalizer lets sequential decodes + -- accumulate decoder state in proportion to how rarely the GC runs. + consume (pullDecompressed limits compressedSource stateRef) + `finally` finalizeForeignPtr (decoderStream decoder) + +-- | Produce the next decompressed chunk. +pullDecompressed :: Bzip2Limits -> IO ByteString -> IORef Bzip2SourceState -> IO ByteString +pullDecompressed limits compressedSource stateRef = advance =<< readIORef stateRef + where + advance state = case state of + Bzip2Drained -> pure BS.empty + Bzip2Failed failure -> throwIO failure + Bzip2Streaming decoder -> do + outcome <- tryPull (nextDecodedChunk limits compressedSource decoder) + case outcome of + Left failure -> do + writeIORef stateRef (Bzip2Failed failure) + throwIO failure + Right (Left err) -> do + writeIORef stateRef (Bzip2Failed (toException err)) + throwIO err + Right (Right Nothing) -> do + writeIORef stateRef Bzip2Drained + pure BS.empty + Right (Right (Just (chunk, next))) -> do + writeIORef stateRef (Bzip2Streaming next) + pure chunk + +-- | 'try' at 'SomeException', monomorphic so the catch-all needs no +-- annotation at the call site. Any exception escaping a pull - the +-- compressed source failing included - leaves the transfer +-- unfinishable, and the only sound later answer is the same failure +-- again, so the caller latches whatever this catches. +tryPull :: + IO (Either Bzip2Error (Maybe (ByteString, Decoder))) -> + IO (Either SomeException (Either Bzip2Error (Maybe (ByteString, Decoder)))) +tryPull = try + +-- --------------------------------------------------------------------------- +-- Shared decoder engine +-- --------------------------------------------------------------------------- + +-- | Decoder identity threaded between engine steps: the C stream, +-- input handed over but not yet consumed, output produced so far +-- (the bound's basis), and whether the decoder sits at a stream +-- boundary. +data Decoder = Decoder + { decoderStream :: !(ForeignPtr BzStream), + decoderLeftover :: !ByteString, + decoderProduced :: !Word64, + decoderPhase :: !DecoderPhase + } + +-- | 'AtStreamBoundary' means a stream just ended cleanly: end of +-- input here is a clean end of output, while more input means a +-- concatenated stream follows. Anywhere else, end of input is +-- truncation. +data DecoderPhase = MidStream | AtStreamBoundary + +-- | A freshly initialized decoder. Failure here is libbz2 refusing +-- to initialize (or the allocation failing, which the shim folds +-- into the same status), rendered as a stream error. +newDecoder :: IO (Either Bzip2Error Decoder) +newDecoder = do + rawStream <- cStreamNew + stream <- newForeignPtr cStreamDestroy rawStream + status <- withForeignPtr stream cDecompressInit + pure $ + if status == statusOk + then + Right + Decoder + { decoderStream = stream, + decoderLeftover = BS.empty, + decoderProduced = 0, + decoderPhase = MidStream + } + else Left (Bzip2StreamError (renderStatus status)) + +-- | Advance the decoder to its next decompressed chunk: 'Nothing' +-- is the clean end of output, 'Just' carries a nonempty chunk and +-- the decoder to continue from. Both 'decompress' and +-- 'withBzip2Source' drive this engine, so the bound arithmetic and +-- the stream-boundary rules exist once. +nextDecodedChunk :: + Bzip2Limits -> + IO ByteString -> + Decoder -> + IO (Either Bzip2Error (Maybe (ByteString, Decoder))) +nextDecodedChunk limits compressedSource = advance + where + advance decoder = case decoderPhase decoder of + AtStreamBoundary -> continueAfterStream decoder + MidStream + | BS.null (decoderLeftover decoder) -> do + chunk <- compressedSource + if BS.null chunk + then pure (Left (Bzip2StreamError truncatedInputMessage)) + else advance decoder {decoderLeftover = chunk} + | otherwise -> decodeStep decoder + + -- Input after a clean stream end. Upstream C++ Nix decompresses + -- bzip2 through libarchive (its own BzipDecompressionSink is gone), + -- and libarchive decodes the payload and ignores trailing bytes that + -- do not begin another stream: a single stray NUL or newline after + -- the last stream substitutes fine under `nix copy` and used to fail + -- here. Bytes that DO begin a stream header are decoded as a + -- concatenated stream, and a truncated one still fails, since + -- libarchive refuses those too and silently truncating a real stream + -- is the failure mode worth keeping. One measured divergence + -- remains: a trailer that is a well-formed header carrying no block + -- data (`BZh9` alone) is refused here and accepted by libarchive, + -- which buffers past it - refusing is the safer side of a case that + -- does not arise in practice. + continueAfterStream decoder = do + trailing <- fillToHeader (decoderLeftover decoder) + if startsStream trailing + then reopen decoder {decoderLeftover = trailing} + else pure (Right Nothing) + + -- Top the held bytes up to a full stream header, so the decision + -- above is never taken on a short read that more input completes. + fillToHeader held + | BS.length held >= streamHeaderLength = pure held + | otherwise = do + chunk <- compressedSource + if BS.null chunk + then pure held + else fillToHeader (held <> chunk) + + -- Re-initialize and decode the trailing bytes as the next + -- concatenated stream. + reopen decoder = do + status <- withForeignPtr (decoderStream decoder) cDecompressReinit + if status == statusOk + then advance decoder {decoderPhase = MidStream} + else pure (Left (Bzip2StreamError (renderStatus status))) + + decodeStep decoder = do + (status, consumedCount, outChunk) <- + runDecompressStep (decoderStream decoder) (decoderLeftover decoder) + let remaining = BS.drop consumedCount (decoderLeftover decoder) + finished = status == statusStreamEnd + if status /= statusOk && not finished + then pure (Left (Bzip2StreamError (renderStatus status))) + else case growWithinBound limits (decoderProduced decoder) (BS.length outChunk) of + Left err -> pure (Left err) + Right grown -> + let continued = + decoder + { decoderLeftover = remaining, + decoderProduced = grown, + decoderPhase = if finished then AtStreamBoundary else MidStream + } + in -- An empty step (input absorbed, nothing produced + -- yet) must not surface as the end-of-output chunk. + if BS.null outChunk + then advance continued + else pure (Right (Just (outChunk, continued))) + +-- | Does this begin a bzip2 stream: the @BZh@ magic followed by a +-- block-size digit? The trailing-bytes decision rests on this, so it +-- reads only the header and never consumes. +startsStream :: ByteString -> Bool +startsStream bytes = + streamMagic `BS.isPrefixOf` bytes + && case BS.indexMaybe bytes (BS.length streamMagic) of + Just level -> level >= minBlockSizeDigit && level <= maxBlockSizeDigit + Nothing -> False + +-- | The bytes every bzip2 stream opens with, before the block-size digit. +streamMagic :: ByteString +streamMagic = "BZh" + +-- | A full stream header: the magic and the block-size digit after it. +streamHeaderLength :: Int +streamHeaderLength = BS.length streamMagic + 1 + +-- | @\'1\'@ and @\'9\'@: the block-size digits bzip2 defines, in +-- hundreds of kilobytes. +minBlockSizeDigit, maxBlockSizeDigit :: Word8 +minBlockSizeDigit = 0x31 +maxBlockSizeDigit = 0x39 + +-- | The one place the output bound is enforced: the produced count +-- grown by a chunk, refused past the bound. Inclusive - reaching +-- the bound exactly passes, because a narinfo's NarSize is exact. +growWithinBound :: Bzip2Limits -> Word64 -> Int -> Either Bzip2Error Word64 +growWithinBound limits produced chunkLength + | grown > bound = Left (Bzip2OutputOverBound bound) + | otherwise = Right grown + where + bound = bzip2MaxOutputBytes limits + grown = produced + fromIntegral chunkLength + +-- | One BZ2_bzDecompress call through the shim: feed at most +-- 'stepBufferBytes' of the input against a fresh output buffer, and +-- yield the status, the count of input bytes consumed, and the +-- bytes produced. +runDecompressStep :: ForeignPtr BzStream -> ByteString -> IO (CInt, Int, ByteString) +runDecompressStep stream input = + withForeignPtr stream $ \streamPtr -> + unsafeUseAsCStringLen (BS.take stepBufferBytes input) $ \(inputPtr, inputLength) -> + allocaBytes stepBufferBytes $ \outputPtr -> + alloca $ \consumedPtr -> + alloca $ \producedPtr -> do + status <- + cDecompressStep + streamPtr + inputPtr + (fromIntegral inputLength) + outputPtr + (fromIntegral stepBufferBytes) + consumedPtr + producedPtr + consumedCount <- peek consumedPtr + producedCount <- peek producedPtr + outChunk <- BS.packCStringLen (outputPtr, fromIntegral producedCount) + pure (status, fromIntegral consumedCount, outChunk) + +-- | Per-step transfer size, for both the input fed across the FFI +-- and the output buffer: bounds one unsafe C call's work, and keeps +-- the lengths within CUInt on every platform however large a chunk +-- the source hands over. +stepBufferBytes :: Int +stepBufferBytes = 64 * 1024 + +truncatedInputMessage :: String +truncatedInputMessage = "input ends inside a bzip2 stream" + +-- --------------------------------------------------------------------------- +-- FFI boundary +-- --------------------------------------------------------------------------- + +-- | Opaque tag for libbz2's @bz_stream@; the struct lives behind +-- the shim and is never inspected from Haskell. +data BzStream + +-- | libbz2's status names by return code, as bzlib.h declares them. +statusNames :: [(CInt, String)] +statusNames = + [ (0, "BZ_OK"), + (1, "BZ_RUN_OK"), + (2, "BZ_FLUSH_OK"), + (3, "BZ_FINISH_OK"), + (4, "BZ_STREAM_END"), + (-1, "BZ_SEQUENCE_ERROR"), + (-2, "BZ_PARAM_ERROR"), + (-3, "BZ_MEM_ERROR"), + (-4, "BZ_DATA_ERROR"), + (-5, "BZ_DATA_ERROR_MAGIC"), + (-6, "BZ_IO_ERROR"), + (-7, "BZ_UNEXPECTED_EOF"), + (-8, "BZ_OUTBUFF_FULL"), + (-9, "BZ_CONFIG_ERROR") + ] + +statusOk :: CInt +statusOk = 0 + +statusStreamEnd :: CInt +statusStreamEnd = 4 + +-- | Render a libbz2 status by its bzlib.h name. +renderStatus :: CInt -> String +renderStatus status = + fromMaybe ("bzip2 status " <> show status) (lookup status statusNames) + +foreign import ccall unsafe "nova_bzip2_stream_new" + cStreamNew :: IO (Ptr BzStream) + +foreign import ccall unsafe "&nova_bzip2_stream_destroy" + cStreamDestroy :: FinalizerPtr BzStream + +foreign import ccall unsafe "nova_bzip2_decompress_init" + cDecompressInit :: Ptr BzStream -> IO CInt + +foreign import ccall unsafe "nova_bzip2_decompress_reinit" + cDecompressReinit :: Ptr BzStream -> IO CInt + +foreign import ccall unsafe "nova_bzip2_decompress_step" + cDecompressStep :: + Ptr BzStream -> + Ptr CChar -> + CUInt -> + Ptr CChar -> + CUInt -> + Ptr CUInt -> + Ptr CUInt -> + IO CInt diff --git a/src/NovaCache/Compression.hs b/src/NovaCache/Compression.hs deleted file mode 100644 --- a/src/NovaCache/Compression.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | xz compression and decompression for NAR files. --- --- Thin wrappers around the @lzma@ package, converting between strict --- 'ByteString' and the underlying lazy interface. -module NovaCache.Compression - ( compressXz, - decompressXz, - ) -where - -import qualified Codec.Compression.Lzma as Lzma -import Control.Exception (SomeAsyncException, SomeException, evaluate, fromException, throwIO, try) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BL - --- | Compress a strict 'ByteString' with xz. -compressXz :: ByteString -> ByteString -compressXz = BL.toStrict . Lzma.compress . BL.fromStrict - --- | Decompress an xz-compressed strict 'ByteString'. --- --- Returns 'Left' with an error message if the input is not valid xz data. -decompressXz :: ByteString -> IO (Either String ByteString) -decompressXz bs = do - result <- try (evaluate (BL.toStrict (Lzma.decompress (BL.fromStrict bs)))) - case result of - Right decompressed -> pure (Right decompressed) - -- Catch only SYNCHRONOUS failures; re-raise async exceptions (timeout, - -- ThreadKilled) so a caller's timeout/cancellation still works on this - -- untrusted-input decoder. - Left err - | Just (_ :: SomeAsyncException) <- fromException err -> throwIO err - | otherwise -> pure (Left ("xz decompression failed: " ++ show (err :: SomeException))) diff --git a/src/NovaCache/Hash.hs b/src/NovaCache/Hash.hs --- a/src/NovaCache/Hash.hs +++ b/src/NovaCache/Hash.hs @@ -7,12 +7,17 @@ ( NixHash (..), hashBytes, hashFile, + HashContext, + hashInit, + hashUpdate, + hashFinalize, formatNixHash, parseNixHash, ) where import Crypto.Hash (Digest, SHA256, hash) +import qualified Crypto.Hash as CH import Data.ByteArray (convert) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -40,11 +45,31 @@ hashFile :: FilePath -> IO NixHash hashFile path = hashBytes <$> BS.readFile path --- | Format a 'NixHash' as @sha256:\@. +-- | An in-progress SHA-256 computation. Pure - crypton contexts are +-- persistent values - so a consumer can fold 'hashUpdate' over chunks +-- as they stream (a download, 'NovaCache.NAR.withNarSource') and never +-- hold the whole input. +newtype HashContext = HashContext (CH.Context SHA256) + +-- | The empty hash computation. +hashInit :: HashContext +hashInit = HashContext CH.hashInit + +-- | Absorb one chunk. +hashUpdate :: HashContext -> ByteString -> HashContext +hashUpdate (HashContext ctx) chunk = HashContext (CH.hashUpdate ctx chunk) + +-- | Close the computation. @'hashFinalize' . foldl' 'hashUpdate' +-- 'hashInit'@ over any chunking of the input equals 'hashBytes' of the +-- whole. +hashFinalize :: HashContext -> NixHash +hashFinalize (HashContext ctx) = NixHash (convert (CH.hashFinalize ctx)) + +-- | Format a 't:NixHash' as @sha256:\@. formatNixHash :: NixHash -> Text formatNixHash (NixHash raw) = sha256Prefix <> Base32.encode raw --- | Parse a @sha256:\@ string back to a 'NixHash'. +-- | Parse a @sha256:\@ string back to a 't:NixHash'. -- -- Validates both the prefix and the decoded length. parseNixHash :: Text -> Either String NixHash diff --git a/src/NovaCache/NAR.hs b/src/NovaCache/NAR.hs --- a/src/NovaCache/NAR.hs +++ b/src/NovaCache/NAR.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | NAR (Nix ARchive) binary format serialization and deserialization. -- -- NAR is a deterministic archive format used by Nix. All strings are @@ -11,28 +13,61 @@ -- directory ::= (entry)* -- entry ::= "entry" "(" "name" STRING "node" node ")" -- @ +-- +-- Entry names and symlink targets are raw byte strings: the format +-- imposes no text encoding on them, and upstream carries them verbatim. +-- +-- Parsing is the whole-input instantiation of the incremental machine +-- in "NovaCache.NAR.Stream", and serialisation draws on that module's +-- wire vocabulary - the grammar exists once. To serialise a tree +-- without holding file contents in memory, see 'withNarSource'. module NovaCache.NAR ( NarEntry (..), serialise, deserialise, + isWindowsHazardName, narHash, serialiseFromPath, + serialiseFromPathWith, + withNarSource, + CaseHack (..), + defaultCaseHack, + caseHackSuffix, ) where -import Data.Bits (shiftL, (.&.), (.|.)) +import Control.Exception (bracketOnError, finally) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BL +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (sort, sortBy) import Data.Ord (comparing) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE import Data.Word (Word64) import qualified NovaCache.Hash as Hash -import System.Directory +import NovaCache.NAR.Stream + ( NarEvent (..), + NarStep (..), + isWindowsHazardName, + narPad, + narPadOf, + narStreamBounded, + tokContents, + tokDirectory, + tokEntry, + tokExecutable, + tokLParen, + tokMagic, + tokName, + tokNode, + tokRParen, + tokRegular, + tokSymlink, + tokTarget, + tokType, + ) +import System.Directory.OsPath ( doesDirectoryExist, doesFileExist, executable, @@ -41,7 +76,17 @@ listDirectory, pathIsSymbolicLink, ) -import System.FilePath (()) +import qualified System.Info +import System.OsPath (OsPath, decodeFS, encodeFS, ()) +import qualified System.OsPath as OP +#ifdef mingw32_HOST_OS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.IO (Handle, IOMode (ReadMode), hClose, hFileSize, openBinaryFile) +#else +import qualified Data.ByteString.Char8 as BS8 +import System.IO (Handle, IOMode (ReadMode), hClose, hFileSize, latin1, openBinaryFile) +#endif -- --------------------------------------------------------------------------- -- Types @@ -51,44 +96,17 @@ data NarEntry = -- | Regular file: executable flag and contents. NarRegular !Bool !ByteString - | -- | Symbolic link: target path. - NarSymlink !Text - | -- | Directory: list of (name, entry) pairs. Names must be unique; the - -- serializer sorts them and 'deserialise' rejects duplicate or + | -- | Symbolic link: target path, as the raw bytes the archive + -- carries. + NarSymlink !ByteString + | -- | Directory: list of (name, entry) pairs. Names are the raw + -- bytes the archive carries; they must be unique, the serializer + -- sorts them bytewise, and 'deserialise' rejects duplicate or -- out-of-order names. - NarDirectory ![(Text, NarEntry)] + NarDirectory ![(ByteString, NarEntry)] deriving (Eq, Show) -- --------------------------------------------------------------------------- --- Wire tokens (named constants, no magic strings) --- --------------------------------------------------------------------------- - -tokMagic, tokLParen, tokRParen, tokType :: ByteString -tokMagic = "nix-archive-1" -tokLParen = "(" -tokRParen = ")" -tokType = "type" - -tokRegular, tokDirectory, tokSymlink :: ByteString -tokRegular = "regular" -tokDirectory = "directory" -tokSymlink = "symlink" - -tokContents, tokTarget, tokExecutable :: ByteString -tokContents = "contents" -tokTarget = "target" -tokExecutable = "executable" - -tokEntry, tokName, tokNode :: ByteString -tokEntry = "entry" -tokName = "name" -tokNode = "node" - --- | Alignment boundary for NAR wire strings. -narAlignment :: Int -narAlignment = 8 - --- --------------------------------------------------------------------------- -- Serialization (pure Builder pipeline) -- --------------------------------------------------------------------------- @@ -115,7 +133,7 @@ <> narStr tokType <> narStr tokSymlink <> narStr tokTarget - <> narStr (TE.encodeUtf8 target) + <> narStr target <> narStr tokRParen buildNode (NarDirectory entries) = narStr tokLParen @@ -130,12 +148,12 @@ execFlag False = mempty -- | Build a single directory entry: @"entry" "(" "name" \ "node" \ ")"@. -buildDirEntry :: (Text, NarEntry) -> B.Builder +buildDirEntry :: (ByteString, NarEntry) -> B.Builder buildDirEntry (entryName, entry) = narStr tokEntry <> narStr tokLParen <> narStr tokName - <> narStr (TE.encodeUtf8 entryName) + <> narStr entryName <> narStr tokNode <> buildNode entry <> narStr tokRParen @@ -150,179 +168,76 @@ len = BS.length bs padLen = narPad len --- | Compute padding to reach the next 8-byte boundary. -narPad :: Int -> Int -narPad len = - let remainder = len .&. (narAlignment - 1) - in if remainder == 0 then 0 else narAlignment - remainder - -- --------------------------------------------------------------------------- --- Deserialization (pure, cursor-passing parser) +-- Deserialization (the streaming machine, driven over the whole input) -- --------------------------------------------------------------------------- --- | Parser state: remaining bytes after consuming a token. -type NarParser a = ByteString -> Either String (a, ByteString) - -- | Deserialise NAR binary format to a 'NarEntry'. +-- +-- Drives "NovaCache.NAR.Stream" over the whole input, folding its +-- events back into a tree. The structural-string bound is the input's +-- own length - a wire string cannot outgrow its container - so this +-- accepts exactly what the dedicated whole-input parser accepted, +-- with no extra ceiling. Contents events are slices of the input, so +-- single-chunk files rebuild by sharing, not copying. deserialise :: ByteString -> Either String NarEntry -deserialise bs = do - (magic, rest) <- readStr bs - expect tokMagic magic - (entry, rest2) <- parseNode rest - if BS.null rest2 - then Right entry - else Left "trailing bytes after NAR root node" - --- | Parse a single NAR node. -parseNode :: NarParser NarEntry -parseNode bs = do - (lp, rest) <- readStr bs - expect tokLParen lp - (ty, afterTy) <- readStr rest - expect tokType ty - (kind, afterKind) <- readStr afterTy - dispatch kind afterKind - where - dispatch kind rest - | kind == tokRegular = parseRegular rest - | kind == tokSymlink = parseSymlink rest - | kind == tokDirectory = parseDirectory rest - | otherwise = Left ("unknown NAR entry type: " ++ show kind) - --- | Parse a regular file node (optional executable flag + contents). -parseRegular :: NarParser NarEntry -parseRegular bs = do - (tok, afterTok) <- readStr bs - regular tok afterTok - where - regular tok rest - | tok == tokExecutable = do - (_, afterEmpty) <- readStr rest - (cTok, afterCTok) <- readStr afterEmpty - expect tokContents cTok - (contents, afterContents) <- readStr afterCTok - (rp, final) <- readStr afterContents - expect tokRParen rp - pure (NarRegular True contents, final) - | tok == tokContents = do - (contents, afterContents) <- readStr rest - (rp, final) <- readStr afterContents - expect tokRParen rp - pure (NarRegular False contents, final) - | otherwise = - -- 'contents' is mandatory (even an empty file serialises with it), so - -- a regular node without it is malformed - reject, matching Nix. - Left ("expected 'executable' or 'contents' in regular, got: " ++ show tok) - --- | Parse a symlink node. -parseSymlink :: NarParser NarEntry -parseSymlink bs = do - (tgt, afterTgt) <- readStr bs - expect tokTarget tgt - (targetPath, afterPath) <- readStr afterTgt - (rp, final) <- readStr afterPath - expect tokRParen rp - symTarget <- decodeUtf8Safe targetPath - pure (NarSymlink symTarget, final) - --- | Parse a directory node (zero or more child entries). -parseDirectory :: NarParser NarEntry -parseDirectory = go Nothing [] +deserialise input = drive True (narStreamBounded (fromIntegral (BS.length input))) [] Nothing where - go !prev !acc bs = do - (tok, afterTok) <- readStr bs - if tok == tokRParen - then pure (NarDirectory (reverse acc), afterTok) - else do - expect tokEntry tok - (lp, afterLp) <- readStr afterTok - expect tokLParen lp - (nTok, afterNTok) <- readStr afterLp - expect tokName nTok - (entryName, afterName) <- readStr afterNTok - (nodeTok, afterNodeTok) <- readStr afterName - expect tokNode nodeTok - (entry, afterEntry) <- parseNode afterNodeTok - (rp, afterRp) <- readStr afterEntry - expect tokRParen rp - decodedName <- decodeUtf8Safe entryName - _ <- checkName prev decodedName - go (Just decodedName) ((decodedName, entry) : acc) afterRp - -- NAR directory entries must have safe names in strictly increasing - -- (sorted, unique) order. Enforcing this rejects malformed or hostile - -- archives, keeps @serialise . deserialise@ an identity, and forecloses the - -- path-traversal surface for any future NAR-extraction consumer. - checkName prev name - | T.null name = Left "empty NAR directory entry name" - | name == "." || name == ".." || T.any (\c -> c == '/' || c == '\0') name = - Left ("unsafe NAR directory entry name: " ++ T.unpack name) - | Just p <- prev, - name <= p = - Left ("NAR directory entries not strictly increasing: " ++ T.unpack name) - | otherwise = Right () - --- --------------------------------------------------------------------------- --- Wire primitives --- --------------------------------------------------------------------------- + drive !firstFeed step !stack !root = case step of + NarFail err -> Left err + NarDone -> case (stack, root) of + ([], Just entry) -> Right entry + _ -> Left malformedEventStream + NarYield event continue -> do + (stackNext, rootNext) <- applyEvent event stack root + drive firstFeed continue stackNext rootNext + NarAwait continue + | firstFeed -> drive False (continue input) stack root + | otherwise -> drive False (continue BS.empty) stack root --- | Read a length-prefixed, 8-byte-padded string from the buffer. -readStr :: NarParser ByteString -readStr bs - | BS.length bs < wordSize = - Left "unexpected end of NAR: need 8 bytes for string length" - -- Compare the Word64 length to the remaining bytes BEFORE narrowing it to - -- Int: a hostile length above maxBound::Int would otherwise wrap negative - -- and slip past the totalLen check below. - | len > fromIntegral (BS.length payload) = - Left - ( "unexpected end of NAR: string length " - ++ show len - ++ " exceeds remaining " - ++ show (BS.length payload) - ) - | totalLen > BS.length payload = - Left - ( "unexpected end of NAR: padded string length " - ++ show totalLen - ++ " exceeds remaining " - ++ show (BS.length payload) - ) - | otherwise = - Right (BS.take (fromIntegral len) payload, BS.drop totalLen payload) - where - len = readWord64LE bs - payload = BS.drop wordSize bs - totalLen = fromIntegral len + narPad (fromIntegral len) +-- | One frame of the event fold in 'deserialise': the construct +-- enclosing the node currently being built. +data BuildFrame + = -- | A regular file: executable flag and reversed contents slices. + FrameRegular !Bool ![ByteString] + | -- | A directory: completed children, reversed. + FrameDirectory ![(ByteString, NarEntry)] + | -- | A directory entry: its name, then its node once complete. + FrameEntry !ByteString !(Maybe NarEntry) --- | Read a little-endian 'Word64' from the first 8 bytes. -readWord64LE :: ByteString -> Word64 -readWord64LE bs = - byte 0 - .|. (byte 1 `shiftL` 8) - .|. (byte 2 `shiftL` 16) - .|. (byte 3 `shiftL` 24) - .|. (byte 4 `shiftL` 32) - .|. (byte 5 `shiftL` 40) - .|. (byte 6 `shiftL` 48) - .|. (byte 7 `shiftL` 56) +-- | Apply one event to the frame stack. The machine already validated +-- the grammar, so the mismatch arms are unreachable through +-- 'narStreamBounded'; they fail closed rather than building partially. +applyEvent :: NarEvent -> [BuildFrame] -> Maybe NarEntry -> Either String ([BuildFrame], Maybe NarEntry) +applyEvent event stack root = case (event, stack) of + (EventRegularBegin isExec _declaredSize, _) -> + Right (FrameRegular isExec [] : stack, root) + (EventRegularChunk slice, FrameRegular isExec chunks : rest) -> + Right (FrameRegular isExec (slice : chunks) : rest, root) + (EventRegularEnd, FrameRegular isExec chunks : rest) -> + complete (NarRegular isExec (BS.concat (reverse chunks))) rest + (EventSymlink target, _) -> + complete (NarSymlink target) stack + (EventDirectoryBegin, _) -> + Right (FrameDirectory [] : stack, root) + (EventEntryBegin entryName, _) -> + Right (FrameEntry entryName Nothing : stack, root) + (EventEntryEnd, FrameEntry entryName (Just entry) : FrameDirectory entriesRev : rest) -> + Right (FrameDirectory ((entryName, entry) : entriesRev) : rest, root) + (EventDirectoryEnd, FrameDirectory entriesRev : rest) -> + complete (NarDirectory (reverse entriesRev)) rest + _ -> Left malformedEventStream where - byte i = fromIntegral (BS.index bs i) - --- | Size of a Word64 in bytes. -wordSize :: Int -wordSize = 8 - --- | Assert that a token matches the expected value. -expect :: ByteString -> ByteString -> Either String () -expect expected got - | got == expected = Right () - | otherwise = Left ("expected " ++ show expected ++ ", got " ++ show got) + complete entry remaining = case remaining of + [] -> case root of + Nothing -> Right ([], Just entry) + Just _ -> Left malformedEventStream + FrameEntry entryName Nothing : rest -> + Right (FrameEntry entryName (Just entry) : rest, root) + _ -> Left malformedEventStream --- | Decode a UTF-8 bytestring, converting decode failures to parse errors. -decodeUtf8Safe :: ByteString -> Either String Text -decodeUtf8Safe bs = case TE.decodeUtf8' bs of - Right txt -> Right txt - Left err -> Left ("invalid UTF-8 in NAR: " ++ show err) +malformedEventStream :: String +malformedEventStream = "malformed NAR event stream" -- --------------------------------------------------------------------------- -- Hashing @@ -336,51 +251,371 @@ -- Filesystem to NarEntry (IO boundary) -- --------------------------------------------------------------------------- --- | Walk a filesystem path and build a 'NarEntry'. +-- | Whether the serialiser strips upstream's case-hack suffix from +-- on-disk names. A case-folding store filesystem cannot hold two +-- sibling names differing only by case, so an extractor there +-- materializes the second with a reversible suffix; serialisation must +-- strip it for the tree to reproduce its original NAR bytes. +data CaseHack = CaseHackEnabled | CaseHackDisabled + deriving (Eq, Show) + +-- | The platform default 'serialiseFromPath' uses: enabled where the +-- store filesystem folds case (Windows NTFS, default macOS APFS), +-- disabled elsewhere - a Linux file legitimately named with the suffix +-- must serialise verbatim. Matches upstream's use-case-hack defaults. +defaultCaseHack :: CaseHack +defaultCaseHack = case System.Info.os of + "mingw32" -> CaseHackEnabled + "darwin" -> CaseHackEnabled + _ -> CaseHackDisabled + +-- | Upstream's reversible collision suffix (its @caseHackSuffix@): an +-- extractor appends @~nix~case~hack~@ to a sibling whose name +-- case-folds onto an earlier one, and serialisation strips from the +-- suffix onward to recover the NAR name. Bytes, matching the entry +-- names it marks. +caseHackSuffix :: ByteString +caseHackSuffix = "~nix~case~hack~" + +-- | Walk a filesystem path and build a 'NarEntry' under +-- 'defaultCaseHack'. -- --- This is the sole IO function in the module. It classifies each path --- as symlink, directory, or regular file, then delegates to pure --- constructors. +-- This is the module's IO boundary: the platform-native walk +-- classifies each path as symlink, directory, or regular file and +-- delegates to pure constructors. serialiseFromPath :: FilePath -> IO NarEntry -serialiseFromPath path = do +serialiseFromPath = serialiseFromPathWith defaultCaseHack + +-- | 'serialiseFromPath' with the case-hack mode explicit, for callers +-- and tests that need behavior independent of the host platform. +serialiseFromPathWith :: CaseHack -> FilePath -> IO NarEntry +serialiseFromPathWith mode path = walkPath mode =<< encodeFS path + +-- | Walk one platform-native path. The walk runs on 'OsPath' so child +-- names reach the archive byte-true ('osPathBytes'); only the root +-- enters as 'FilePath', and the root's own name never appears in a +-- NAR. +walkPath :: CaseHack -> OsPath -> IO NarEntry +walkPath mode path = do isSym <- pathIsSymbolicLink path if isSym - then NarSymlink . T.pack <$> getSymbolicLinkTarget path + then NarSymlink <$> (osPathBytes =<< getSymbolicLinkTarget path) else do isDir <- doesDirectoryExist path if isDir - then buildDirectory path + then buildDirectory mode path else buildRegularFile path -- | Build a directory entry by recursively walking children. -buildDirectory :: FilePath -> IO NarEntry -buildDirectory path = do +buildDirectory :: CaseHack -> OsPath -> IO NarEntry +buildDirectory mode path = do + resolved <- resolvedDirEntries mode path + NarDirectory <$> traverse walkChild resolved + where + walkChild (entryName, diskName) = do + entry <- walkPath mode (path diskName) + pure (entryName, entry) + +-- | A directory's children as (NAR name, on-disk name) pairs under the +-- case-hack mode. Under 'CaseHackEnabled', each on-disk name is +-- stripped of the case-hack suffix and entries are ordered by the +-- STRIPPED name (the NAR name); two on-disk names stripping to the +-- same entry name fail loudly, as upstream's serialiser does - +-- continuing would emit an archive with duplicate entries no parser +-- accepts. +resolvedDirEntries :: CaseHack -> OsPath -> IO [(ByteString, OsPath)] +resolvedDirEntries mode path = do names <- sort <$> listDirectory path - entries <- traverse walkChild names - pure (NarDirectory entries) + named <- traverse withNameBytes names + case unhackedDirNames mode named of + Left (collidedA, collidedB) -> do + pathA <- decodeFS (path collidedA) + pathB <- decodeFS (path collidedB) + fail + ( "serialiseFromPath: file name collision between '" + ++ pathA + ++ "' and '" + ++ pathB + ++ "' after case-hack stripping" + ) + Right resolved -> pure resolved where - walkChild name = do - entry <- serialiseFromPath (path name) - pure (T.pack name, entry) + withNameBytes diskName = do + nameBytes <- osPathBytes diskName + pure (nameBytes, diskName) +-- | Resolve (NAR name, on-disk name) pairs for a directory's children. +-- Under 'CaseHackDisabled' pairs pass through verbatim (serialisation +-- sorts at emit). Under 'CaseHackEnabled' the case-hack suffix is +-- stripped from each NAR name and pairs are re-sorted by the stripped +-- bytes; @Left@ carries the first pair of disk names whose stripped +-- entry names coincide. +unhackedDirNames :: CaseHack -> [(ByteString, OsPath)] -> Either (OsPath, OsPath) [(ByteString, OsPath)] +unhackedDirNames CaseHackDisabled named = Right named +unhackedDirNames CaseHackEnabled named = + detectCollision (sortBy (comparing fst) (map resolve named)) + where + resolve (nameBytes, diskName) = + let (unhacked, rest) = BS.breakSubstring caseHackSuffix nameBytes + in if BS.null rest + then (nameBytes, diskName) + else (unhacked, diskName) + detectCollision resolved = + case [ (diskA, diskB) + | ((entryA, diskA), (entryB, diskB)) <- zip resolved (drop 1 resolved), + entryA == entryB + ] of + ((diskA, diskB) : _) -> Left (diskA, diskB) + [] -> Right resolved + -- | Build a regular file entry, checking the executable bit. -buildRegularFile :: FilePath -> IO NarEntry +buildRegularFile :: OsPath -> IO NarEntry buildRegularFile path = do isFile <- doesFileExist path if isFile then do - contents <- BS.readFile path + contents <- readFileBytes path isExec <- checkExecutable path pure (NarRegular isExec contents) - else - -- Not a symlink, directory, or regular file: a special file (FIFO, - -- socket, device) or a path that vanished mid-walk. Fail loudly rather - -- than fabricating an empty regular (which would silently change the NAR - -- and its hash) - matching Nix, which aborts on unsupported types. - fail ("serialiseFromPath: not a regular file (special or vanished): " ++ path) + else specialFileFailure path +-- | The shared refusal for a path that is not a symlink, directory, or +-- regular file: a special file (FIFO, socket, device) or a path that +-- vanished mid-walk. Fail loudly rather than fabricating an empty +-- regular (which would silently change the NAR and its hash) - +-- matching Nix, which aborts on unsupported types. +specialFileFailure :: OsPath -> IO a +specialFileFailure path = do + shownPath <- decodeFS path + fail ("serialiseFromPath: not a regular file (special or vanished): " ++ shownPath) + -- | Check whether a file has the executable permission set. --- Uses 'System.Directory.getPermissions' which is cross-platform: +-- Uses 'System.Directory.OsPath.getPermissions' which is cross-platform: -- checks the user-execute bit on Unix, file extension on Windows. -checkExecutable :: FilePath -> IO Bool +checkExecutable :: OsPath -> IO Bool checkExecutable path = executable <$> getPermissions path + +-- | Read a file's contents by platform-native path. The byte-string +-- file API still takes 'FilePath', so the path bridges through +-- 'decodeFS' - interop with unmigrated APIs is that function's +-- documented purpose, and its contract is the exact round-trip: the +-- reopened path names the same file even when the name has no text +-- decoding. +readFileBytes :: OsPath -> IO ByteString +readFileBytes path = BS.readFile =<< decodeFS path + +-- | The NAR name for one platform-native path component: on POSIX the +-- raw bytes the filesystem reports, on Windows the UTF-8 encoding of +-- the UTF-16 name - each platform's spelling of the upstream rule that +-- a NAR carries names as byte strings. Symlink targets take the same +-- path. The one refusal is a Windows name holding an unpaired +-- surrogate: it has no UTF-8 form and upstream defines no byte +-- spelling for it, so failing loudly beats inventing a name (the same +-- policy 'buildRegularFile' applies to special files). +#ifdef mingw32_HOST_OS +osPathBytes :: OsPath -> IO ByteString +osPathBytes path = case OP.decodeUtf path of + Just decoded -> pure (TE.encodeUtf8 (T.pack decoded)) + Nothing -> + fail ("serialiseFromPath: name has no UTF-8 form (unpaired surrogate): " ++ show path) +#else +osPathBytes :: OsPath -> IO ByteString +osPathBytes path = case OP.decodeWith latin1 latin1 path of + Right decoded -> pure (BS8.pack decoded) + Left err -> + -- Unreachable: latin1 decoding is total - byte N reads as code + -- point N, and Char8 re-truncation above inverts it exactly - but + -- surfacing the impossible beats hiding it. + fail ("serialiseFromPath: undecodable name: " ++ show err) +#endif + +-- --------------------------------------------------------------------------- +-- Streaming filesystem serialisation (IO boundary) +-- --------------------------------------------------------------------------- + +-- | Chunk size for streaming file contents: large enough to amortize +-- per-chunk handling in consumers, small enough that one pull's memory +-- and latency stay flat. +narSourceChunkBytes :: Int +narSourceChunkBytes = 131072 + +-- | One planned piece of the archive: structural bytes rendered up +-- front, or a regular file whose length prefix, contents, and padding +-- stream at pull time. +data NarSegment + = SegmentBytes !ByteString + | SegmentFile !OsPath + +-- | What the puller is doing between calls. The 'IORef' holding this +-- is the module's one piece of mutable state - the same deliberate, +-- documented boundary as the streaming write in "NovaCache.Store". +data SourceState + = SourceSegments ![NarSegment] + | -- | Mid-file: the open handle, its decoded path for error text, + -- the bytes still owed, the padding after them, and the remaining + -- segments. + SourceFile !Handle !FilePath !Word64 !Int ![NarSegment] + | SourceDrained + +-- | Serialise a filesystem tree as a pull source of NAR chunks, +-- without ever holding a file's contents in memory: the tree's +-- structure is planned up front (names, kinds, symlink targets - +-- never contents), then each pull returns the next chunk, reading +-- regular files 128 KiB at a time. The empty chunk +-- means end of input and repeats on further pulls - the convention +-- 'NovaCache.Store.writeNarStreaming' consumes, so the two ends +-- compose directly. Pair with "NovaCache.Hash"'s incremental hashing +-- to compute the NAR hash in the same pass. +-- +-- The walk applies the same case-hack resolution and loud failures as +-- 'serialiseFromPathWith', and emits entries in the same bytewise +-- order, so the pulled bytes equal @'serialise' \@ exactly. A +-- file's size is read when its streaming starts and exactly that many +-- bytes are emitted, as upstream's dump does; a file that shrinks +-- mid-stream fails loudly rather than emitting a torn archive. Any +-- file handle still open when the continuation exits is closed. +withNarSource :: CaseHack -> FilePath -> (IO ByteString -> IO a) -> IO a +withNarSource mode root consume = do + rootPath <- encodeFS root + segments <- planSegments mode rootPath + stateRef <- newIORef (SourceSegments segments) + consume (pullChunk stateRef) `finally` closeCurrent stateRef + where + closeCurrent stateRef = do + state <- readIORef stateRef + case state of + SourceFile handle _ _ _ _ -> hClose handle + _ -> pure () + +-- | Produce the next chunk of the planned archive. +pullChunk :: IORef SourceState -> IO ByteString +pullChunk stateRef = advance =<< readIORef stateRef + where + advance (SourceSegments []) = do + writeIORef stateRef SourceDrained + pure BS.empty + advance (SourceSegments (SegmentBytes bytes : rest)) = do + writeIORef stateRef (SourceSegments rest) + pure bytes + advance (SourceSegments (SegmentFile path : rest)) = do + shownPath <- decodeFS path + -- hFileSize can throw after a successful open (the path swapped + -- for a FIFO between plan and pull); until the state ref records + -- the handle, closeCurrent cannot see it, so ownership transfers + -- under bracketOnError - the same discipline as the shrink path + -- below. + bracketOnError (openBinaryFile shownPath ReadMode) hClose $ \handle -> do + size <- hFileSize handle + let owed = fromIntegral size :: Word64 + writeIORef stateRef (SourceFile handle shownPath owed (narPadOf owed) rest) + pure (BL.toStrict (B.toLazyByteString (B.word64LE owed))) + advance (SourceFile handle _ 0 padLen rest) = do + hClose handle + writeIORef stateRef (SourceSegments rest) + if padLen == 0 + then pullChunk stateRef + else pure (BS.replicate padLen 0) + advance (SourceFile handle shownPath owed padLen rest) = do + chunk <- BS.hGet handle (fromIntegral (min owed (fromIntegral narSourceChunkBytes))) + if BS.null chunk + then do + hClose handle + writeIORef stateRef SourceDrained + ioError (userError ("withNarSource: " ++ shownPath ++ " shrank while streaming")) + else do + writeIORef + stateRef + (SourceFile handle shownPath (owed - fromIntegral (BS.length chunk)) padLen rest) + pure chunk + advance SourceDrained = pure BS.empty + +-- | Plan the archive: every structural byte rendered, file contents +-- deferred as 'SegmentFile's. Holds structure only - O(entries), +-- never contents. +planSegments :: CaseHack -> OsPath -> IO [NarSegment] +planSegments mode path = do + pieces <- planNode mode path + pure (coalesce (PieceBytes (narStr tokMagic) : pieces)) + +-- | Plan pieces before coalescing: structural builders, or a deferred +-- regular file. +data PlanPiece + = PieceBytes !B.Builder + | PieceFile !OsPath + +-- | Merge adjacent structural runs and render each strict, so a pull +-- returns a directory's worth of tokens in one chunk instead of one +-- token at a time. +coalesce :: [PlanPiece] -> [NarSegment] +coalesce = go mempty + where + go !pending [] = flushOnto pending [] + go !pending (PieceBytes builder : rest) = go (pending <> builder) rest + go !pending (PieceFile path : rest) = + flushOnto pending (SegmentFile path : go mempty rest) + flushOnto pending segments = + let bytes = BL.toStrict (B.toLazyByteString pending) + in if BS.null bytes then segments else SegmentBytes bytes : segments + +-- | Plan one node, mirroring 'walkPath'. +planNode :: CaseHack -> OsPath -> IO [PlanPiece] +planNode mode path = do + isSym <- pathIsSymbolicLink path + if isSym + then do + target <- osPathBytes =<< getSymbolicLinkTarget path + pure [PieceBytes (buildNode (NarSymlink target))] + else do + isDir <- doesDirectoryExist path + if isDir + then planDirectory mode path + else planRegular path + +-- | Plan a directory. Children are ordered by their NAR-name bytes - +-- the same order 'buildNode' emits - not by on-disk order, which can +-- differ on Windows where 'OsPath' sorts by UTF-16 units. +planDirectory :: CaseHack -> OsPath -> IO [PlanPiece] +planDirectory mode path = do + resolved <- resolvedDirEntries mode path + children <- traverse planChild (sortBy (comparing fst) resolved) + pure + ( PieceBytes (narStr tokLParen <> narStr tokType <> narStr tokDirectory) + : concat children + ++ [PieceBytes (narStr tokRParen)] + ) + where + planChild (entryName, diskName) = do + node <- planNode mode (path diskName) + pure + ( PieceBytes + ( narStr tokEntry + <> narStr tokLParen + <> narStr tokName + <> narStr entryName + <> narStr tokNode + ) + : node + ++ [PieceBytes (narStr tokRParen)] + ) + +-- | Plan a regular file: the node's structure now, its contents at +-- pull time. The pieces mirror 'buildNode' on 'NarRegular' exactly, +-- with the contents wire string (length, bytes, padding) deferred. +planRegular :: OsPath -> IO [PlanPiece] +planRegular path = do + isFile <- doesFileExist path + if isFile + then do + isExec <- checkExecutable path + pure + [ PieceBytes + ( narStr tokLParen + <> narStr tokType + <> narStr tokRegular + <> execFlag isExec + <> narStr tokContents + ), + PieceFile path, + PieceBytes (narStr tokRParen) + ] + else specialFileFailure path diff --git a/src/NovaCache/NAR/Stream.hs b/src/NovaCache/NAR/Stream.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/NAR/Stream.hs @@ -0,0 +1,418 @@ +-- | Incremental NAR parsing: a pure, chunk-fed event machine. +-- +-- "NovaCache.NAR" parses a NAR held whole in memory; consumers realize +-- entire archives to walk them, and nova-nix's substituter documents +-- the resident-set spike that costs on large paths. This module parses +-- the same grammar incrementally: feed chunks as they arrive - from a +-- download, a decompressor - and act on events as they complete. +-- Regular-file contents pass through as slices of the fed chunks, so +-- memory is bounded by the largest structural wire string +-- ('maxWireStringBytes'), never by archive or file size. +-- +-- The grammar lives here once: 'NovaCache.NAR.deserialise' is the +-- whole-input instantiation of this machine, and the serialiser draws +-- its wire vocabulary from the exports below, so the two directions +-- cannot drift apart. +module NovaCache.NAR.Stream + ( -- * Events + NarEvent (..), + + -- * The machine + NarStep (..), + narStream, + narStreamBounded, + maxWireStringBytes, + + -- * Entry-name safety + checkEntryName, + isWindowsHazardName, + + -- * Wire vocabulary (shared with the serialiser in "NovaCache.NAR") + tokMagic, + tokLParen, + tokRParen, + tokType, + tokRegular, + tokDirectory, + tokSymlink, + tokContents, + tokTarget, + tokExecutable, + tokEntry, + tokName, + tokNode, + narAlignment, + narPad, + narPadOf, + ) +where + +import Data.Bits (shiftL, (.&.), (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Word (Word64) +import NovaCache.SafeName (hasTrailingDotOrSpace, isReservedDeviceName) + +-- --------------------------------------------------------------------------- +-- Wire vocabulary +-- --------------------------------------------------------------------------- + +-- | Archive framing: the magic header, node delimiters, and the type +-- keyword. +tokMagic, tokLParen, tokRParen, tokType :: ByteString +tokMagic = "nix-archive-1" +tokLParen = "(" +tokRParen = ")" +tokType = "type" + +-- | The three node kinds. +tokRegular, tokDirectory, tokSymlink :: ByteString +tokRegular = "regular" +tokDirectory = "directory" +tokSymlink = "symlink" + +-- | Regular-file and symlink field keywords. +tokContents, tokTarget, tokExecutable :: ByteString +tokContents = "contents" +tokTarget = "target" +tokExecutable = "executable" + +-- | Directory-entry keywords. +tokEntry, tokName, tokNode :: ByteString +tokEntry = "entry" +tokName = "name" +tokNode = "node" + +-- | Alignment boundary for NAR wire strings. +narAlignment :: Int +narAlignment = 8 + +-- | Compute padding to reach the next 8-byte boundary. +narPad :: Int -> Int +narPad len = + let remainder = len .&. (narAlignment - 1) + in if remainder == 0 then 0 else narAlignment - remainder + +-- | 'narPad' over the wire's own length type, for sizes that may not +-- fit 'Int'. The result is a padding count, so it always does. +narPadOf :: Word64 -> Int +narPadOf len = + let remainder = len .&. fromIntegral (narAlignment - 1) + in if remainder == 0 then 0 else narAlignment - fromIntegral remainder + +-- | Size of the length prefix preceding every wire string. +lengthPrefixBytes :: Int +lengthPrefixBytes = 8 + +-- --------------------------------------------------------------------------- +-- Events +-- --------------------------------------------------------------------------- + +-- | One structural step of an archive. A node unfolds as either +-- +-- @'EventRegularBegin' ('EventRegularChunk'*) 'EventRegularEnd'@, +-- an 'EventSymlink', or +-- @'EventDirectoryBegin' entry* 'EventDirectoryEnd'@ where each entry +-- is @'EventEntryBegin' node 'EventEntryEnd'@. +data NarEvent + = -- | A regular file opens: executable flag and its declared + -- contents size, known up front from the wire length prefix. + EventRegularBegin !Bool !Word64 + | -- | One slice of regular-file contents, in order. Slices are + -- substrings of the fed chunks (no copying); their lengths sum to + -- the declared size. + EventRegularChunk !ByteString + | -- | The regular file's contents and padding are fully consumed and + -- its node is closed. + EventRegularEnd + | -- | A complete symlink node: the target, as the raw bytes the + -- archive carries. + EventSymlink !ByteString + | EventDirectoryBegin + | -- | An entry opens under the innermost open directory. The name + -- has already passed 'checkEntryName', order included. + EventEntryBegin !ByteString + | EventEntryEnd + | EventDirectoryEnd + deriving (Eq, Show) + +-- | The machine's outward face. Drive it by pattern matching: hand +-- 'NarAwait' the next chunk (the empty string means end of input, the +-- same convention as 'NovaCache.Store.writeNarStreaming' consumes), and +-- read events off 'NarYield' as they complete. 'NarDone' confirms the +-- archive ended exactly at the root node's close; anything else that +-- can go wrong is a 'NarFail'. +data NarStep + = NarAwait !(ByteString -> NarStep) + | -- | The continuation is deliberately lazy: yielding is what hands + -- control back to the consumer, and a strict field would force + -- each step's successor at construction, materializing the whole + -- fed chunk's event chain before the consumer acts on the first + -- event. Do not add a bang. + NarYield !NarEvent NarStep + | NarDone + | NarFail !String + +-- | The bound 'narStream' places on structural wire strings - tokens, +-- entry names, symlink targets; never file contents, which stream +-- through unaccumulated. Real names fit a filesystem's 255-byte +-- component limit and targets its path limit, so 64 KiB is generous; +-- without some bound a hostile length prefix could demand an +-- arbitrary-size allocation from one 8-byte read. +maxWireStringBytes :: Word64 +maxWireStringBytes = 65536 + +-- | The parser, positioned at the start of an archive, holding +-- 'maxWireStringBytes' over structural strings. +narStream :: NarStep +narStream = narStreamBounded maxWireStringBytes + +-- | The largest structural-string bound 'narStreamBounded' honors: +-- 'Int''s ceiling less alignment headroom, so a payload at the bound +-- still fits 'Int' together with its padding. +structuralBoundCeiling :: Word64 +structuralBoundCeiling = + fromIntegral (maxBound :: Int) - fromIntegral (narAlignment - 1) + +-- --------------------------------------------------------------------------- +-- Parser +-- --------------------------------------------------------------------------- + +-- | A parse state waiting for its share of the input: apply it to the +-- unconsumed bytes to proceed. +type Continue = ByteString -> NarStep + +-- | 'narStream' with the structural-string bound explicit. +-- 'NovaCache.NAR.deserialise' passes its whole input's length - a +-- string cannot outgrow its container, so the strict parser accepts +-- exactly what it always accepted - while streaming callers keep the +-- documented default. +narStreamBounded :: Word64 -> NarStep +narStreamBounded bound = + expectWire limited "archive magic" tokMagic (parseNode limited archiveEnd) BS.empty + where + -- Declared lengths are compared in Word64 and narrowed only below + -- the bound; 'wireString' then demands the narrowed length plus + -- its padding in Int, so the bound must sit far enough below Int's + -- ceiling that the padded sum cannot wrap. + limited = min bound structuralBoundCeiling + archiveEnd leftover + | BS.null leftover = NarAwait confirm + | otherwise = NarFail trailingBytes + confirm chunk + | BS.null chunk = NarDone + | otherwise = NarFail trailingBytes + trailingBytes = "trailing bytes after NAR root node" + +-- | Parse one node and continue. +parseNode :: Word64 -> Continue -> Continue +parseNode bound k = + expectWire bound "node opening" tokLParen + $ expectWire bound "type keyword" tokType + $ wireString bound "node type" dispatch + where + dispatch kind + | kind == tokRegular = parseRegular bound k + | kind == tokSymlink = parseSymlink bound k + | kind == tokDirectory = parseDirectory bound k + | otherwise = failWith ("unknown NAR entry type: " ++ show kind) + +-- | Parse a regular file node: optional executable flag, then contents +-- streamed through as chunk events. +parseRegular :: Word64 -> Continue -> Continue +parseRegular bound k = wireString bound "regular-node keyword" body + where + body tok + | tok == tokExecutable = + -- The format fixes the executable marker's value as the + -- empty string; upstream rejects a nonempty value. + wireString bound "executable marker" $ \marker -> + if BS.null marker + then expectWire bound "contents keyword" tokContents (contentsOf True) + else failWith ("executable marker must be empty, got: " ++ show marker) + | tok == tokContents = contentsOf False + | otherwise = + failWith ("expected 'executable' or 'contents' in regular, got: " ++ show tok) + contentsOf isExec = exactly lengthPrefixBytes "length of file contents" (withSize isExec) + withSize isExec lenBytes leftover = + let size = word64LE lenBytes + in NarYield + (EventRegularBegin isExec size) + (streamContents size (afterContents size) leftover) + afterContents size = + exactly (narPadOf size) "file contents padding" $ \padding -> + if BS.any (/= 0) padding + then failWith nonzeroPadding + else expectWire bound "node closing" tokRParen $ \leftover -> + NarYield EventRegularEnd (k leftover) + +-- | Yield contents slices until the declared size is consumed. Slices +-- are substrings of the fed chunks; nothing accumulates. +streamContents :: Word64 -> Continue -> Continue +streamContents remaining k leftover + | remaining == 0 = k leftover + | BS.null leftover = NarAwait feed + | otherwise = + let sliceLen = fromIntegral (min remaining (fromIntegral (BS.length leftover))) + (slice, rest) = BS.splitAt sliceLen leftover + in NarYield + (EventRegularChunk slice) + (streamContents (remaining - fromIntegral sliceLen) k rest) + where + feed chunk + | BS.null chunk = NarFail "unexpected end of NAR: file contents" + | otherwise = streamContents remaining k chunk + +-- | Parse a symlink node. The target is carried verbatim: upstream +-- imposes no text encoding on it. +parseSymlink :: Word64 -> Continue -> Continue +parseSymlink bound k = + expectWire bound "target keyword" tokTarget $ + wireString bound "symlink target" $ \target -> + expectWire bound "node closing" tokRParen $ \leftover -> + NarYield (EventSymlink target) (k leftover) + +-- | Parse a directory node: entries validated name by name as they +-- open, so a consumer can act on each entry before the next arrives. +parseDirectory :: Word64 -> Continue -> Continue +parseDirectory bound k leftover = + NarYield EventDirectoryBegin (entries Nothing leftover) + where + entries prev = wireString bound "directory token" (branch prev) + branch prev tok + | tok == tokRParen = NarYield EventDirectoryEnd . k + | tok == tokEntry = + expectWire bound "entry opening" tokLParen + $ expectWire bound "name keyword" tokName + $ wireString bound "entry name" (named prev) + | otherwise = failWith ("expected 'entry' or ')' in directory, got: " ++ show tok) + named prev entryName = case checkEntryName prev entryName of + Left err -> failWith err + Right () -> + NarYield (EventEntryBegin entryName) + . expectWire bound "node keyword" tokNode (parseNode bound (closeEntry entryName)) + closeEntry entryName = + expectWire bound "entry closing" tokRParen $ \leftover2 -> + NarYield EventEntryEnd (entries (Just entryName) leftover2) + +-- --------------------------------------------------------------------------- +-- Entry-name safety +-- --------------------------------------------------------------------------- + +-- | Reject a NAR directory entry name the grammar itself refuses, or +-- one out of order against its predecessor. The rejections are +-- exactly upstream's: no empty name, no @.@ or @..@, no @/@ or NUL, +-- and strictly increasing (sorted, unique) byte order - which rejects +-- malformed archives, keeps @serialise . deserialise@ an identity, +-- and forecloses the POSIX path-traversal surface. Names hazardous +-- only on Windows (device stems like @aux.c@, colons, backslashes, +-- trailing dots or spaces) are accepted here, as upstream's restore +-- accepts them on Unix and real caches serve them; rejecting them is +-- a materialization-boundary decision a store writer takes with +-- 'isWindowsHazardName' when the target filesystem needs it. +checkEntryName :: Maybe ByteString -> ByteString -> Either String () +checkEntryName prev name + | BS.null name = Left "empty NAR directory entry name" + | name == "." || name == ".." || BS8.any (\c -> c == '/' || c == '\0') name = + Left ("unsafe NAR directory entry name: " ++ show name) + | Just p <- prev, + name <= p = + Left ("NAR directory entries not strictly increasing: " ++ show name) + | otherwise = Right () + +-- | Does the name resolve, on a Windows filesystem, to something other +-- than an ordinary file of this exact spelling? Backslash is a +-- directory separator there, so @..\\out.exe@ traverses like a name +-- with @/@; a colon is a drive prefix (@C:evil@) or an NTFS alternate +-- data stream (@a:b@); a reserved device stem (@nul@, @aux.c@) opens +-- the device; and NTFS strips a trailing dot or space, silently +-- diverging the on-disk name from the NAR name. The parser accepts +-- all of these because upstream does and real cache.nixos.org +-- archives carry them (perl man pages named @ExtUtils::MakeMaker.3@, +-- kernel trees carrying @aux.c@); a store writer applies this +-- predicate at materialization when the target filesystem needs it. +-- Every check is ASCII-structural, so it stays exact whether or not +-- the name decodes as text (see "NovaCache.SafeName"). +isWindowsHazardName :: ByteString -> Bool +isWindowsHazardName name = + BS8.any (\c -> c == '\\' || c == ':') name + || isReservedDeviceName name + || hasTrailingDotOrSpace name + +-- --------------------------------------------------------------------------- +-- Chunk-fed primitives +-- --------------------------------------------------------------------------- + +-- | Read one whole wire string - length prefix, payload, zero padding - +-- refusing a declared length over the bound before allocating for it. +-- For structural strings only; file contents go through +-- 'streamContents'. +wireString :: Word64 -> String -> (ByteString -> Continue) -> Continue +wireString bound what k = exactly lengthPrefixBytes ("length of " ++ what) withLength + where + withLength lenBytes = + let declared = word64LE lenBytes + in if declared > bound + then + failWith + ( what + ++ ": declared length " + ++ show declared + ++ " exceeds the " + ++ show bound + ++ "-byte wire-string bound" + ) + else + -- Safe narrowing and a safe padded demand: declared <= + -- bound <= structuralBoundCeiling, which sits enough + -- below Int's ceiling that len + narPad len cannot wrap. + let len = fromIntegral declared + in exactly (len + narPad len) what $ \whole -> + case BS.splitAt len whole of + (payload, padding) + -- Nix's reader rejects nonzero padding; accepting it + -- would let archives that upstream tooling refuses + -- round-trip through this library. + | BS.any (/= 0) padding -> failWith nonzeroPadding + | otherwise -> k payload + +-- | Read a wire string and require an exact token. +expectWire :: Word64 -> String -> ByteString -> Continue -> Continue +expectWire bound what expected k = wireString bound what check + where + check got + | got == expected = k + | otherwise = failWith ("expected " ++ show expected ++ ", got " ++ show got) + +-- | Demand exactly @n@ bytes, awaiting more chunks as needed, then +-- continue with them and the leftover. Held chunks concatenate once, +-- so pathological chunking costs linear work, not quadratic. +exactly :: Int -> String -> (ByteString -> Continue) -> Continue +exactly n what k leftover = go [leftover] (BS.length leftover) + where + go !heldRev !heldLen + | heldLen >= n = + case BS.splitAt n (BS.concat (reverse heldRev)) of + (taken, rest) -> k taken rest + | otherwise = NarAwait $ \chunk -> + if BS.null chunk + then NarFail ("unexpected end of NAR: " ++ what) + else go (chunk : heldRev) (heldLen + BS.length chunk) + +-- | Fail from any position that still owes the machine a continuation. +failWith :: String -> Continue +failWith err _ = NarFail err + +nonzeroPadding :: String +nonzeroPadding = "nonzero padding bytes in NAR string" + +-- | Read a little-endian 'Word64' from an 8-byte string. +word64LE :: ByteString -> Word64 +word64LE = BS.foldr accumulate 0 + where + accumulate byte acc = (acc `shiftL` bitsPerByte) .|. fromIntegral byte + +-- | Bits per byte, for the length-prefix fold. +bitsPerByte :: Int +bitsPerByte = 8 diff --git a/src/NovaCache/NarInfo.hs b/src/NovaCache/NarInfo.hs --- a/src/NovaCache/NarInfo.hs +++ b/src/NovaCache/NarInfo.hs @@ -10,7 +10,6 @@ ) where -import Data.List (find) import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -21,12 +20,17 @@ -- --------------------------------------------------------------------------- -- | A parsed @.narinfo@ record. All fields are strict. +-- +-- Field optionality mirrors upstream Nix's parser: only StorePath, URL, +-- NarHash, and NarSize are mandatory; Compression defaults to bzip2 when +-- absent, and FileHash\/FileSize describe the compressed blob only when +-- the cache provides them. data NarInfo = NarInfo { niStorePath :: !Text, niUrl :: !Text, niCompression :: !Text, - niFileHash :: !Text, - niFileSize :: !Integer, + niFileHash :: !(Maybe Text), + niFileSize :: !(Maybe Integer), niNarHash :: !Text, niNarSize :: !Integer, niReferences :: ![Text], @@ -69,30 +73,36 @@ -- Parsing -- --------------------------------------------------------------------------- --- | Parse a narinfo text body into a 'NarInfo'. +-- | Compression assumed when the narinfo omits the field, as upstream's +-- parser does. +defaultCompression :: Text +defaultCompression = "bzip2" + +-- | Parse a narinfo text body into a 't:NarInfo'. Only StorePath, URL, +-- NarHash, and NarSize are required, matching upstream Nix; a valid +-- narinfo from a foreign cache must not be rejected over an absent +-- optional field. parseNarInfo :: Text -> Either String NarInfo parseNarInfo txt = do let kvs = mapMaybe parseLine (T.lines txt) storePath <- require keyStorePath kvs url <- require keyUrl kvs - compression <- require keyCompression kvs - fileHash <- require keyFileHash kvs - fileSize <- require keyFileSize kvs >>= parseInteger keyFileSize + fileSize <- traverse (parseInteger keyFileSize) (lookupLast keyFileSize kvs) narHashVal <- require keyNarHash kvs narSize <- require keyNarSize kvs >>= parseInteger keyNarSize pure NarInfo { niStorePath = storePath, niUrl = url, - niCompression = compression, - niFileHash = fileHash, + niCompression = fromMaybe defaultCompression (lookupLast keyCompression kvs), + niFileHash = lookupLast keyFileHash kvs, niFileSize = fileSize, niNarHash = narHashVal, niNarSize = narSize, - niReferences = parseRefs (lookupFirst keyReferences kvs), - niDeriver = lookupFirst keyDeriver kvs, + niReferences = parseRefs (lookupLast keyReferences kvs), + niDeriver = lookupLast keyDeriver kvs, niSigs = lookupAll keySig kvs, - niCA = lookupFirst keyCA kvs + niCA = lookupLast keyCA kvs } -- | Parse a space-separated references field. @@ -106,19 +116,20 @@ -- Rendering -- --------------------------------------------------------------------------- --- | Render a 'NarInfo' to its text representation. +-- | Render a 't:NarInfo' to its text representation. renderNarInfo :: NarInfo -> Text renderNarInfo ni = T.unlines $ [ kv keyStorePath (niStorePath ni), kv keyUrl (niUrl ni), - kv keyCompression (niCompression ni), - kv keyFileHash (niFileHash ni), - kv keyFileSize (showT (niFileSize ni)), - kv keyNarHash (niNarHash ni), - kv keyNarSize (showT (niNarSize ni)), - kv keyReferences (T.unwords (niReferences ni)) + kv keyCompression (niCompression ni) ] + ++ optionalKV keyFileHash (niFileHash ni) + ++ optionalKV keyFileSize (showT <$> niFileSize ni) + ++ [ kv keyNarHash (niNarHash ni), + kv keyNarSize (showT (niNarSize ni)), + kv keyReferences (T.unwords (niReferences ni)) + ] ++ optionalKV keyDeriver (niDeriver ni) ++ map (kv keySig) (niSigs ni) ++ optionalKV keyCA (niCA ni) @@ -150,9 +161,14 @@ optionalKV _ Nothing = [] optionalKV key (Just val) = [kv key val] --- | Look up the first occurrence of a key. -lookupFirst :: Text -> [(Text, Text)] -> Maybe Text -lookupFirst key kvs = snd <$> find ((== key) . fst) kvs +-- | Look up the LAST occurrence of a scalar key: upstream's parser +-- assigns each field as it reads, so a duplicated key resolves to the +-- final value. (@Sig@ is the one intentionally repeatable key - +-- 'lookupAll'.) +lookupLast :: Text -> [(Text, Text)] -> Maybe Text +lookupLast key = foldl' pick Nothing + where + pick acc (k, v) = if k == key then Just v else acc -- | Look up all occurrences of a key. lookupAll :: Text -> [(Text, Text)] -> [Text] @@ -160,18 +176,42 @@ -- | Require a key to be present. require :: Text -> [(Text, Text)] -> Either String Text -require key kvs = case lookupFirst key kvs of +require key kvs = case lookupLast key kvs of Nothing -> Left ("missing required key: " ++ T.unpack key) Just val -> Right val +-- | Sizes on the wire are uint64 in Nix: at most 20 digits. A longer +-- field is rejected before the bignum parse, because 'TR.decimal' +-- accumulates digit by digit - quadratic in the field length - so an +-- unbounded field costs quadratic CPU and a proportional allocation +-- before any consumer looks at the value. +maxSizeFieldDigits :: Int +maxSizeFieldDigits = 20 + +-- | The uint64 ceiling (2^64 - 1). Twenty digits still admit values +-- past it; upstream's @string2Int\@ refuses those, so a +-- narinfo carrying one would be signed here and then rejected as +-- corrupt by every real Nix client. +maxSizeFieldValue :: Integer +maxSizeFieldValue = 18446744073709551615 + -- | Parse a non-negative base-10 integer, matching C++ Nix's narinfo parser. -- Uses 'TR.decimal' (not 'reads', which also accepts hex/octal/leading space) -- and requires the whole field to be consumed, so a non-canonical value cannot --- slip through and then be re-signed under the cache's key. +-- slip through and then be re-signed under the cache's key. The length is +-- bounded first ('maxSizeFieldDigits'), so the parse cost is constant, and the +-- value is bounded after ('maxSizeFieldValue'), completing the uint64 contract. parseInteger :: Text -> Text -> Either String Integer -parseInteger key txt = case TR.decimal txt of - Right (n, rest) | T.null rest -> Right n - _ -> Left ("invalid integer for " ++ T.unpack key ++ ": " ++ T.unpack txt) +parseInteger key txt + | T.length txt > maxSizeFieldDigits = + Left ("integer field for " ++ T.unpack key ++ " is " ++ show (T.length txt) ++ " characters, above the " ++ show maxSizeFieldDigits ++ " maximum") + | otherwise = case TR.decimal txt of + Right (n, rest) + | T.null rest, + n > maxSizeFieldValue -> + Left ("integer field for " ++ T.unpack key ++ " is above the uint64 maximum: " ++ T.unpack txt) + | T.null rest -> Right n + _ -> Left ("invalid integer for " ++ T.unpack key ++ ": " ++ T.unpack txt) -- | Show a value as 'Text'. showT :: (Show a) => a -> Text diff --git a/src/NovaCache/SafeName.hs b/src/NovaCache/SafeName.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/SafeName.hs @@ -0,0 +1,81 @@ +-- | Windows-unsafe name categories, shared by the store-key allowlist +-- ('NovaCache.Store.sanitizePath') and the NAR materialization +-- predicate ('NovaCache.NAR.Stream.isWindowsHazardName'): names +-- Windows resolves to something other than an ordinary file of that +-- exact spelling. Both guards reject the same categories from one +-- definition, so they cannot drift apart. +-- +-- The predicates take raw bytes, the form NAR entry names have. The +-- categories are ASCII-structural - except the superscript device +-- digits, matched as their exact UTF-8 sequences - and UTF-8 lead and +-- continuation bytes are all @>= 0x80@, so byte-level matching is +-- exact inside valid UTF-8 and inside names that decode as nothing at +-- all. Text callers encode with 'Data.Text.Encoding.encodeUtf8' +-- first. +module NovaCache.SafeName + ( isReservedDeviceName, + hasTrailingDotOrSpace, + ) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (isAsciiUpper, isDigit, toLower) + +-- | Is the name a Windows reserved device (@con@, @prn@, @aux@, @nul@, +-- @com0@-@com9@, @lpt0@-@lpt9@, or a superscript-digit @com@\/@lpt@ +-- form)? The comparison runs on the stem - the portion before the +-- first dot, trailing spaces trimmed - since @nul.txt@ and @NUL .txt@ +-- also open the device. Surfaced to store writers through +-- 'NovaCache.NAR.Stream.isWindowsHazardName', and kept in step with +-- the twin guard nova-nix applies when it materializes NAR entries. +-- +-- Device matching is ASCII case-insensitive, so only @A@-@Z@ fold; any +-- other byte passes through and can never match the named set. +isReservedDeviceName :: ByteString -> Bool +isReservedDeviceName name = stem `elem` namedDevices || isNumberedDevice stem + where + stem = BS8.map asciiLower (deviceStem name) + asciiLower c = if isAsciiUpper c then toLower c else c + namedDevices = ["con", "prn", "aux", "nul"] + +-- | The portion of a name Win32 device parsing compares against the +-- reserved set: up to the first dot, trailing spaces trimmed. +deviceStem :: ByteString -> ByteString +deviceStem = BS8.dropWhileEnd (== ' ') . BS8.takeWhile (/= '.') + +-- | A numbered device stem: @com@ or @lpt@ followed by exactly one +-- device digit (@com10@ is an ordinary name). +isNumberedDevice :: ByteString -> Bool +isNumberedDevice stem = case BS.splitAt numberedDevicePrefixLen stem of + (prefix, digit) -> (prefix == "com" || prefix == "lpt") && isDeviceDigit digit + +-- | Bytes @com@\/@lpt@ occupy in a numbered device stem. +numberedDevicePrefixLen :: Int +numberedDevicePrefixLen = 3 + +-- | One device digit: ASCII @0@-@9@, or superscript one\/two\/three as +-- UTF-8 bytes - Windows reserves the superscript @COM@\/@LPT@ forms +-- alongside the plain ones. Only the UTF-8 spelling is matched: a +-- lone Latin-1 superscript byte is not valid UTF-8, so no UTF-8 write +-- boundary ever lands it on a Windows filesystem, and on POSIX it +-- names an ordinary file. +isDeviceDigit :: ByteString -> Bool +isDeviceDigit bytes = + (BS.length bytes == 1 && BS8.all isDigit bytes) + || bytes `elem` superscriptDigits + +-- | The UTF-8 encodings of U+00B9, U+00B2, U+00B3 (superscript one, +-- two, three). +superscriptDigits :: [ByteString] +superscriptDigits = + [BS.pack [0xC2, 0xB9], BS.pack [0xC2, 0xB2], BS.pack [0xC2, 0xB3]] + +-- | Does the name end with a dot or a space? NTFS strips both at +-- create time, so the on-disk name silently diverges from the requested +-- one and the materialized tree no longer matches what named it. +hasTrailingDotOrSpace :: ByteString -> Bool +hasTrailingDotOrSpace name = case BS8.unsnoc name of + Just (_, end) -> end == '.' || end == ' ' + Nothing -> False diff --git a/src/NovaCache/Server.hs b/src/NovaCache/Server.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/Server.hs @@ -0,0 +1,441 @@ +-- | The Nix binary cache HTTP protocol as a WAI 'Network.Wai.Application'. +-- +-- An IO-boundary module like "NovaCache.Store": routing, write +-- authentication, request-body limits, and the narinfo +-- validation\/signing pipeline of a cache server. Deployment identity +-- stays out of the library: the root page is supplied per deployment via +-- 'scRootResponse' ('defaultRootResponse' otherwise), so the published +-- package carries no operator branding. +-- +-- Protocol surface: +-- +-- @ +-- GET \/nix-cache-info cache metadata +-- GET \/\.narinfo narinfo by store-path hash +-- GET \/nar\/\ NAR payload (streamed from disk) +-- GET \/narinfo-hashes stored-hash listing (authenticated; push-tool plumbing) +-- PUT \/\.narinfo validated, signed, stored (authenticated) +-- PUT \/nar\/\ streamed to disk under a size cap (authenticated) +-- @ +-- +-- HEAD is answered wherever GET is: routing treats the two identically +-- and Warp elides the body while keeping the status and headers. +module NovaCache.Server + ( -- * Configuration + ServerConfig (..), + defaultRootResponse, + newTTLCache, + + -- * Application + cacheApp, + onExceptionResponse, + + -- * Body limits + maxNarInfoBodySize, + maxNarBodySize, + + -- * Handler pieces (exported for tests) + requireAuth, + readBodyLimited, + withLimitedBody, + decodeAndValidate, + narInfoHashMatches, + signNarInfo, + renderCacheInfo, + ) +where + +import Data.Bifunctor (first) +import Data.ByteArray (constEq) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BL +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import GHC.Clock (getMonotonicTime) +import qualified Network.HTTP.Types as HTTP +import Network.Wai + ( Application, + Request, + RequestBodyLength (..), + Response, + ResponseReceived, + getRequestBodyChunk, + pathInfo, + requestBodyLength, + requestHeaders, + requestMethod, + responseFile, + responseLBS, + ) +import NovaCache.NarInfo (NarInfo (..), parseNarInfo, renderNarInfo) +import NovaCache.Signing (SecretKey, sign) +import NovaCache.Store + ( CacheInfo (..), + FileStore, + NarWriteResult (..), + getCacheInfo, + listNarInfoHashes, + narFilePath, + readNarInfo, + writeNarInfo, + writeNarStreaming, + ) +import NovaCache.StorePath (defaultStoreDir, parseStorePath, storePathHashString) +import NovaCache.Validate (validateNarInfo) +import System.IO (hPutStrLn, stderr) + +-- --------------------------------------------------------------------------- +-- Constants +-- --------------------------------------------------------------------------- + +-- | Maximum narinfo request body - narinfo is small text, so a tight cap. +maxNarInfoBodySize :: Int +maxNarInfoBodySize = 4 * 1024 * 1024 -- 4 MB + +-- | Maximum NAR request body. A real store path's NAR can be very large +-- (toolchains, GHC, LLVM), so this is far higher than the narinfo cap. +-- Uploads stream to disk, so the cap bounds storage abuse, not memory. +maxNarBodySize :: Int +maxNarBodySize = 4 * 1024 * 1024 * 1024 -- 4 GB + +-- | Suffix of narinfo request paths (@\/\.narinfo@). +narInfoSuffix :: Text +narInfoSuffix = ".narinfo" + +-- --------------------------------------------------------------------------- +-- Configuration +-- --------------------------------------------------------------------------- + +-- | Server configuration: the store, the write credential, the signing +-- key, and the deployment's root page. +data ServerConfig = ServerConfig + { scStore :: !FileStore, + -- | Write API key. 'Nothing' permits unauthenticated writes (open + -- mode); arming it with an empty key is the embedder's bug to + -- prevent - an empty bearer token would then authenticate. + scApiKey :: !(Maybe ByteString), + -- | Narinfo signing key. 'Nothing' stores uploads unsigned. + scSigningKey :: !(Maybe SecretKey), + -- | Response for @GET \/@, recomputed per request so it can carry + -- live stats. Branding belongs to the embedding executable, never + -- this library. + scRootResponse :: !(IO Response) + } + +-- | Root response for embedders that do not supply a landing page: +-- enough for a human to identify the service, nothing else. +defaultRootResponse :: IO Response +defaultRootResponse = + pure (responseLBS HTTP.status200 textHeaders "nova-cache: a Nix binary cache\n") + +-- | Memoize an action's result for a time-to-live, in seconds +-- (monotonic clock, so wall-time jumps cannot starve the refresh). +-- +-- An unauthenticated route must do bounded work per request: a root +-- response that counts the store, for example, must not scan the whole +-- narinfo directory per hit. Wrap the expensive read once at startup +-- and hand the returned action to 'scRootResponse'. +-- +-- Concurrent requests near expiry may run the action more than once; +-- the last write wins. Acceptable for idempotent reads, which is the +-- intended use. +newTTLCache :: Double -> IO a -> IO (IO a) +newTTLCache ttlSeconds action = do + ref <- newIORef Nothing + pure $ do + now <- getMonotonicTime + cached <- readIORef ref + case cached of + Just (refreshedAt, held) | now - refreshedAt < ttlSeconds -> pure held + _ -> do + fresh <- action + writeIORef ref (Just (now, fresh)) + pure fresh + +-- --------------------------------------------------------------------------- +-- WAI application +-- --------------------------------------------------------------------------- + +-- | WAI application implementing the Nix binary cache HTTP protocol. +cacheApp :: ServerConfig -> Application +cacheApp cfg req respond = case (routeMethod, pathInfo req) of + -- GET / - the deployment's page (protocol lives at the other routes) + ("GET", []) -> + respond =<< scRootResponse cfg + -- GET /nix-cache-info + ("GET", ["nix-cache-info"]) -> + respond (responseLBS HTTP.status200 textHeaders (BL.fromStrict (renderCacheInfo (scStore cfg)))) + -- GET /narinfo-hashes - push-tool plumbing: it enumerates the whole + -- store (something the public protocol deliberately never offers) and + -- lists a directory per hit, so it is gated behind the write key and + -- marked uncacheable. + ("GET", ["narinfo-hashes"]) -> + requireAuth cfg req respond $ do + hashes <- listNarInfoHashes (scStore cfg) + let body = TE.encodeUtf8 (T.unlines hashes) + respond (responseLBS HTTP.status200 hashListHeaders (BL.fromStrict body)) + -- GET /.narinfo + ("GET", [hashNarinfo]) + | Just hashKey <- T.stripSuffix narInfoSuffix hashNarinfo -> do + result <- readNarInfo (scStore cfg) hashKey + case result of + Just content -> + respond (responseLBS HTTP.status200 narInfoHeaders (BL.fromStrict content)) + Nothing -> + respond notFound + -- GET /nar/ - handed to the transport layer as a file so the + -- OS streams it; a multi-GB NAR never transits the Haskell heap. + ("GET", ["nar", fileName]) -> do + found <- narFilePath (scStore cfg) fileName + case found of + Just path -> + respond (responseFile HTTP.status200 octetHeaders path Nothing) + Nothing -> + respond notFound + -- PUT /.narinfo (auth required, validated) + ("PUT", [hashNarinfo]) + | Just hashKey <- T.stripSuffix narInfoSuffix hashNarinfo -> + requireAuth cfg req respond $ + withLimitedBody maxNarInfoBodySize req respond $ \body -> + case decodeAndValidate body of + Left err -> do + logWarn req ("INVALID: " <> T.unpack err) + respond (badRequest err) + Right ni + | not (narInfoHashMatches hashKey ni) -> do + logWarn req "HASHMISMATCH" + respond (badRequest "narinfo StorePath hash does not match request") + | otherwise -> do + signedResult <- signNarInfo (scSigningKey cfg) ni + case signedResult of + Left err -> do + logWarn req ("SIGNFAIL: " <> err) + respond (responseLBS HTTP.status500 textHeaders "signing failed") + Right signed -> do + ok <- writeNarInfo (scStore cfg) hashKey signed + if ok + then respond (responseLBS HTTP.status200 textHeaders "ok") + else do + logWarn req "BADPATH" + respond (badRequest "invalid path") + -- PUT /nar/ (auth required, streamed) + ("PUT", ["nar", fileName]) -> + requireAuth cfg req respond (putNar cfg req respond fileName) + -- Fallback + _ -> + respond notFound + where + -- HEAD is served as GET: the handlers build the same response and + -- Warp elides the body while keeping status, headers, and the + -- computed Content-Length. + routeMethod = + if requestMethod req == HTTP.methodHead + then HTTP.methodGet + else requestMethod req + +-- | Stream a NAR upload into the store. A declared @Content-Length@ over +-- the cap is refused before reading anything; chunked or lying transfers +-- are cut off by the store's running size check, so memory and storage +-- stay bounded either way. +putNar :: ServerConfig -> Request -> (Response -> IO ResponseReceived) -> Text -> IO ResponseReceived +putNar cfg req respond fileName = case requestBodyLength req of + KnownLength len + | len > fromIntegral maxNarBodySize -> overLimit + _ -> do + result <- writeNarStreaming (scStore cfg) fileName maxNarBodySize (getRequestBodyChunk req) + case result of + NarWriteOk -> respond (responseLBS HTTP.status200 textHeaders "ok") + NarWriteTooLarge -> overLimit + NarWriteBadPath -> do + logWarn req "BADPATH" + respond (badRequest "invalid path") + where + overLimit = do + logWarn req "OVERLIMIT" + respond (responseLBS HTTP.status413 textHeaders "request body too large") + +-- --------------------------------------------------------------------------- +-- Validation pipeline +-- --------------------------------------------------------------------------- + +-- | Decode a raw narinfo body and validate it in a single pure pipeline. +-- +-- Composes UTF-8 decoding, narinfo parsing, and field validation. Returns +-- the validated 't:NarInfo' on success, or a user-facing error message. +decodeAndValidate :: ByteString -> Either Text NarInfo +decodeAndValidate body = do + decoded <- first (const "request body is not valid UTF-8") (TE.decodeUtf8' body) + ni <- first T.pack (parseNarInfo decoded) + first (T.unlines . map (T.pack . show)) (validateNarInfo ni) + +-- | Whether the narinfo's declared StorePath actually carries the requested +-- hash - so an authenticated writer cannot store a narinfo describing path X +-- under path Y's key (a cache-poisoning / confused-deputy shape). +narInfoHashMatches :: Text -> NarInfo -> Bool +narInfoHashMatches hashKey ni = + case parseStorePath defaultStoreDir (niStorePath ni) of + Right sp -> storePathHashString sp == hashKey + Left _ -> False + +-- --------------------------------------------------------------------------- +-- Request body limiting +-- --------------------------------------------------------------------------- + +-- | Read the request body, rejecting payloads over the given limit. +-- +-- A declared @Content-Length@ over the limit is rejected up front; otherwise +-- (including unsized/chunked transfers) the body is read in bounded chunks with +-- a running size check that aborts before exceeding the limit, so memory stays +-- bounded regardless of the declared length. +readBodyLimited :: Int -> Request -> IO (Maybe ByteString) +readBodyLimited limit req = case requestBodyLength req of + KnownLength len + | len > fromIntegral limit -> pure Nothing + _ -> readChunks [] 0 + where + readChunks acc total = do + chunk <- getRequestBodyChunk req + if BS.null chunk + then pure (Just (BS.concat (reverse acc))) + else + let newTotal = total + BS.length chunk + in if newTotal > limit + then pure Nothing + else readChunks (chunk : acc) newTotal + +-- | Run an action with the limited request body, responding 413 if too large. +withLimitedBody :: Int -> Request -> (Response -> IO ResponseReceived) -> (ByteString -> IO ResponseReceived) -> IO ResponseReceived +withLimitedBody limit req respond action = do + bodyResult <- readBodyLimited limit req + case bodyResult of + Nothing -> do + logWarn req "OVERLIMIT" + respond (responseLBS HTTP.status413 textHeaders "request body too large") + Just body -> action body + +-- --------------------------------------------------------------------------- +-- Auth +-- --------------------------------------------------------------------------- + +-- | Gate a handler behind API key authentication. +-- +-- If no key is configured, the action is permitted (open mode). +-- Otherwise the request must carry @Authorization: Bearer \@. +-- Uses constant-time comparison to prevent timing attacks. +requireAuth :: ServerConfig -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -> IO ResponseReceived +requireAuth cfg req respond action = case scApiKey cfg of + Nothing -> action + Just expected -> + let provided = lookup HTTP.hAuthorization (requestHeaders req) + expectedHeader = "Bearer " <> expected + in if maybe False (constEq expectedHeader) provided + then action + else do + logWarn req "REJECTED" + respond (responseLBS HTTP.status401 textHeaders "unauthorized") + +-- --------------------------------------------------------------------------- +-- Signing +-- --------------------------------------------------------------------------- + +-- | Sign a validated 't:NarInfo' if a signing key is configured. +-- +-- With no key, returns the unsigned rendering (intentional - the operator +-- configured none). With a key, FAILS CLOSED: a signing error returns 'Left' +-- so the handler refuses the write rather than persisting an unsigned narinfo +-- on a cache that is supposed to sign. +signNarInfo :: Maybe SecretKey -> NarInfo -> IO (Either String ByteString) +signNarInfo Nothing ni = pure (Right (renderNarInfoBytes ni)) +signNarInfo (Just sk) ni = case sign sk ni of + Left err -> do + hPutStrLn stderr ("ERROR: signNarInfo: sign failed: " ++ err) + pure (Left err) + Right sig -> + let signed = ni {niSigs = niSigs ni ++ [sig]} + in pure (Right (renderNarInfoBytes signed)) + +-- | Render a 't:NarInfo' to its UTF-8 encoded wire format. +renderNarInfoBytes :: NarInfo -> ByteString +renderNarInfoBytes = TE.encodeUtf8 . renderNarInfo + +-- --------------------------------------------------------------------------- +-- Logging +-- --------------------------------------------------------------------------- + +-- | Log a server-side warning to stderr with request context. +logWarn :: Request -> String -> IO () +logWarn req msg = + hPutStrLn stderr $ + msg + <> " " + <> BS8.unpack (requestMethod req) + <> " /" + <> T.unpack (T.intercalate "/" (pathInfo req)) + +-- --------------------------------------------------------------------------- +-- Response helpers +-- --------------------------------------------------------------------------- + +-- | Render the nix-cache-info response body. +renderCacheInfo :: FileStore -> ByteString +renderCacheInfo store = + let info = getCacheInfo store + in TE.encodeUtf8 $ + T.unlines + [ "StoreDir: " <> ciStoreDir info, + "WantMassQuery: " <> boolText (ciWantMassQuery info), + "Priority: " <> T.pack (show (ciPriority info)) + ] + +-- | Render a Bool as @1@ or @0@. +boolText :: Bool -> Text +boolText True = "1" +boolText False = "0" + +-- | 404 Not Found response. +notFound :: Response +notFound = responseLBS HTTP.status404 textHeaders "not found" + +-- | 400 Bad Request with a text error message. +badRequest :: Text -> Response +badRequest msg = responseLBS HTTP.status400 textHeaders (BL.fromStrict (TE.encodeUtf8 msg)) + +-- | Map any uncaught handler exception to a generic 500, so internal error +-- detail (filesystem paths, exception text) is never leaked to clients. +onExceptionResponse :: e -> Response +onExceptionResponse _ = responseLBS HTTP.status500 textHeaders "internal server error" + +-- | Content-Type: text/plain headers. +textHeaders :: HTTP.ResponseHeaders +textHeaders = [(HTTP.hContentType, "text/plain")] + +-- | Headers for the authenticated hash listing: push-tool plumbing that +-- changes with every upload, so intermediaries must never cache it. +hashListHeaders :: HTTP.ResponseHeaders +hashListHeaders = + [ (HTTP.hContentType, "text/plain"), + (HTTP.hCacheControl, "no-store") + ] + +-- | Content-Type and caching headers for a narinfo response. +-- A narinfo body is NOT immutable for a fixed key - re-uploading the same store +-- path to add or rotate a signature changes it - so it is cacheable but must +-- stay revalidatable (no @immutable@). +narInfoHeaders :: HTTP.ResponseHeaders +narInfoHeaders = + [ (HTTP.hContentType, "text/x-nix-narinfo"), + (HTTP.hCacheControl, "public, max-age=3600, must-revalidate") + ] + +-- | Content-Type: application/octet-stream headers. +-- NAR files are content-addressed (keyed by content hash) and immutable +-- once written, so they are safe to cache indefinitely at the CDN edge. +octetHeaders :: HTTP.ResponseHeaders +octetHeaders = + [ (HTTP.hContentType, "application/octet-stream"), + (HTTP.hCacheControl, "public, max-age=31536000, immutable") + ] diff --git a/src/NovaCache/Signing.hs b/src/NovaCache/Signing.hs --- a/src/NovaCache/Signing.hs +++ b/src/NovaCache/Signing.hs @@ -20,10 +20,11 @@ import Crypto.Error (CryptoFailable (..)) import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.ByteArray (convert) +import Data.ByteArray (constEq, convert) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -38,8 +39,21 @@ { skName :: !Text, skBytes :: !ByteString } - deriving (Eq, Show) +-- | Renders the key NAME only. The secret bytes must never be +-- reachable through 'Show': any enclosing type deriving 'Show' (a +-- config record, a debug trace, an error formatter) would otherwise +-- render them. Deliberately not read-back-able. +instance Show SecretKey where + show (SecretKey keyName _) = "SecretKey " ++ show keyName ++ " " + +-- | The name compares normally (it is public); the key bytes compare in +-- constant time - equality over secret material must not be +-- timing-dependent. +instance Eq SecretKey where + SecretKey nameA bytesA == SecretKey nameB bytesB = + nameA == nameB && constEq bytesA bytesB + -- | An Ed25519 public key with its key name. data PublicKey = PublicKey { pkName :: !Text, @@ -128,15 +142,22 @@ keyName <> keySeparator <> TE.decodeLatin1 (B64.encode bytes) -- | Split a @name:base64@ string and decode the base64 payload. +-- An empty name or empty payload is corrupt, as upstream's Key +-- constructor treats it: an empty-named key would sign every narinfo +-- with @:sig@ lines no client's named trust anchor can ever match, so +-- the misconfiguration must fail at key-load time, not as silent +-- signature rejection downstream. splitAndDecode :: Text -> String -> Either String (Text, ByteString) splitAndDecode txt label = case T.breakOn keySeparator txt of - (_, rest) + (keyName, rest) | T.null rest -> Left (label ++ " missing ':' separator") + | T.null keyName -> Left (label ++ " has an empty name before ':'") + | T.null encoded -> Left (label ++ " has empty key material after ':'") | otherwise -> do - let encoded = T.drop 1 rest - keyName = fst (T.breakOn keySeparator txt) decoded <- decodeBase64 encoded pure (keyName, decoded) + where + encoded = T.drop 1 rest -- | Assert that decoded bytes have the expected size. expectSize :: Int -> String -> ByteString -> Either String () @@ -167,13 +188,17 @@ niStorePath ni, niNarHash ni, T.pack (show (niNarSize ni)), - T.intercalate referenceSep (map (storeDir <>) (niReferences ni)) + T.intercalate referenceSep (map (storeDir <>) sortedReferences) ] where -- References in a narinfo are basenames, but the fingerprint signs them as -- full store paths (/nix/store/-), matching C++ Nix. The store -- directory is the leading path of the (already absolute) niStorePath. storeDir = T.dropWhileEnd (/= '/') (niStorePath ni) + -- C++ Nix fingerprints a StorePathSet - references sorted by basename, + -- deduplicated - so the narinfo's file order must not leak into the + -- signature: real Nix clients always verify against the sorted form. + sortedReferences = Set.toAscList (Set.fromList (niReferences ni)) -- --------------------------------------------------------------------------- -- Signing and verification diff --git a/src/NovaCache/Store.hs b/src/NovaCache/Store.hs --- a/src/NovaCache/Store.hs +++ b/src/NovaCache/Store.hs @@ -13,6 +13,9 @@ writeNarInfo, readNar, writeNar, + NarWriteResult (..), + writeNarStreaming, + narFilePath, listNarInfoHashes, CacheInfo (..), getCacheInfo, @@ -26,6 +29,8 @@ import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import NovaCache.SafeName (hasTrailingDotOrSpace, isReservedDeviceName) import System.Directory ( createDirectoryIfMissing, doesFileExist, @@ -78,7 +83,7 @@ -- Initialization -- --------------------------------------------------------------------------- --- | Create a 'FileStore' rooted at the given directory. +-- | Create a 't:FileStore' rooted at the given directory. -- -- Ensures the @narinfo@ and @nar@ subdirectories exist. newFileStore :: FilePath -> IO FileStore @@ -136,6 +141,56 @@ Nothing -> pure False Just safe -> atomicWriteFile (fsRoot fs narSubdir safe) body >> pure True +-- | Outcome of a streaming NAR write. +data NarWriteResult + = -- | Fully written and atomically renamed into place. + NarWriteOk + | -- | The chunk stream exceeded the size cap; the partial temp file + -- was deleted and nothing changed in the store. + NarWriteTooLarge + | -- | The filename failed 'sanitizePath'; nothing was written. + NarWriteBadPath + deriving (Eq, Show) + +-- | Stream a NAR to disk from a chunk source (an empty chunk means end of +-- input), enforcing a total-size cap as bytes arrive so the body is never +-- held in memory. Same atomic temp-then-rename discipline as 'writeNar': +-- readers see the old file or the complete new one, never a partial write. +writeNarStreaming :: FileStore -> Text -> Int -> IO ByteString -> IO NarWriteResult +writeNarStreaming fs fileName limit nextChunk = case sanitizePath fileName of + Nothing -> pure NarWriteBadPath + Just safe -> do + let target = fsRoot fs narSubdir safe + (tmpPath, handle) <- openBinaryTempFile (takeDirectory target) tempFilePrefix + let cleanup = do + ignoringExceptions (hClose handle) + ignoringExceptions (removeFile tmpPath) + consume !total = do + chunk <- nextChunk + if BS.null chunk + then do + hClose handle + renameFile tmpPath target + pure NarWriteOk + else + let grown = total + BS.length chunk + in if grown > limit + then cleanup >> pure NarWriteTooLarge + else BS.hPut handle chunk >> consume grown + consume 0 `onException` cleanup + +-- | The on-disk path of a stored NAR, if present. Lets a server hand the +-- file to its transport layer (e.g. WAI's @responseFile@, which streams +-- from disk) instead of buffering the bytes; the name passes the same +-- 'sanitizePath' contract as 'readNar'. +narFilePath :: FileStore -> Text -> IO (Maybe FilePath) +narFilePath fs fileName = case sanitizePath fileName of + Nothing -> pure Nothing + Just safe -> do + let path = fsRoot fs narSubdir safe + exists <- doesFileExist path + pure (if exists then Just path else Nothing) + -- --------------------------------------------------------------------------- -- Listing -- --------------------------------------------------------------------------- @@ -181,34 +236,29 @@ -- | Validate a path component for safe filesystem use via a positive allowlist. -- -- Accepts only non-empty names of @[A-Za-z0-9._+-]@ that do not start with a --- dot and are not a Windows reserved device name. This rejects directory +-- dot, do not end with a dot (NTFS strips it, silently renaming the file), +-- and are not a Windows reserved device name. This rejects directory -- separators, @.@\/@..@ traversal, dotfiles (including the temp-write prefix), -- NUL bytes, alternate-data-stream (@name:stream@) syntax, and device names -- like @nul@ - so a client-supplied hash or NAR filename can never escape the --- store directory or resolve to a device, on any platform. +-- store directory, resolve to a device, or land under a different name, on +-- any platform. The Windows-specific categories are shared with the NAR +-- entry-name guard via "NovaCache.SafeName". sanitizePath :: Text -> Maybe FilePath sanitizePath txt | T.null txt = Nothing | T.isPrefixOf "." txt = Nothing | T.any (not . isSafeChar) txt = Nothing - | isReservedName txt = Nothing + | isReservedDeviceName keyBytes = Nothing + | hasTrailingDotOrSpace keyBytes = Nothing | otherwise = Just (T.unpack txt) where + -- The shared hazard predicates take the byte form NAR entry names + -- have; a store key is ASCII by the allowlist above, so its UTF-8 + -- encoding is the same spelling. + keyBytes = TE.encodeUtf8 txt isSafeChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-+" :: [Char]) - --- | Is the name a Windows reserved device (@con@, @prn@, @aux@, @nul@, --- @com1@-@com9@, @lpt1@-@lpt9@)? Matched case-insensitively on the portion --- before the first dot, since @nul.txt@ also opens the device. Enforced on --- every platform so a Windows-hosted cache is safe too. -isReservedName :: Text -> Bool -isReservedName txt = T.toLower (T.takeWhile (/= '.') txt) `elem` reservedNames - where - reservedNames = - ["con", "prn", "aux", "nul"] - ++ ["com" <> n | n <- digits] - ++ ["lpt" <> n | n <- digits] - digits = [T.pack (show n) | n <- [1 .. 9 :: Int]] -- --------------------------------------------------------------------------- -- Internal diff --git a/src/NovaCache/StorePath.hs b/src/NovaCache/StorePath.hs --- a/src/NovaCache/StorePath.hs +++ b/src/NovaCache/StorePath.hs @@ -9,6 +9,8 @@ StorePathHash (..), StorePathName (..), parseStorePath, + parseStorePathBaseName, + parseAbsoluteStorePath, renderStorePath, storePathHashString, storePathBaseName, @@ -16,7 +18,7 @@ ) where -import Data.Char (isAlphaNum) +import Data.Char (isAlphaNum, isAscii) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -69,16 +71,22 @@ hashNameSeparator :: Char hashNameSeparator = '-' +-- | Maximum length of a store path name, as enforced by Nix. +maxNameLen :: Int +maxNameLen = 211 + -- --------------------------------------------------------------------------- -- Validation -- --------------------------------------------------------------------------- -- | Characters allowed in the name component of a store path. -- --- Alphanumeric plus @-._+?=@, matching the Nix specification. +-- ASCII alphanumeric plus @-._+?=@, matching the Nix specification. The +-- ASCII restriction matters: Nix rejects non-ASCII letters and digits, so +-- accepting them here would sign and store paths no Nix client can parse. validNameChar :: Char -> Bool validNameChar c = - isAlphaNum c + (isAscii c && isAlphaNum c) || c == '-' || c == '_' || c == '.' @@ -93,16 +101,37 @@ -- | Parse a store path from a full path or bare basename. -- -- Accepts @\/nix\/store\/\-\@ or just @\-\@. +-- Wire-format fields have a REQUIRED spelling; use 'parseStorePathBaseName' +-- (narinfo References, Deriver) or 'parseAbsoluteStorePath' (narinfo +-- StorePath) to enforce it. parseStorePath :: StoreDir -> Text -> Either String StorePath parseStorePath (StoreDir dir) txt = parseBaseName (stripDirPrefix dir txt) +-- | Parse a bare @\-\@ basename, rejecting any path separator. +-- Narinfo References and Deriver are basenames on the wire; upstream Nix +-- rejects tokens containing @\/@ outright. +parseStorePathBaseName :: Text -> Either String StorePath +parseStorePathBaseName txt + | T.any (== '/') txt = + Left ("expected a store path basename, got a path: " ++ T.unpack txt) + | otherwise = parseBaseName txt + +-- | Parse a full @\\/\-\@ path, rejecting a bare +-- basename. The narinfo StorePath field is absolute on the wire. +parseAbsoluteStorePath :: StoreDir -> Text -> Either String StorePath +parseAbsoluteStorePath (StoreDir dir) txt = + case T.stripPrefix (T.pack dir <> "/") txt of + Just basename -> parseBaseName basename + Nothing -> + Left ("expected an absolute store path under " ++ dir ++ ": " ++ T.unpack txt) + -- | Strip the store directory prefix if present. stripDirPrefix :: FilePath -> Text -> Text stripDirPrefix dir txt = fromMaybe txt (T.stripPrefix (T.pack dir <> "/") txt) --- | Parse a @\-\@ basename into a 'StorePath'. +-- | Parse a @\-\@ basename into a 't:StorePath'. parseBaseName :: Text -> Either String StorePath parseBaseName basename | T.length basename < minBaseNameLen = @@ -115,6 +144,16 @@ Left ("invalid nix-base32 hash in store path: " ++ T.unpack hashPart) | T.null name = Left ("empty name in store path: " ++ T.unpack basename) + | T.length name > maxNameLen = + Left ("store path name longer than " ++ show maxNameLen ++ " characters: " ++ T.unpack name) + -- Upstream's checkName dot rule: the FIRST dash-separated component may + -- not be "." or "..", rejecting the traversal names and their ".-x" / + -- "..-y" prefixed forms alike, while other dot-leading names + -- (".config-1.0") stay valid. Same rule nova-nix enforces at its + -- construction and parse boundaries; a dot name accepted here would be + -- stored and signed although no Nix client parses it. + | firstDashComponent == "." || firstDashComponent == ".." = + Left ("store path name may not begin with a dot segment: " ++ T.unpack name) | not (T.all validNameChar name) = Left ("invalid characters in store path name: " ++ T.unpack name) | otherwise = @@ -122,6 +161,7 @@ where hashPart = T.take storePathHashLen basename name = T.drop minBaseNameLen basename + firstDashComponent = T.takeWhile (/= '-') name -- --------------------------------------------------------------------------- -- Rendering diff --git a/src/NovaCache/Validate.hs b/src/NovaCache/Validate.hs --- a/src/NovaCache/Validate.hs +++ b/src/NovaCache/Validate.hs @@ -19,7 +19,7 @@ import NovaCache.Hash (formatNixHash, hashBytes, parseNixHash) import NovaCache.NarInfo (NarInfo (..)) import NovaCache.Signing (PublicKey, verify) -import NovaCache.StorePath (defaultStoreDir, parseStorePath) +import NovaCache.StorePath (defaultStoreDir, parseAbsoluteStorePath, parseStorePathBaseName) -- --------------------------------------------------------------------------- -- Types @@ -57,7 +57,7 @@ -- | Validate narinfo field semantics: sizes non-negative, store path parses, -- hash fields parse, references parse. Collects all errors (not short-circuit). --- Returns the 'NarInfo' unchanged on success for composition. +-- Returns the 't:NarInfo' unchanged on success for composition. validateNarInfo :: NarInfo -> Either [ValidationError] NarInfo validateNarInfo ni = case concat [sizeErrors, drvErrors, storePathErrors, fileHashErrors, narHashErrors, refErrors] of @@ -65,19 +65,26 @@ errs -> Left errs where sizeErrors = - [NegativeFileSize (niFileSize ni) | niFileSize ni < 0] + [NegativeFileSize declared | Just declared <- [niFileSize ni], declared < 0] ++ [NegativeNarSize (niNarSize ni) | niNarSize ni < 0] drvErrors = [DerivationStorePath (niStorePath ni) | ".drv" `T.isSuffixOf` niStorePath ni] - storePathErrors = case parseStorePath defaultStoreDir (niStorePath ni) of + -- The wire format fixes each field's spelling: StorePath is absolute, + -- References and Deriver are basenames. Accepting the other spelling + -- would sign narinfos (bare StorePath, absolute references) that every + -- real Nix client rejects at parse time - and a bare StorePath also + -- derives an empty store dir in the signed fingerprint. + storePathErrors = case parseAbsoluteStorePath defaultStoreDir (niStorePath ni) of Left err -> [InvalidStorePath (niStorePath ni) err] Right _ -> [] - fileHashErrors = case parseNixHash (niFileHash ni) of - Left err -> [InvalidFileHash (niFileHash ni) err] - Right _ -> [] + fileHashErrors = case niFileHash ni of + Nothing -> [] + Just declared -> case parseNixHash declared of + Left err -> [InvalidFileHash declared err] + Right _ -> [] narHashErrors = case parseNixHash (niNarHash ni) of Left err -> [InvalidNarHash (niNarHash ni) err] @@ -85,7 +92,7 @@ refErrors = concatMap checkRef (niReferences ni) - checkRef ref = case parseStorePath defaultStoreDir ref of + checkRef ref = case parseStorePathBaseName ref of Left err -> [InvalidReference ref err] Right _ -> [] @@ -97,8 +104,11 @@ -- the declared 'niNarHash'. validateNarHash :: NarInfo -> ByteString -> Either ValidationError () validateNarHash ni narBytes = - -- Compare DECODED hash bytes, not re-formatted strings, so any valid encoding - -- of the declared NarHash (SRI, hex, base32) validates against the same digest. + -- Compare DECODED hash bytes, not re-formatted strings. Only the + -- canonical sha256: spelling parses - deliberately strict, + -- since the fingerprint signs the NarHash TEXT verbatim; accepting other + -- encodings on the read side arrives with the foreign-cache substitution + -- feature that needs them. case parseNixHash (niNarHash ni) of Left err -> Left (InvalidNarHash (niNarHash ni) err) Right declared @@ -106,14 +116,17 @@ | otherwise -> Left (NarHashMismatch (niNarHash ni) (formatNixHash (hashBytes narBytes))) -- | Validate that the SHA-256 hash of compressed file bytes matches --- the declared 'niFileHash'. +-- the declared 'niFileHash'. An absent FileHash declares nothing to +-- check (upstream treats the field as optional); integrity then rests on +-- the always-required NarHash. validateFileHash :: NarInfo -> ByteString -> Either ValidationError () -validateFileHash ni fileBytes = - case parseNixHash (niFileHash ni) of - Left err -> Left (InvalidFileHash (niFileHash ni) err) +validateFileHash ni fileBytes = case niFileHash ni of + Nothing -> Right () + Just declaredText -> case parseNixHash declaredText of + Left err -> Left (InvalidFileHash declaredText err) Right declared | declared == hashBytes fileBytes -> Right () - | otherwise -> Left (FileHashMismatch (niFileHash ni) (formatNixHash (hashBytes fileBytes))) + | otherwise -> Left (FileHashMismatch declaredText (formatNixHash (hashBytes fileBytes))) -- --------------------------------------------------------------------------- -- Signature validation diff --git a/src/NovaCache/Xz.hs b/src/NovaCache/Xz.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/Xz.hs @@ -0,0 +1,290 @@ +-- | Bounded xz decompression for untrusted cache data. +-- +-- cache.nixos.org serves NARs xz-compressed, and substitution +-- decompresses bytes that arrive from the network BEFORE any hash can +-- vouch for them, so the decoder must not be steerable into unbounded +-- allocation. The consumer knows the narinfo's declared NarSize +-- before decompressing: decompression takes that bound and fails past +-- it ('xzMaxOutputBytes'), so a small compressed input cannot expand +-- to arbitrary memory ahead of the hash check. The decoder's own +-- state is capped as well ('xzMaxDecoderMemoryBytes') - upstream +-- passes no limit there; the divergence is deliberate hardening and +-- the cap is a parameter. +-- +-- Concatenated streams decode as one output, matching upstream's +-- @LZMA_CONCATENATED@ decoder in libutil's compression sink. +-- +-- This module lives in the public @nova-cache:xz@ sublibrary. The +-- @lzma-static@ dependency bundles liblzma's C sources, so no system +-- library is needed on any platform - but it is still an extra C +-- build that consumers without foreign-cache needs should not pay +-- for, and a default-on compression dependency broke downstream +-- installs once already (0.5.0.0). Consumers that substitute from +-- foreign caches depend on @nova-cache:xz@; everyone else never +-- builds it. +module NovaCache.Xz + ( XzLimits (..), + defaultXzDecoderMemoryBytes, + XzError (..), + truncatedInputMessage, + decompress, + withXzSource, + ) +where + +import qualified Codec.Compression.Lzma as Lzma +import Control.Exception (Exception, SomeException, throwIO, try) +-- decompressST runs in lazy ST (the upstream package's own lazy +-- API drives it the same way); the driver's accumulator bangs and +-- guard-before-recurse keep the bound checks strict regardless. +import Control.Monad.ST.Lazy (runST) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Word (Word64) + +-- --------------------------------------------------------------------------- +-- Limits +-- --------------------------------------------------------------------------- + +-- | What a decode run may cost. Both bounds are inclusive: output of +-- exactly 'xzMaxOutputBytes' passes, one byte more fails - a narinfo's +-- NarSize is exact, so the declared size itself must be reachable. +data XzLimits = XzLimits + { -- | Maximum decompressed output, in bytes: the narinfo's declared + -- NarSize. + xzMaxOutputBytes :: !Word64, + -- | Maximum decoder-state memory liblzma may allocate. Decoder + -- memory tracks the stream's declared dictionary size, an + -- attacker-chosen number read from the compressed header. + xzMaxDecoderMemoryBytes :: !Word64 + } + deriving (Eq, Show) + +-- | A decoder-memory cap for callers without an opinion: 1 GiB. The +-- largest standard preset (@xz -9@) declares a 64 MiB dictionary and +-- needs about 65 MiB to decode, so this refuses only hand-rolled +-- dictionaries past 1 GiB. Upstream passes no limit at all; a +-- consumer matching that exactly can pass 'maxBound'. +defaultXzDecoderMemoryBytes :: Word64 +defaultXzDecoderMemoryBytes = 1024 * 1024 * 1024 + +-- --------------------------------------------------------------------------- +-- Errors +-- --------------------------------------------------------------------------- + +-- | Everything a bounded decode can refuse. The pure 'decompress' +-- returns these in 'Left'; the pull source behind 'withXzSource' +-- throws them (see the 'Exception' instance). +data XzError + = -- | The compressed stream is malformed, truncated, or carries + -- trailing garbage (liblzma's status, rendered). + XzStreamError !String + | -- | Decompressed output would exceed the bound (carried here). + XzOutputOverBound !Word64 + | -- | The stream declares a dictionary needing more decoder memory + -- than the bound (carried here). + XzMemoryOverBound !Word64 + deriving (Eq, Show) + +-- | Thrown by the pull source 'withXzSource' hands its continuation; +-- a chunk convention has no error channel, and a throwing pull +-- composes with consumers built around one (the store's streaming +-- write cleans up via its exception path). +instance Exception XzError + +-- --------------------------------------------------------------------------- +-- Pure bounded decode +-- --------------------------------------------------------------------------- + +-- | Decompress one xz blob under the given limits. Output stops +-- accumulating the moment it would pass the bound, so a +-- high-expansion input costs at most the bound plus one decoder +-- buffer, never what it claims to hold. +decompress :: XzLimits -> ByteString -> Either XzError ByteString +decompress limits input = runST $ do + start <- Lzma.decompressST (decompressParams limits) + drive (Just input) 0 [] start + where + bound = xzMaxOutputBytes limits + drive pending !produced acc step = case step of + -- The whole input feeds on the first request; the second request + -- gets the empty string, liblzma's end-of-input signal. + Lzma.DecompressInputRequired supply -> case pending of + Just bytes -> drive Nothing produced acc =<< supply bytes + Nothing -> drive Nothing produced acc =<< supply BS.empty + Lzma.DecompressOutputAvailable out next -> + case growWithinBound bound produced out of + Nothing -> pure (Left (XzOutputOverBound bound)) + Just grown -> drive pending grown (out : acc) =<< next + Lzma.DecompressStreamEnd leftover + | BS.null leftover -> pure (Right (BS.concat (reverse acc))) + | otherwise -> pure (Left (XzStreamError trailingDataMessage)) + Lzma.DecompressStreamError ret -> pure (Left (mapRet limits ret)) + +-- --------------------------------------------------------------------------- +-- Streaming bounded decode (IO boundary) +-- --------------------------------------------------------------------------- + +-- | What the pull source is doing between calls. The 'IORef' holding +-- this is the module's one piece of mutable state - the same +-- deliberate, documented boundary as the streaming NAR source. +data XzSourceState + = XzStreaming !(Lzma.DecompressStream IO) !Word64 + | XzDrained + | -- | A pull failed; the exception is held so every later pull + -- re-throws it. Collapsing failure into 'XzDrained' would let a + -- consumer that catches the first throw pull once more and read + -- the empty chunk - the clean-end signal - presenting truncated + -- output as complete. Held at 'SomeException', not 'XzError': + -- the compressed source throwing mid-pull leaves the transfer + -- just as unfinishable as a decoder error does. + XzFailed !SomeException + +-- | Decompress a chunk source into a chunk source, under the limits. +-- The continuation's pull yields decompressed chunks; the empty chunk +-- means end of output and repeats on further pulls. The compressed +-- source follows the same convention on its side. Pairs with the +-- incremental NAR parser and hashing, so a substituter can fetch, +-- decompress, hash, and unpack in one bounded pass. +-- +-- Limit violations and malformed input are thrown as 'XzError' from +-- the pull; once a pull has let any exception escape - decoder error +-- or the compressed source failing - every later pull re-throws the +-- same exception. +-- +-- Despite the bracket-shaped name there is no bracket to run: the +-- binding ("Codec.Compression.Lzma") exposes no teardown for a live +-- 'Lzma.DecompressStream' - it runs @lzma_end@ itself on the clean +-- end path and otherwise leaves it to the stream's ForeignPtr +-- finalizer. A pull that throws, or a consumer that exits early, +-- therefore strands the decoder state (up to 'xzMaxDecoderMemoryBytes') +-- until a GC runs the finalizer. Undo condition: a lzma-static +-- release surfacing live-stream teardown in the high-level API (its +-- internal @LibLzma.endLzmaStream@ is what the fix needs), at which +-- point this becomes a real bracket ending the stream on every exit +-- path. +withXzSource :: XzLimits -> IO ByteString -> (IO ByteString -> IO a) -> IO a +withXzSource limits compressedSource consume = do + start <- Lzma.decompressIO (decompressParams limits) + stateRef <- newIORef (XzStreaming start 0) + consume (pullDecompressed limits compressedSource stateRef) + +-- | Produce the next decompressed chunk. +pullDecompressed :: XzLimits -> IO ByteString -> IORef XzSourceState -> IO ByteString +pullDecompressed limits compressedSource stateRef = dispatch =<< readIORef stateRef + where + bound = xzMaxOutputBytes limits + dispatch XzDrained = pure BS.empty + dispatch (XzFailed failure) = throwIO failure + dispatch (XzStreaming step produced) = do + outcome <- tryPull (advance step produced) + case outcome of + Left failure -> do + writeIORef stateRef (XzFailed failure) + throwIO failure + Right chunk -> pure chunk + advance step produced = case step of + Lzma.DecompressInputRequired supply -> do + chunk <- compressedSource + next <- supply chunk + advance next produced + Lzma.DecompressOutputAvailable out nextAction -> + case growWithinBound bound produced out of + Nothing -> throwIO (XzOutputOverBound bound) + Just grown -> do + next <- nextAction + writeIORef stateRef (XzStreaming next grown) + -- liblzma may hand back an empty buffer at stream + -- boundaries; returning it would read as end of output. + if BS.null out + then advance next grown + else pure out + Lzma.DecompressStreamEnd leftover + | BS.null leftover -> do + writeIORef stateRef XzDrained + pure BS.empty + | otherwise -> throwIO (XzStreamError trailingDataMessage) + Lzma.DecompressStreamError ret -> throwIO (mapRet limits ret) + +-- | 'try' at 'SomeException', monomorphic so the catch-all needs no +-- annotation at the call site. Any exception escaping a pull - the +-- compressed source failing included - leaves the transfer +-- unfinishable, and the only sound later answer is the same failure +-- again, so the caller latches whatever this catches. +tryPull :: IO ByteString -> IO (Either SomeException ByteString) +tryPull = try + +-- --------------------------------------------------------------------------- +-- Shared decoder machinery +-- --------------------------------------------------------------------------- + +-- | Decoder parameters under the limits: concatenated-stream decoding +-- as upstream, memory capped, everything else at the library default. +decompressParams :: XzLimits -> Lzma.DecompressParams +decompressParams limits = + Lzma.defaultDecompressParams + { Lzma.decompressConcatenated = True, + Lzma.decompressMemLimit = xzMaxDecoderMemoryBytes limits + } + +-- | Total output after one more chunk, if it stays within the +-- inclusive bound. The pure driver and the streaming pull both decide +-- the boundary here, so output of exactly the bound - a narinfo's +-- NarSize is exact - passes in both paths by construction. +growWithinBound :: Word64 -> Word64 -> ByteString -> Maybe Word64 +growWithinBound bound produced chunk + | grown > bound = Nothing + | otherwise = Just grown + where + grown = produced + fromIntegral (BS.length chunk) + +-- | Map liblzma's status to the error vocabulary. The binding hands +-- over the raw 'Lzma.LzmaRet'; shown as-is, a zero-byte input would +-- fail with the message @LzmaRetOK@ - which reads as success - so the +-- terminal statuses get real diagnoses instead. +mapRet :: XzLimits -> Lzma.LzmaRet -> XzError +mapRet limits ret = case ret of + Lzma.LzmaRetMemlimitError -> XzMemoryOverBound (xzMaxDecoderMemoryBytes limits) + -- Input exhausted mid-stream: the binding reports LzmaRetOK when + -- the decoder was still content at end of input (a zero-byte input + -- lands here) and LzmaRetBufError when it could make no further + -- progress; both mean the input ran out before the stream did. + Lzma.LzmaRetOK -> XzStreamError truncatedInputMessage + Lzma.LzmaRetBufError -> XzStreamError truncatedInputMessage + Lzma.LzmaRetFormatError -> XzStreamError formatErrorMessage + Lzma.LzmaRetDataError -> XzStreamError dataErrorMessage + Lzma.LzmaRetOptionsError -> XzStreamError optionsErrorMessage + Lzma.LzmaRetUnsupportedCheck -> XzStreamError unsupportedCheckMessage + Lzma.LzmaRetMemError -> XzStreamError decoderAllocationMessage + -- LzmaRetStreamEnd, LzmaRetGetCheck, LzmaRetProgError never reach + -- the error path under this module's parameters; if the binding + -- surfaces one anyway, name it honestly rather than invent a cause. + other -> XzStreamError (unexpectedStatusPrefix ++ show other) + +-- | Diagnosis for input that ends before the xz stream does. A +-- zero-byte input and a truncated download both land here; exported so +-- consumers can match the condition without parsing prose. +truncatedInputMessage :: String +truncatedInputMessage = "compressed input is empty or truncated before the end of the xz stream" + +trailingDataMessage :: String +trailingDataMessage = "trailing data after the xz stream" + +formatErrorMessage :: String +formatErrorMessage = "input is not an xz stream (magic bytes not recognized)" + +dataErrorMessage :: String +dataErrorMessage = "corrupt xz stream" + +optionsErrorMessage :: String +optionsErrorMessage = "xz stream declares unsupported filter options" + +unsupportedCheckMessage :: String +unsupportedCheckMessage = "xz stream declares an unsupported integrity check" + +decoderAllocationMessage :: String +decoderAllocationMessage = "decoder memory allocation failed" + +unexpectedStatusPrefix :: String +unexpectedStatusPrefix = "unexpected liblzma status: " diff --git a/src/NovaCache/Zstd.hs b/src/NovaCache/Zstd.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/Zstd.hs @@ -0,0 +1,429 @@ +-- | Bounded zstd decompression, and compression for the push path. +-- +-- The modern caches (Cachix, attic, FlakeHub) serve NARs +-- zstd-compressed, and a cache of our own wants the same: near-xz +-- ratio on binaries with decompression an order of magnitude +-- faster. Substitution decompresses bytes that arrive from the +-- network BEFORE any hash can vouch for them, so the decoder must +-- not be steerable into unbounded allocation. The consumer knows +-- the narinfo's declared NarSize before decompressing: +-- decompression takes that bound and fails past it +-- ('zstdMaxOutputBytes'), so a small compressed input cannot expand +-- to arbitrary memory ahead of the hash check. +-- +-- The decoder drives @ZSTD_decompressStream@ through the binding's +-- FFI module rather than its high-level streaming driver, for two +-- properties the driver cannot give: +-- +-- * The decompression context is created and freed in a bracket +-- (@withDecoder@), so its window buffer - sized by the incoming +-- frame header, i.e. by the peer, up to libzstd's 128 MiB default +-- ceiling - is released deterministically on every exit: success, +-- bound violation, corrupt frame, or an exception in the +-- consumer. The driver frees contexts only when the GC runs a +-- finalizer. +-- +-- * The stream's end state is observable: @ZSTD_decompressStream@ +-- returns 0 exactly when a frame is completely decoded and fully +-- flushed. Input that ends anywhere else - a frame cut off +-- mid-way, or trailing bytes the decoder buffered as a +-- prospective next frame header - refuses with 'ZstdStreamError', +-- the same complete-stream contract as 'NovaCache.Xz'. The +-- driver discards this return value at end of input and reports a +-- clean end regardless. +-- +-- Decoder window memory is bounded by libzstd itself: the binding +-- exposes no window-limit parameter, but the streaming decoder +-- refuses any frame declaring a window past its default +-- @ZSTD_WINDOWLOG_LIMIT_DEFAULT@ (2^27, 128 MiB), so decoder memory +-- is capped by the library rather than by a caller-chosen number. +-- Take the tunable cap here too if the binding ever exposes +-- @ZSTD_d_windowLogMax@. +-- +-- Everything here is IO: streaming decompression is stateful C +-- calls against a bracketed context, unlike lzma's lazy-ST driver +-- under 'NovaCache.Xz'. +-- +-- This module lives in the public @nova-cache:zstandard@ sublibrary +-- (a component named @zstd@ would shadow the @zstd@ dependency), the +-- same solver-visible opt-in as @nova-cache:xz@: the @zstd@ package +-- bundles libzstd's C sources (no system library on any platform), +-- and consumers that do not need the codec never build them. +module NovaCache.Zstd + ( ZstdLimits (..), + ZstdError (..), + decompress, + compress, + ZstdCompressionLevel, + zstdCompressionLevel, + lowestCompressionLevel, + maxCompressionLevel, + defaultCompressionLevel, + withZstdSource, + ) +where + +import qualified Codec.Compression.Zstd as OneShot +import Codec.Compression.Zstd.FFI (Buffer (..), In, Out) +import qualified Codec.Compression.Zstd.FFI as FFI +import Control.Exception (Exception, SomeException, bracket, throwIO, try) +import Control.Monad (when) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BSU +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Word (Word64, Word8) +import Foreign.Marshal.Alloc (free, malloc, mallocBytes) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Storable (peek, poke) + +-- --------------------------------------------------------------------------- +-- Limits +-- --------------------------------------------------------------------------- + +-- | What a decode run may cost. The bound is inclusive: output of +-- exactly 'zstdMaxOutputBytes' passes, one byte more fails - a +-- narinfo's NarSize is exact, so the declared size itself must be +-- reachable. Decoder-state memory is capped by libzstd's default +-- window limit (see the module header), not by a field here. +newtype ZstdLimits = ZstdLimits + { -- | Maximum decompressed output, in bytes: the narinfo's declared + -- NarSize. + zstdMaxOutputBytes :: Word64 + } + deriving (Eq, Show) + +-- --------------------------------------------------------------------------- +-- Errors +-- --------------------------------------------------------------------------- + +-- | Everything a bounded decode can refuse. The pure-shaped +-- 'decompress' returns these in 'Left'; the pull source behind +-- 'withZstdSource' throws them (see the 'Exception' instance). +data ZstdError + = -- | The compressed stream is unacceptable: malformed (libzstd's + -- error name, rendered with the failing call site), or ended + -- anywhere but exactly between frames (truncated mid-frame, or + -- trailing bytes after the last frame). + ZstdStreamError !String + | -- | Decompressed output would exceed the bound (carried here). + ZstdOutputOverBound !Word64 + deriving (Eq, Show) + +-- | Thrown by the pull source 'withZstdSource' hands its +-- continuation; a chunk convention has no error channel, and a +-- throwing pull composes with consumers built around one. +instance Exception ZstdError + +-- | One libzstd failure in this module's error vocabulary. +renderError :: String -> String -> ZstdError +renderError site name = ZstdStreamError (site <> ": " <> name) + +-- | Call sites named in 'ZstdStreamError' messages. +dstreamCreateSite, dstreamInitSite, decompressStreamSite, endOfInputSite :: String +dstreamCreateSite = "ZSTD_createDStream" +dstreamInitSite = "ZSTD_initDStream" +decompressStreamSite = "ZSTD_decompressStream" +endOfInputSite = "end of input" + +-- | The refusal for a stream that ends anywhere but exactly between +-- frames. One error covers both shapes deliberately: libzstd +-- buffers a truncated frame header and one to three trailing +-- garbage bytes identically (either could be the start of a next +-- frame), so the two are not distinguishable here. +incompleteStreamError :: ZstdError +incompleteStreamError = renderError endOfInputSite "truncated frame or trailing bytes" + +-- --------------------------------------------------------------------------- +-- Compression levels +-- --------------------------------------------------------------------------- + +-- | A compression level the binding accepts: 'lowestCompressionLevel' +-- through 'maxCompressionLevel'. The constructor is not exported, so +-- an out-of-range level is unrepresentable and 'compress' is total; +-- the binding's own compress calls 'error' (under unsafePerformIO) +-- on a level outside this range. +newtype ZstdCompressionLevel = ZstdCompressionLevel Int + deriving (Eq, Ord, Show) + +-- | Validate a level into 't:ZstdCompressionLevel'; 'Nothing' outside +-- the accepted range. +zstdCompressionLevel :: Int -> Maybe ZstdCompressionLevel +zstdCompressionLevel level + | level >= lowestCompressionLevel && level <= maxCompressionLevel = + Just (ZstdCompressionLevel level) + | otherwise = Nothing + +-- | The highest level libzstd supports (@ZSTD_maxCLevel@; 22 in +-- current releases). +maxCompressionLevel :: Int +maxCompressionLevel = FFI.maxCLevel + +-- | The lowest level the binding accepts. libzstd itself reads 0 as +-- "use the default" and negative values as the fast modes, but the +-- binding's compress rejects anything below 1, so 1 is the floor of +-- the representable range. +lowestCompressionLevel :: Int +lowestCompressionLevel = 1 + +-- | libzstd's own default (level 3): the ratio/speed point the +-- library authors tuned for, and far cheaper than xz at push time. +defaultCompressionLevel :: ZstdCompressionLevel +defaultCompressionLevel = ZstdCompressionLevel 3 + +-- --------------------------------------------------------------------------- +-- Compression (push path) +-- --------------------------------------------------------------------------- + +-- | Compress one payload at the given level. The produced frame +-- records its content size, so consumers with a one-shot decoder can +-- allocate exactly. Total by construction: 't:ZstdCompressionLevel' +-- cannot hold a level the binding's pure one-shot API would reject. +compress :: ZstdCompressionLevel -> ByteString -> ByteString +compress (ZstdCompressionLevel level) = OneShot.compress level + +-- --------------------------------------------------------------------------- +-- Bounded decode +-- --------------------------------------------------------------------------- + +-- | Decompress one zstd payload under the given limits. Output +-- stops accumulating the moment it would pass the bound, so a +-- high-expansion input costs at most the bound plus one decoder +-- buffer, never what it claims to hold. Concatenated frames decode +-- as one output, as upstream's decompression sink accepts; input +-- that ends mid-frame or carries trailing bytes refuses (see the +-- module header). +decompress :: ZstdLimits -> ByteString -> IO (Either ZstdError ByteString) +decompress limits input = do + remainingRef <- newIORef (Just input) + try (withZstdSource limits (oneShotSource remainingRef) drainSource) + +-- | Yield the held payload on the first pull, the end-of-input empty +-- chunk on every later one. +oneShotSource :: IORef (Maybe ByteString) -> IO ByteString +oneShotSource remainingRef = do + remaining <- readIORef remainingRef + case remaining of + Nothing -> pure BS.empty + Just bytes -> do + writeIORef remainingRef Nothing + pure bytes + +-- | Collect a pull source's chunks into one strict ByteString. +drainSource :: IO ByteString -> IO ByteString +drainSource pull = collect [] + where + collect acc = do + chunk <- pull + if BS.null chunk + then pure (BS.concat (reverse acc)) + else collect (chunk : acc) + +-- --------------------------------------------------------------------------- +-- Streaming bounded decode (IO boundary) +-- --------------------------------------------------------------------------- + +-- | Decompress a chunk source into a chunk source, under the +-- limits. The continuation's pull yields decompressed chunks; the +-- empty chunk means end of output and repeats on further pulls. +-- The compressed source follows the same convention on its side. +-- Pairs with the incremental NAR parser and hashing, so a +-- substituter can fetch, decompress, hash, and unpack in one +-- bounded pass. +-- +-- Limit violations and unacceptable input are thrown as 'ZstdError' +-- from the pull; once a pull has let any exception escape - decoder +-- error or the compressed source failing - every later pull rethrows +-- the same exception. The decompression context lives exactly as +-- long as the continuation. +withZstdSource :: ZstdLimits -> IO ByteString -> (IO ByteString -> IO a) -> IO a +withZstdSource limits compressedSource consume = + withDecoder $ \decoder -> do + stateRef <- newIORef (ZstdStreaming initialProgress) + consume (pullDecompressed limits compressedSource decoder stateRef) + +-- | What the pull source is doing between calls. The 'IORef' +-- holding this is the module's one piece of mutable state - the +-- same deliberate, documented boundary as the xz source. A failure +-- is remembered: a consumer that catches the exception and pulls +-- again gets it rethrown, never a phantom clean end of stream. +-- Held at 'SomeException', not 'ZstdError': the compressed source +-- throwing mid-pull leaves the transfer just as unfinishable as a +-- decoder error does. +data ZstdSourceState + = ZstdStreaming !DecodeProgress + | ZstdFailed !SomeException + | ZstdDrained + +-- | Where a decode stands between pulls. +data DecodeProgress = DecodeProgress + { -- | Compressed bytes handed over by the source but not yet + -- consumed by the decoder (the output buffer filled first). + pendingCompressed :: !ByteString, + -- | Decompressed bytes delivered so far, for the bound check. + producedBytes :: !Word64, + -- | The last @ZSTD_decompressStream@ call returned 0, or none + -- has run: the decoder sits exactly between frames, the only + -- state in which end of input is a clean end of stream. + atFrameBoundary :: !Bool, + -- | The compressed source has delivered its empty end chunk. + sourceExhausted :: !Bool + } + +initialProgress :: DecodeProgress +initialProgress = DecodeProgress BS.empty 0 True False + +-- | Produce the next decompressed chunk. +pullDecompressed :: ZstdLimits -> IO ByteString -> ZstdDecoder -> IORef ZstdSourceState -> IO ByteString +pullDecompressed limits compressedSource decoder stateRef = + dispatch =<< readIORef stateRef + where + bound = zstdMaxOutputBytes limits + + dispatch ZstdDrained = pure BS.empty + dispatch (ZstdFailed failure) = throwIO failure + dispatch (ZstdStreaming progress) = do + outcome <- tryPull (advance progress) + case outcome of + Left failure -> do + writeIORef stateRef (ZstdFailed failure) + throwIO failure + Right chunk -> pure chunk + + advance progress + | not (BS.null (pendingCompressed progress)) = decodeStep progress + | sourceExhausted progress = finishStep progress + | otherwise = do + chunk <- compressedSource + if BS.null chunk + then finishStep progress {sourceExhausted = True} + else decodeStep progress {pendingCompressed = chunk} + + decodeStep progress = + deliver progress =<< decodeChunk decoder (pendingCompressed progress) + + -- End of input. Between frames it is the clean end of stream. + -- Inside a frame, first flush what the decoder still buffers + -- (bounded by one block per call); a flush that yields nothing + -- short of a frame boundary means the remaining state is a + -- frame cut off mid-way or buffered trailing bytes - refuse. + finishStep progress + | atFrameBoundary progress = do + writeIORef stateRef ZstdDrained + pure BS.empty + | otherwise = do + outcome <- decodeChunk decoder BS.empty + case outcome of + Right step + | BS.null (stepOutput step) && not (stepAtBoundary step) -> + throwIO incompleteStreamError + _ -> deliver progress outcome + + deliver _ (Left err) = throwIO err + deliver progress (Right step) + | grown > bound = throwIO (ZstdOutputOverBound bound) + | BS.null (stepOutput step) = advance nextProgress + | otherwise = do + writeIORef stateRef (ZstdStreaming nextProgress) + pure (stepOutput step) + where + grown = producedBytes progress + fromIntegral (BS.length (stepOutput step)) + nextProgress = + progress + { pendingCompressed = stepRemaining step, + producedBytes = grown, + atFrameBoundary = stepAtBoundary step + } + +-- | 'try' at 'SomeException', monomorphic so the catch-all needs no +-- annotation at the call site. Any exception escaping a pull - the +-- compressed source failing included - leaves the transfer +-- unfinishable, and the only sound later answer is the same failure +-- again, so the caller latches whatever this catches. +tryPull :: IO ByteString -> IO (Either SomeException ByteString) +tryPull = try + +-- --------------------------------------------------------------------------- +-- Decoder plumbing (FFI boundary) +-- --------------------------------------------------------------------------- + +-- | A bracketed @ZSTD_DStream@ with the reusable buffers one +-- @ZSTD_decompressStream@ call needs. +data ZstdDecoder = ZstdDecoder + { decoderStream :: !(Ptr FFI.DStream), + decoderInBuffer :: !(Ptr (Buffer In)), + decoderOutBuffer :: !(Ptr (Buffer Out)), + decoderOutBytes :: !(Ptr Word8) + } + +-- | Output capacity per @ZSTD_decompressStream@ call: +-- @ZSTD_DStreamOutSize@, sized by libzstd so one call can always +-- flush a full decoded block. +outputBufferBytes :: Int +outputBufferBytes = fromIntegral FFI.dstreamOutSize + +-- | Run an action with a decompression context and its buffers, +-- freeing all four allocations on any exit. This bracket is the +-- point of driving the FFI directly: the context grows a window +-- buffer sized by the incoming frame header, and 'FFI.freeDStream' +-- here releases it the moment the action ends instead of at a GC +-- finalizer's leisure. +withDecoder :: (ZstdDecoder -> IO a) -> IO a +withDecoder action = + bracket (FFI.checkAlloc dstreamCreateSite FFI.createDStream) FFI.freeDStream $ \stream -> + bracket malloc free $ \inBuffer -> + bracket malloc free $ \outBuffer -> + bracket (mallocBytes outputBufferBytes) free $ \outBytes -> do + initRet <- FFI.initDStream stream + when (FFI.isError initRet) $ + throwIO (renderError dstreamInitSite (FFI.getErrorName initRet)) + action (ZstdDecoder stream inBuffer outBuffer outBytes) + +-- | What one @ZSTD_decompressStream@ call yielded. +data DecodeStep = DecodeStep + { -- | Decompressed bytes flushed into the output buffer. + stepOutput :: !ByteString, + -- | The unconsumed tail of the fed input. + stepRemaining :: !ByteString, + -- | The call returned 0, the library's only signal that a frame + -- is completely decoded AND fully flushed. + stepAtBoundary :: !Bool + } + +-- | One @ZSTD_decompressStream@ call: feed a chunk (empty for a pure +-- flush), collect whatever fits in the output buffer. The output is +-- copied out immediately, so the shared buffer can be reused. +decodeChunk :: ZstdDecoder -> ByteString -> IO (Either ZstdError DecodeStep) +decodeChunk decoder input = + supplyInput (decoderInBuffer decoder) input $ do + poke + (decoderOutBuffer decoder) + (Buffer (decoderOutBytes decoder) (fromIntegral outputBufferBytes) 0) + ret <- + FFI.decompressStream + (decoderStream decoder) + (decoderOutBuffer decoder) + (decoderInBuffer decoder) + if FFI.isError ret + then pure (Left (renderError decompressStreamSite (FFI.getErrorName ret))) + else do + -- The binding hides its FFI.Types module, so the filled and + -- consumed positions are read by peeking the whole (three + -- field) struct rather than its exposed peekPos helper. + outFilled <- bufPos <$> peek (decoderOutBuffer decoder) + inConsumed <- bufPos <$> peek (decoderInBuffer decoder) + output <- BS.packCStringLen (castPtr (decoderOutBytes decoder), fromIntegral outFilled) + pure (Right (DecodeStep output (BS.drop (fromIntegral inConsumed) input) (ret == 0))) + +-- | Point the input buffer at the chunk for the duration of the +-- action. An empty chunk becomes a null zero-length buffer - +-- libzstd reads nothing from a zero-size buffer, and this is the +-- shape its own examples use for a flush call. +supplyInput :: Ptr (Buffer In) -> ByteString -> IO a -> IO a +supplyInput inBuffer bytes action + | BS.null bytes = do + poke inBuffer (Buffer (nullPtr :: Ptr Word8) 0 0) + action + | otherwise = BSU.unsafeUseAsCStringLen bytes $ \(inPtr, inLen) -> do + poke inBuffer (Buffer inPtr (fromIntegral inLen) 0) + action diff --git a/test/Bzip2Test.hs b/test/Bzip2Test.hs new file mode 100644 --- /dev/null +++ b/test/Bzip2Test.hs @@ -0,0 +1,262 @@ +-- | Tests for the bounded bzip2 decoder. A separate suite because +-- the decoder lives in the nova-cache:bzip2 sublibrary; the fixtures +-- are real @bzip2 -9@ output embedded as hex, so no external tool +-- runs at test time. +module Main (main) where + +import Control.Exception (throwIO, try) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char (isDigit) +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified NovaCache.Bzip2 as Bzip2 +import System.Exit (exitFailure, exitSuccess) +import System.IO (hFlush, stdout) +import System.IO.Error (isUserError) + +-- --------------------------------------------------------------------------- +-- Harness (mirrors test/Main.hs) +-- --------------------------------------------------------------------------- + +test :: String -> IO Bool -> IO Bool +test name action = do + putStr (" " ++ name ++ "... ") + hFlush stdout + result <- action + putStrLn (if result then "OK" else "FAILED") + pure result + +assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool +assertEqual label expected actual + | expected == actual = pure True + | otherwise = do + putStrLn "" + putStrLn (" " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual: " ++ show actual) + pure False + +assertTrue :: String -> Bool -> IO Bool +assertTrue _ True = pure True +assertTrue label False = do + putStrLn "" + putStrLn (" " ++ label ++ ": expected True") + pure False + +-- --------------------------------------------------------------------------- +-- Fixtures +-- --------------------------------------------------------------------------- + +-- | Decode a hex fixture literal. Fixtures are constants, so a +-- malformed one decodes short and the assertions fail loudly. +unhex :: String -> ByteString +unhex = BS.pack . pairs + where + pairs (hi : lo : rest) = case (hexVal hi, hexVal lo) of + (Just h, Just l) -> fromIntegral (h * 16 + l) : pairs rest + _ -> [] + pairs _ = [] + hexVal c + | isDigit c = Just (fromEnum c - fromEnum '0') + | c >= 'a' && c <= 'f' = Just (fromEnum c - fromEnum 'a' + 10) + | otherwise = Nothing + +-- | @bzip2 -9@ of "nova-cache bzip2 fixture\n" (25 bytes of output). +textBz2 :: ByteString +textBz2 = + unhex + "425a6839314159265359c032547900000859800010400210003b61d750200022\ + \8326862687a85309a680d3112446fdca60e188c3b44780043e2ee48a70a12180\ + \64a8f2" + +-- | The bytes 'textBz2' decompresses to. +textPlain :: ByteString +textPlain = "nova-cache bzip2 fixture\n" + +-- | @bzip2 -9@ of 65536 zero bytes: 43 bytes in, 64 KiB out - the +-- expansion shape the output bound exists for. +zerosBz2 :: ByteString +zerosBz2 = + unhex + "425a6839314159265359d771e9eb000080c000c000000820003080291a01a403\ + \8bb9229c28486bb8f4f580" + +-- | Output size of 'zerosBz2'. +zerosLength :: Word +zerosLength = 65536 + +-- | A generous bound for the happy paths. +openLimits :: Bzip2.Bzip2Limits +openLimits = boundedTo (1024 * 1024) + +-- | Limits with the given output bound. +boundedTo :: Word -> Bzip2.Bzip2Limits +boundedTo bound = Bzip2.Bzip2Limits {Bzip2.bzip2MaxOutputBytes = fromIntegral bound} + +-- | Split a byte string into fixed-size pieces. +chunksOf :: Int -> ByteString -> [ByteString] +chunksOf n bs + | BS.null bs = [] + | otherwise = case BS.splitAt n bs of + (piece, rest) -> piece : chunksOf n rest + +-- | A chunk source over a fixed list (empty chunk on exhaustion), +-- for feeding 'Bzip2.withBzip2Source'. +listSource :: [ByteString] -> IO (IO ByteString) +listSource chunks = scriptedSource (map pure chunks) + +-- | A chunk source that performs the given actions in order and +-- returns the empty chunk after they run out; an action may throw, +-- which is how the errored-source tests stage a failure. +scriptedSource :: [IO ByteString] -> IO (IO ByteString) +scriptedSource steps = do + remaining <- newIORef steps + pure $ do + held <- readIORef remaining + case held of + [] -> pure BS.empty + (act : rest) -> do + writeIORef remaining rest + act + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +main :: IO () +main = do + putStrLn "nova-cache bzip2 test suite" + putStrLn "===========================" + results <- + sequence + [ test "roundtrip under the exact output bound" $ do + -- NarSize is exact, so output == bound must pass. + outcome <- Bzip2.decompress (boundedTo (fromIntegral (BS.length textPlain))) textBz2 + assertEqual "text fixture" (Right textPlain) outcome, + test "high-expansion input inflates fully under an open bound" $ do + outcome <- Bzip2.decompress openLimits zerosBz2 + case outcome of + Left err -> do + putStrLn (" unexpected error: " ++ show err) + pure False + Right out -> do + ok1 <- assertEqual "length" zerosLength (fromIntegral (BS.length out)) + ok2 <- assertTrue "all zero" (BS.all (== 0) out) + pure (ok1 && ok2), + test "output over the bound is refused" $ do + outcome <- Bzip2.decompress (boundedTo 1000) zerosBz2 + assertEqual "far bound" (Left (Bzip2.Bzip2OutputOverBound 1000)) outcome, + test "one byte under the true size is refused" $ do + outcome <- Bzip2.decompress (boundedTo (zerosLength - 1)) zerosBz2 + assertEqual + "tight bound" + (Left (Bzip2.Bzip2OutputOverBound (fromIntegral (zerosLength - 1)))) + outcome, + test "garbage input is a stream error" $ do + outcome <- Bzip2.decompress openLimits "not a bzip2 stream" + assertTrue "garbage" (isStreamError outcome), + test "a truncated stream is a stream error" $ do + outcome <- Bzip2.decompress openLimits (BS.take 20 textBz2) + assertTrue "truncated" (isStreamError outcome), + test "concatenated streams decode as one output" $ do + -- Upstream's sink re-initializes at stream end while input + -- remains; two streams back-to-back are one valid input. + outcome <- Bzip2.decompress openLimits (textBz2 <> textBz2) + assertEqual "two text streams" (Right (textPlain <> textPlain)) outcome, + -- Upstream Nix decompresses bzip2 through libarchive, which + -- ignores whatever follows the last stream unless it begins + -- another one. Measured against libarchive 3.8.2 driven exactly + -- as Nix drives it (filter_all + format_raw + format_empty): all + -- four of these decode to the payload there, and all four were + -- refused here before. + test "trailing bytes that are not a stream end the output" $ do + let trailers = ["garbage!", "\0\0\0\0", "\n", "BZh"] + results <- + mapM + ( \trailer -> do + outcome <- Bzip2.decompress openLimits (textBz2 <> trailer) + assertEqual ("trailer " <> show trailer) (Right textPlain) outcome + ) + trailers + pure (and results), + test "a truncated concatenated stream is still refused" $ do + -- The safe half of the rule: bytes that DO begin a stream are + -- decoded as one, and a truncated one fails rather than + -- silently truncating the output. + outcome <- Bzip2.decompress openLimits (textBz2 <> BS.take 40 textBz2) + assertTrue "truncated second stream" (isStreamError outcome), + test "withBzip2Source decompresses a chunked source" $ do + source <- listSource (chunksOf 7 textBz2) + out <- Bzip2.withBzip2Source openLimits source drainSource + assertEqual "streamed output" textPlain out, + test "withBzip2Source decompresses one-byte chunks" $ do + source <- listSource (chunksOf 1 textBz2) + out <- Bzip2.withBzip2Source openLimits source drainSource + assertEqual "byte-fed output" textPlain out, + test "withBzip2Source succeeds at the exact output bound" $ do + source <- listSource (chunksOf 16 zerosBz2) + out <- + Bzip2.withBzip2Source + (boundedTo (fromIntegral zerosLength)) + source + drainSource + assertEqual "streamed length" zerosLength (fromIntegral (BS.length out)), + test "withBzip2Source throws past the output bound" $ do + source <- listSource (chunksOf 16 zerosBz2) + outcome <- + try (Bzip2.withBzip2Source (boundedTo 1000) source drainSource) :: + IO (Either Bzip2.Bzip2Error ByteString) + assertEqual "thrown" (Left (Bzip2.Bzip2OutputOverBound 1000)) outcome, + test "withBzip2Source keeps returning empty after the end" $ do + source <- listSource [textBz2] + ends <- Bzip2.withBzip2Source openLimits source $ \pull -> do + _ <- drainSource pull + endA <- pull + endB <- pull + pure (endA, endB) + assertEqual "stable end" ("", "") ends, + test "a thrown decode error repeats on later pulls" $ do + source <- listSource (chunksOf 16 zerosBz2) + Bzip2.withBzip2Source (boundedTo 1000) source $ \pull -> do + first <- try (drainSource pull) :: IO (Either Bzip2.Bzip2Error ByteString) + again <- try pull :: IO (Either Bzip2.Bzip2Error ByteString) + ok1 <- assertEqual "first pull" (Left (Bzip2.Bzip2OutputOverBound 1000)) first + ok2 <- assertEqual "later pull" (Left (Bzip2.Bzip2OutputOverBound 1000)) again + pure (ok1 && ok2), + test "a source failure never becomes a clean end" $ do + -- The source delivers a full stream, errors on the pull + -- that would confirm the end, then reads as exhausted. An + -- unlatched decoder would answer the retry with the empty + -- chunk - a failed transfer posing as complete output. + source <- + scriptedSource [pure textBz2, throwIO (userError sourceFailureText)] + Bzip2.withBzip2Source openLimits source $ \pull -> do + chunk <- pull + first <- try pull :: IO (Either IOError ByteString) + again <- try pull :: IO (Either IOError ByteString) + ok1 <- assertEqual "decoded chunk" textPlain chunk + ok2 <- assertTrue "first pull throws" (either isUserError (const False) first) + ok3 <- assertTrue "later pull throws" (either isUserError (const False) again) + pure (ok1 && ok2 && ok3) + ] + if and results + then do + putStrLn "" + putStrLn ("All " ++ show (length results) ++ " tests passed.") + exitSuccess + else do + putStrLn "" + putStrLn "Some tests FAILED." + exitFailure + where + sourceFailureText = "staged transfer failure" + isStreamError outcome = case outcome of + Left (Bzip2.Bzip2StreamError _) -> True + _ -> False + drainSource pull = go [] + where + go acc = do + chunk <- pull + if BS.null chunk + then pure (BS.concat (reverse acc)) + else go (chunk : acc) diff --git a/test/CompressionTest.hs b/test/CompressionTest.hs deleted file mode 100644 --- a/test/CompressionTest.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Main (main) where - -import qualified Data.ByteString as BS -import qualified NovaCache.Compression as Compression -import System.Exit (exitFailure, exitSuccess) -import System.IO (hFlush, stdout) - --- | Run a named test, short-circuit on first failure. -test :: String -> IO Bool -> IO Bool -test name action = do - putStr (" " ++ name ++ "... ") - hFlush stdout - result <- action - if result - then do - putStrLn "OK" - pure True - else do - putStrLn "FAILED" - pure False - --- | Assert equality. -assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool -assertEqual label expected actual - | expected == actual = pure True - | otherwise = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected: " ++ show expected) - putStrLn (" actual: " ++ show actual) - pure False - --- | Assert a Bool is True. -assertTrue :: String -> Bool -> IO Bool -assertTrue _ True = pure True -assertTrue label False = do - putStrLn "" - putStrLn (" " ++ label ++ ": expected True") - pure False - --- | Assert a Right value matches. -assertRight :: (Eq a, Show a) => String -> a -> Either String a -> IO Bool -assertRight label expected (Right actual) = assertEqual label expected actual -assertRight label _ (Left err) = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected Right, got Left: " ++ err) - pure False - --- | Assert a Left (error case). -assertLeft :: (Show a) => String -> Either String a -> IO Bool -assertLeft _ (Left _) = pure True -assertLeft label (Right val) = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected Left, got Right: " ++ show val) - pure False - -main :: IO () -main = do - putStrLn "nova-cache compression tests" - putStrLn "==============================" - putStrLn "" - putStrLn "Compression:" - ok1 <- - test "compress/decompress roundtrip" $ do - let input = BS.pack [72, 101, 108, 108, 111, 32, 87, 111, 114, 108, 100] - compressed = Compression.compressXz input - result <- Compression.decompressXz compressed - assertRight "roundtrip" input result - ok2 <- - test "compress/decompress roundtrip (empty)" $ do - let compressed = Compression.compressXz BS.empty - result <- Compression.decompressXz compressed - assertRight "roundtrip empty" BS.empty result - ok3 <- - test "compressed is smaller for repetitive data" $ - let input = BS.replicate 10000 0x42 - compressed = Compression.compressXz input - in assertTrue "smaller" (BS.length compressed < BS.length input) - ok4 <- - test "decompress invalid data returns Left" $ do - result <- Compression.decompressXz (BS.pack [0, 1, 2, 3]) - assertLeft "invalid xz" result - putStrLn "" - if ok1 && ok2 && ok3 && ok4 - then putStrLn "All compression tests passed." >> exitSuccess - else putStrLn "Some compression tests failed." >> exitFailure diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,811 +1,1770 @@ -module Main (main) where - -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.ByteArray (convert) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import Data.List (sort) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified NovaCache.Base32 as Base32 -import qualified NovaCache.Hash as Hash -import qualified NovaCache.NAR as NAR -import qualified NovaCache.NarInfo as NarInfo -import qualified NovaCache.Signing as Signing -import qualified NovaCache.Store as Store -import qualified NovaCache.StorePath as StorePath -import qualified NovaCache.Validate as Validate -import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) -import System.Exit (exitFailure, exitSuccess) -import System.IO (hFlush, stdout) - --- --------------------------------------------------------------------------- --- Test harness (hand-rolled, no framework) --- --------------------------------------------------------------------------- - --- | Run a named test, short-circuit on first failure. -test :: String -> IO Bool -> IO Bool -test name action = do - putStr (" " ++ name ++ "... ") - hFlush stdout - result <- action - if result - then do - putStrLn "OK" - pure True - else do - putStrLn "FAILED" - pure False - --- | Assert equality. -assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool -assertEqual label expected actual - | expected == actual = pure True - | otherwise = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected: " ++ show expected) - putStrLn (" actual: " ++ show actual) - pure False - --- | Assert a Right value matches. -assertRight :: (Eq a, Show a) => String -> a -> Either String a -> IO Bool -assertRight label expected (Right actual) = assertEqual label expected actual -assertRight label _ (Left err) = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected Right, got Left: " ++ err) - pure False - --- | Assert a Left (error case). -assertLeft :: (Show a) => String -> Either String a -> IO Bool -assertLeft _ (Left _) = pure True -assertLeft label (Right val) = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected Left, got Right: " ++ show val) - pure False - --- | Assert a Bool is True. -assertTrue :: String -> Bool -> IO Bool -assertTrue _ True = pure True -assertTrue label False = do - putStrLn "" - putStrLn (" " ++ label ++ ": expected True") - pure False - --- | Assert a Bool is False. -assertFalse :: String -> Bool -> IO Bool -assertFalse _ False = pure True -assertFalse label True = do - putStrLn "" - putStrLn (" " ++ label ++ ": expected False") - pure False - --- | Run a group of tests, stopping at first failure. -runGroup :: String -> [IO Bool] -> IO Bool -runGroup name tests = do - putStrLn (name ++ ":") - go tests - where - go [] = pure True - go (t : ts) = do - ok <- t - if ok then go ts else pure False - --- | Run all test groups. -runAll :: [IO Bool] -> IO () -runAll groups = do - results <- sequence groups - let passed = length (filter id results) - total = length results - putStrLn "" - if and results - then do - putStrLn ("All " ++ show total ++ " groups passed.") - exitSuccess - else do - putStrLn (show passed ++ "/" ++ show total ++ " groups passed.") - exitFailure - -main :: IO () -main = do - putStrLn "nova-cache test suite" - putStrLn "======================" - putStrLn "" - runAll - [ testBase32, - testHash, - testStorePath, - testNAR, - testNarInfo, - testSigning, - testFileStore, - testValidate - ] - --- --------------------------------------------------------------------------- --- Base32 tests --- --------------------------------------------------------------------------- - -testBase32 :: IO Bool -testBase32 = - runGroup - "Base32" - [ test "encode empty" $ - assertEqual "encode empty" "" (Base32.encode BS.empty), - test "decode empty" $ - assertRight "decode empty" BS.empty (Base32.decode ""), - test "encode/decode roundtrip (single byte)" $ - let bs = BS.singleton 0xFF - encoded = Base32.encode bs - in assertRight "roundtrip 0xFF" bs (Base32.decode encoded), - test "encode/decode roundtrip (known SHA-256)" $ - let bs = BS.pack [0 .. 31] - encoded = Base32.encode bs - in assertRight "roundtrip 32 bytes" bs (Base32.decode encoded), - test "encode/decode roundtrip (all zeros)" $ - let bs = BS.replicate 32 0 - encoded = Base32.encode bs - in assertRight "roundtrip zeros" bs (Base32.decode encoded), - test "encode/decode roundtrip (all 0xFF)" $ - let bs = BS.replicate 32 0xFF - encoded = Base32.encode bs - in assertRight "roundtrip 0xFF*32" bs (Base32.decode encoded), - test "decode invalid character" $ - assertLeft "invalid char" (Base32.decode "hello!"), - test "encode length for 32 bytes" $ - -- 32 bytes gives ceil(32*8/5) = ceil(51.2) = 52 chars - let bs = BS.replicate 32 0x42 - encoded = Base32.encode bs - in assertEqual "encoded length" 52 (T.length encoded), - test "nix known vector" $ - -- SHA-256 of empty string in nix-base32 should be 52 chars - let Hash.NixHash raw = Hash.hashBytes BS.empty - encoded = Base32.encode raw - in assertEqual "sha256 of empty in base32 length" 52 (T.length encoded) - ] - --- --------------------------------------------------------------------------- --- Hash tests --- --------------------------------------------------------------------------- - -testHash :: IO Bool -testHash = - runGroup - "Hash" - [ test "hashBytes deterministic" $ - let h1 = Hash.hashBytes (BS.pack [1, 2, 3]) - h2 = Hash.hashBytes (BS.pack [1, 2, 3]) - in assertEqual "deterministic" h1 h2, - test "hashBytes different inputs differ" $ - let h1 = Hash.hashBytes (BS.pack [1, 2, 3]) - h2 = Hash.hashBytes (BS.pack [4, 5, 6]) - in assertTrue "different" (h1 /= h2), - test "hashBytes is 32 bytes" $ - let Hash.NixHash raw = Hash.hashBytes BS.empty - in assertEqual "32 bytes" 32 (BS.length raw), - test "formatNixHash prefix" $ - let formatted = Hash.formatNixHash (Hash.hashBytes BS.empty) - in assertTrue "sha256: prefix" (T.isPrefixOf "sha256:" formatted), - test "formatNixHash/parseNixHash roundtrip" $ - let h = Hash.hashBytes (BS.pack [42]) - formatted = Hash.formatNixHash h - in assertRight "roundtrip" h (Hash.parseNixHash formatted), - test "parseNixHash bad prefix" $ - assertLeft "bad prefix" (Hash.parseNixHash "md5:abc"), - test "parseNixHash bad base32" $ - assertLeft "bad base32" (Hash.parseNixHash "sha256:!!invalid!!") - ] - --- --------------------------------------------------------------------------- --- StorePath tests --- --------------------------------------------------------------------------- - -testStorePath :: IO Bool -testStorePath = - runGroup - "StorePath" - [ test "parse/render roundtrip" $ - let storeDir = StorePath.defaultStoreDir - input = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0" - in case StorePath.parseStorePath storeDir input of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right sp -> - assertEqual "roundtrip" input (StorePath.renderStorePath storeDir sp), - test "parse basename only" $ - let storeDir = StorePath.defaultStoreDir - basename = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0" - in case StorePath.parseStorePath storeDir basename of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right sp -> - assertEqual "basename" basename (StorePath.storePathBaseName sp), - test "parse extracts hash" $ - let storeDir = StorePath.defaultStoreDir - input = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-test" - in case StorePath.parseStorePath storeDir input of - Left _ -> pure False - Right sp -> - assertEqual "hash" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" (StorePath.storePathHashString sp), - test "reject too short" $ - let storeDir = StorePath.defaultStoreDir - in assertLeft "too short" (StorePath.parseStorePath storeDir "abc-def"), - test "reject empty name" $ - let storeDir = StorePath.defaultStoreDir - in assertLeft "empty name" (StorePath.parseStorePath storeDir "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-"), - test "reject invalid name chars" $ - let storeDir = StorePath.defaultStoreDir - input = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello world" - in assertLeft "invalid chars" (StorePath.parseStorePath storeDir input) - ] - --- --------------------------------------------------------------------------- --- NAR tests --- --------------------------------------------------------------------------- - -testNAR :: IO Bool -testNAR = - runGroup - "NAR" - [ test "serialise/deserialise roundtrip (regular file)" $ - let entry = NAR.NarRegular False (BS.pack [72, 101, 108, 108, 111]) - serialised = NAR.serialise entry - in assertRight "roundtrip regular" entry (NAR.deserialise serialised), - test "serialise/deserialise roundtrip (empty file)" $ - let entry = NAR.NarRegular False BS.empty - serialised = NAR.serialise entry - in assertRight "roundtrip empty" entry (NAR.deserialise serialised), - test "serialise/deserialise roundtrip (executable)" $ - let entry = NAR.NarRegular True (BS.pack [0x7F, 0x45, 0x4C, 0x46]) - serialised = NAR.serialise entry - in assertRight "roundtrip exec" entry (NAR.deserialise serialised), - test "serialise/deserialise roundtrip (symlink)" $ - let entry = NAR.NarSymlink "/usr/bin/hello" - serialised = NAR.serialise entry - in assertRight "roundtrip symlink" entry (NAR.deserialise serialised), - test "serialise/deserialise roundtrip (directory)" $ - let entry = - NAR.NarDirectory - [ ("bar", NAR.NarRegular False (BS.pack [2])), - ("foo", NAR.NarRegular False (BS.pack [1])) - ] - serialised = NAR.serialise entry - in assertRight "roundtrip dir" entry (NAR.deserialise serialised), - test "serialise/deserialise roundtrip (nested directory)" $ - let entry = - NAR.NarDirectory - [ ("bin", NAR.NarDirectory [("hello", NAR.NarRegular True (BS.pack [42]))]), - ("lib", NAR.NarSymlink "../lib64") - ] - serialised = NAR.serialise entry - in assertRight "roundtrip nested" entry (NAR.deserialise serialised), - test "directory entries sorted" $ - let entry = - NAR.NarDirectory - [ ("zebra", NAR.NarRegular False BS.empty), - ("alpha", NAR.NarRegular False BS.empty) - ] - serialised = NAR.serialise entry - in case NAR.deserialise serialised of - Left err -> do - putStrLn (" deserialise failed: " ++ err) - pure False - Right (NAR.NarDirectory entries) -> - assertEqual "sorted" ["alpha", "zebra"] (map fst entries) - Right other -> do - putStrLn (" expected directory, got: " ++ show other) - pure False, - test "narHash deterministic" $ - let entry = NAR.NarRegular False (BS.pack [1, 2, 3]) - h1 = NAR.narHash entry - h2 = NAR.narHash entry - in assertEqual "deterministic hash" h1 h2, - test "narHash differs for different content" $ - let h1 = NAR.narHash (NAR.NarRegular False (BS.pack [1])) - h2 = NAR.narHash (NAR.NarRegular False (BS.pack [2])) - in assertTrue "different hashes" (h1 /= h2), - test "deserialise garbage fails" $ - assertLeft "garbage" (NAR.deserialise (BS.pack [0, 0, 0, 0, 0, 0, 0, 0])) - ] - --- --------------------------------------------------------------------------- --- NarInfo tests --- --------------------------------------------------------------------------- - -sampleNarInfoText :: Text -sampleNarInfoText = - T.unlines - [ "StorePath: /nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0", - "URL: nar/1234abcd.nar.xz", - "Compression: xz", - "FileHash: sha256:abcdef1234567890", - "FileSize: 12345", - "NarHash: sha256:fedcba0987654321", - "NarSize: 67890", - "References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0 bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-glibc-2.38", - "Deriver: cccccccccccccccccccccccccccccccc-hello-1.0.drv", - "Sig: cache.example.com:c2lnbmF0dXJl", - "Sig: backup.example.com:YW5vdGhlcnNpZw==" - ] - -testNarInfo :: IO Bool -testNarInfo = - runGroup - "NarInfo" - [ test "parse sample narinfo" $ - case NarInfo.parseNarInfo sampleNarInfoText of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right ni -> do - ok1 <- assertEqual "storePath" "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0" (NarInfo.niStorePath ni) - ok2 <- assertEqual "url" "nar/1234abcd.nar.xz" (NarInfo.niUrl ni) - ok3 <- assertEqual "compression" "xz" (NarInfo.niCompression ni) - ok4 <- assertEqual "fileSize" 12345 (NarInfo.niFileSize ni) - ok5 <- assertEqual "narSize" 67890 (NarInfo.niNarSize ni) - ok6 <- assertEqual "refs count" 2 (length (NarInfo.niReferences ni)) - ok7 <- assertEqual "deriver" (Just "cccccccccccccccccccccccccccccccc-hello-1.0.drv") (NarInfo.niDeriver ni) - ok8 <- assertEqual "sigs count" 2 (length (NarInfo.niSigs ni)) - pure (ok1 && ok2 && ok3 && ok4 && ok5 && ok6 && ok7 && ok8), - test "parse/render roundtrip" $ - case NarInfo.parseNarInfo sampleNarInfoText of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right ni -> - let rendered = NarInfo.renderNarInfo ni - in case NarInfo.parseNarInfo rendered of - Left err -> do - putStrLn (" re-parse failed: " ++ err) - pure False - Right reparsed -> - assertEqual "roundtrip" ni reparsed, - test "parse minimal narinfo (no optional fields)" $ - let minimal = - T.unlines - [ "StorePath: /nix/store/aaaa-test", - "URL: nar/test.nar.xz", - "Compression: xz", - "FileHash: sha256:abc", - "FileSize: 100", - "NarHash: sha256:def", - "NarSize: 200", - "References: " - ] - in case NarInfo.parseNarInfo minimal of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right ni -> do - ok1 <- assertEqual "deriver" Nothing (NarInfo.niDeriver ni) - ok2 <- assertEqual "sigs" [] (NarInfo.niSigs ni) - ok3 <- assertEqual "ca" Nothing (NarInfo.niCA ni) - ok4 <- assertEqual "refs" [] (NarInfo.niReferences ni) - pure (ok1 && ok2 && ok3 && ok4), - test "parse missing required key fails" $ - let incomplete = T.unlines ["StorePath: /nix/store/aaaa-test", "URL: nar/test.nar.xz"] - in assertLeft "missing key" (NarInfo.parseNarInfo incomplete), - test "parse bad integer fails" $ - let bad = - T.unlines - [ "StorePath: /nix/store/aaaa-test", - "URL: nar/test.nar.xz", - "Compression: xz", - "FileHash: sha256:abc", - "FileSize: not-a-number", - "NarHash: sha256:def", - "NarSize: 200", - "References: " - ] - in assertLeft "bad integer" (NarInfo.parseNarInfo bad) - ] - --- --------------------------------------------------------------------------- --- Signing tests --- --------------------------------------------------------------------------- - -testSigning :: IO Bool -testSigning = - runGroup - "Signing" - [ test "fingerprint format" $ - let ni = mkTestNarInfo - fp = Signing.fingerprint ni - in do - ok1 <- assertTrue "starts with 1;" (T.isPrefixOf "1;" fp) - ok2 <- assertTrue "contains storePath" (T.isInfixOf "/nix/store/" fp) - pure (ok1 && ok2), - test "fingerprint renders references as full store paths" $ - let ni = mkTestNarInfo {NarInfo.niReferences = ["00000000000000000000000000000000-glibc-2.40"]} - fp = Signing.fingerprint ni - in assertTrue - "reference is a full /nix/store path in the fingerprint" - (T.isInfixOf "/nix/store/00000000000000000000000000000000-glibc-2.40" fp), - test "parseSecretKey valid" $ - let keyBytes = BS.pack ([1 .. 32] ++ [33 .. 64]) - keyB64 = TE.decodeUtf8 (B64.encode keyBytes) - keyStr = "test-key:" <> keyB64 - in case Signing.parseSecretKey keyStr of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right sk -> - assertEqual "key name" "test-key" (Signing.skName sk), - test "parsePublicKey valid" $ - let keyBytes = BS.pack [1 .. 32] - keyB64 = TE.decodeUtf8 (B64.encode keyBytes) - keyStr = "test-key:" <> keyB64 - in case Signing.parsePublicKey keyStr of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right pk -> - assertEqual "key name" "test-key" (Signing.pkName pk), - test "parseSecretKey no colon fails" $ - assertLeft "no colon" (Signing.parseSecretKey "nokeyname"), - test "parsePublicKey wrong size fails" $ - let keyStr = "test-key:" <> TE.decodeUtf8 (B64.encode (BS.pack [1 .. 16])) - in assertLeft "wrong size" (Signing.parsePublicKey keyStr), - test "sign/verify roundtrip" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - ni = mkTestNarInfo - case Signing.sign sk ni of - Left err -> do - putStrLn (" sign failed: " ++ err) - pure False - Right sig -> - assertTrue "verify passes" (Signing.verify pk ni sig), - test "verify rejects tampered narinfo" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - ni = mkTestNarInfo - case Signing.sign sk ni of - Left err -> do - putStrLn (" sign failed: " ++ err) - pure False - Right sig -> - let tampered = ni {NarInfo.niNarSize = 999999} - in assertFalse "verify rejects tampered" (Signing.verify pk tampered sig), - test "toPublicKey derives the verifying key" $ do - sk <- generateTestSecretKey - case Signing.toPublicKey sk of - Left err -> do - putStrLn (" toPublicKey failed: " ++ err) - pure False - Right pk -> do - okName <- assertEqual "key name carried over" (Signing.skName sk) (Signing.pkName pk) - okBytes <- assertEqual "matches the stored public half" (BS.drop 32 (Signing.skBytes sk)) (Signing.pkBytes pk) - case Signing.sign sk mkTestNarInfo of - Left err -> do - putStrLn (" sign failed: " ++ err) - pure False - Right sig -> do - okVerify <- assertTrue "derived key verifies a signature" (Signing.verify pk mkTestNarInfo sig) - pure (okName && okBytes && okVerify), - test "renderPublicKey round-trips through parsePublicKey" $ do - sk <- generateTestSecretKey - case Signing.toPublicKey sk of - Left err -> do - putStrLn (" toPublicKey failed: " ++ err) - pure False - Right pk -> case Signing.parsePublicKey (Signing.renderPublicKey pk) of - Left err -> do - putStrLn (" parse failed: " ++ err) - pure False - Right reparsed -> assertEqual "round-trip" pk reparsed, - test "normalizeKeyText strips BOM and whitespace" $ do - ok1 <- assertEqual "BOM stripped" "test-key:abc" (Signing.normalizeKeyText ("\xFEFF" <> "test-key:abc")) - ok2 <- assertEqual "CRLF stripped" "test-key:abc" (Signing.normalizeKeyText "test-key:abc\r\n") - ok3 <- assertEqual "spaces stripped" "test-key:abc" (Signing.normalizeKeyText " test-key:abc ") - ok4 <- assertEqual "clean text unchanged" "test-key:abc" (Signing.normalizeKeyText "test-key:abc") - pure (ok1 && ok2 && ok3 && ok4) - ] - --- | Create a test NarInfo for signing tests. -mkTestNarInfo :: NarInfo.NarInfo -mkTestNarInfo = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/aaaa-hello-1.0", - NarInfo.niUrl = "nar/test.nar.xz", - NarInfo.niCompression = "xz", - NarInfo.niFileHash = "sha256:abc", - NarInfo.niFileSize = 100, - NarInfo.niNarHash = "sha256:def", - NarInfo.niNarSize = 200, - NarInfo.niReferences = ["aaaa-hello-1.0"], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - --- --------------------------------------------------------------------------- --- FileStore tests --- --------------------------------------------------------------------------- - -testFileStore :: IO Bool -testFileStore = - runGroup - "FileStore" - [ test "narinfo write/read roundtrip" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - let hashKey = "testhash123" - content = TE.encodeUtf8 ("StorePath: /nix/store/test\n" :: Text) - wOk <- Store.writeNarInfo store hashKey content - result <- Store.readNarInfo store hashKey - removeDirectoryRecursive tmpDir - ok1 <- assertTrue "write succeeded" wOk - ok2 <- assertEqual "narinfo roundtrip" (Just content) result - pure (ok1 && ok2), - test "nar write/read roundtrip" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - let fileName = "test.nar.xz" - content = BS.pack [1, 2, 3, 4, 5] - wOk <- Store.writeNar store fileName content - result <- Store.readNar store fileName - removeDirectoryRecursive tmpDir - ok1 <- assertTrue "write succeeded" wOk - ok2 <- assertEqual "nar roundtrip" (Just content) result - pure (ok1 && ok2), - test "read nonexistent returns Nothing" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - result <- Store.readNarInfo store "nonexistent" - removeDirectoryRecursive tmpDir - assertEqual "not found" Nothing result, - test "cacheInfo defaults" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - let info = Store.getCacheInfo store - removeDirectoryRecursive tmpDir - ok1 <- assertEqual "storeDir" "/nix/store" (Store.ciStoreDir info) - ok2 <- assertTrue "wantMassQuery" (Store.ciWantMassQuery info) - ok3 <- assertEqual "priority" 50 (Store.ciPriority info) - pure (ok1 && ok2 && ok3), - test "sanitizePath rejects traversal" $ - assertEqual "dotdot" Nothing (Store.sanitizePath ".."), - test "sanitizePath rejects slash" $ - assertEqual "slash" Nothing (Store.sanitizePath "../../etc/passwd"), - test "sanitizePath rejects backslash" $ - assertEqual "backslash" Nothing (Store.sanitizePath "..\\..\\etc\\passwd"), - test "sanitizePath rejects empty" $ - assertEqual "empty" Nothing (Store.sanitizePath ""), - test "sanitizePath accepts valid hash" $ - assertEqual "valid" (Just "abc123def456") (Store.sanitizePath "abc123def456"), - test "sanitizePath rejects windows device name" $ - assertEqual "device nul" Nothing (Store.sanitizePath "nul"), - test "sanitizePath rejects dotfile" $ - assertEqual "dotfile" Nothing (Store.sanitizePath ".hidden"), - test "read rejects traversal" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - result <- Store.readNarInfo store "../../etc/passwd" - removeDirectoryRecursive tmpDir - assertEqual "blocked" Nothing result, - test "writeNarInfo rejects traversal" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - ok <- Store.writeNarInfo store "../../etc/passwd" "bad" - removeDirectoryRecursive tmpDir - assertFalse "write rejected" ok, - test "writeNar rejects traversal" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - ok <- Store.writeNar store "../escape.nar" "bad" - removeDirectoryRecursive tmpDir - assertFalse "write rejected" ok, - test "listNarInfoHashes returns stored hashes" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - _ <- Store.writeNarInfo store "hash1" "content1" - _ <- Store.writeNarInfo store "hash2" "content2" - hashes <- Store.listNarInfoHashes store - removeDirectoryRecursive tmpDir - let sorted = sort hashes - assertEqual "listed hashes" ["hash1", "hash2"] sorted, - test "listNarInfoHashes empty store" $ do - tmpDir <- createTestDir - store <- Store.newFileStore tmpDir - hashes <- Store.listNarInfoHashes store - removeDirectoryRecursive tmpDir - assertEqual "empty" [] hashes - ] - --- --------------------------------------------------------------------------- --- Validate tests --- --------------------------------------------------------------------------- - --- | Bytes whose SHA-256 is used as the NarHash in 'mkValidNarInfo'. -validNarBytes :: ByteString -validNarBytes = BS.pack [1, 2, 3, 4, 5] - --- | Bytes whose SHA-256 is used as the FileHash in 'mkValidNarInfo'. -validFileBytes :: ByteString -validFileBytes = BS.pack [10, 20, 30, 40, 50] - --- | A narinfo that passes all field validation. -mkValidNarInfo :: NarInfo.NarInfo -mkValidNarInfo = - NarInfo.NarInfo - { NarInfo.niStorePath = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0", - NarInfo.niUrl = "nar/test.nar.xz", - NarInfo.niCompression = "xz", - NarInfo.niFileHash = Hash.formatNixHash (Hash.hashBytes validFileBytes), - NarInfo.niFileSize = 5, - NarInfo.niNarHash = Hash.formatNixHash (Hash.hashBytes validNarBytes), - NarInfo.niNarSize = 5, - NarInfo.niReferences = ["aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0"], - NarInfo.niDeriver = Nothing, - NarInfo.niSigs = [], - NarInfo.niCA = Nothing - } - -testValidate :: IO Bool -testValidate = - runGroup - "Validate" - [ test "validateNarInfo valid" $ - assertEqual - "valid narinfo" - (Right mkValidNarInfo) - (Validate.validateNarInfo mkValidNarInfo), - test "validateNarInfo negative FileSize" $ - let ni = mkValidNarInfo {NarInfo.niFileSize = -1} - in assertEqual - "negative filesize" - (Left [Validate.NegativeFileSize (-1)]) - (Validate.validateNarInfo ni), - test "validateNarInfo negative NarSize" $ - let ni = mkValidNarInfo {NarInfo.niNarSize = -1} - in assertEqual - "negative narsize" - (Left [Validate.NegativeNarSize (-1)]) - (Validate.validateNarInfo ni), - test "validateNarInfo derivation StorePath rejected" $ - let drvPath = "/nix/store/abc12345678901234567890123456789-foo.drv" - ni = mkValidNarInfo {NarInfo.niStorePath = drvPath} - in case Validate.validateNarInfo ni of - Left [Validate.DerivationStorePath raw] -> - assertEqual "raw value" drvPath raw - other -> do - putStrLn (" expected Left [DerivationStorePath ..], got: " ++ show other) - pure False, - test "validateNarInfo bad StorePath" $ - let ni = mkValidNarInfo {NarInfo.niStorePath = "not-a-store-path"} - in case Validate.validateNarInfo ni of - Left [Validate.InvalidStorePath raw _] -> - assertEqual "raw value" "not-a-store-path" raw - other -> do - putStrLn (" expected Left [InvalidStorePath ..], got: " ++ show other) - pure False, - test "validateNarInfo bad FileHash" $ - let ni = mkValidNarInfo {NarInfo.niFileHash = "md5:bogus"} - in case Validate.validateNarInfo ni of - Left [Validate.InvalidFileHash raw _] -> - assertEqual "raw value" "md5:bogus" raw - other -> do - putStrLn (" expected Left [InvalidFileHash ..], got: " ++ show other) - pure False, - test "validateNarInfo bad NarHash" $ - let ni = mkValidNarInfo {NarInfo.niNarHash = "md5:bogus"} - in case Validate.validateNarInfo ni of - Left [Validate.InvalidNarHash raw _] -> - assertEqual "raw value" "md5:bogus" raw - other -> do - putStrLn (" expected Left [InvalidNarHash ..], got: " ++ show other) - pure False, - test "validateNarInfo bad reference" $ - let ni = mkValidNarInfo {NarInfo.niReferences = ["bad"]} - in case Validate.validateNarInfo ni of - Left [Validate.InvalidReference raw _] -> - assertEqual "raw value" "bad" raw - other -> do - putStrLn (" expected Left [InvalidReference ..], got: " ++ show other) - pure False, - test "validateNarInfo multiple errors collected" $ - let ni = - mkValidNarInfo - { NarInfo.niFileSize = -1, - NarInfo.niNarSize = -1, - NarInfo.niStorePath = "bad" - } - in case Validate.validateNarInfo ni of - Left errs -> assertTrue "at least 3 errors" (length errs >= 3) - Right _ -> do - putStrLn " expected Left, got Right" - pure False, - test "validateNarHash correct" $ - assertEqual - "correct nar hash" - (Right ()) - (Validate.validateNarHash mkValidNarInfo validNarBytes), - test "validateNarHash wrong" $ - case Validate.validateNarHash mkValidNarInfo (BS.pack [99]) of - Left (Validate.NarHashMismatch _ _) -> pure True - other -> do - putStrLn (" expected Left NarHashMismatch, got: " ++ show other) - pure False, - test "validateFileHash correct" $ - assertEqual - "correct file hash" - (Right ()) - (Validate.validateFileHash mkValidNarInfo validFileBytes), - test "validateFileHash wrong" $ - case Validate.validateFileHash mkValidNarInfo (BS.pack [99]) of - Left (Validate.FileHashMismatch _ _) -> pure True - other -> do - putStrLn (" expected Left FileHashMismatch, got: " ++ show other) - pure False, - test "validateSignature valid" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - ni = mkValidNarInfo - case Signing.sign sk ni of - Left err -> do - putStrLn (" sign failed: " ++ err) - pure False - Right sig -> - let niSigned = ni {NarInfo.niSigs = [sig]} - in assertEqual "valid sig" (Right ()) (Validate.validateSignature pk niSigned), - test "validateSignature invalid" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - bogusSig = "bogus-key:aW52YWxpZA==" - ni = mkValidNarInfo {NarInfo.niSigs = [bogusSig]} - assertEqual - "invalid sig" - (Left [Validate.SignatureInvalid bogusSig]) - (Validate.validateSignature pk ni), - test "validateSignature no sigs" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - assertEqual - "no sigs" - (Left [Validate.NoSignatures]) - (Validate.validateSignature pk mkValidNarInfo), - test "validateFull all good" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - ni = mkValidNarInfo - case Signing.sign sk ni of - Left err -> do - putStrLn (" sign failed: " ++ err) - pure False - Right sig -> - let niSigned = ni {NarInfo.niSigs = [sig]} - in assertEqual - "full valid" - (Right ()) - (Validate.validateFull pk niSigned validNarBytes validFileBytes), - test "validateFull multiple failures" $ do - sk <- generateTestSecretKey - let pk = deriveTestPublicKey sk - ni = mkValidNarInfo {NarInfo.niFileSize = -1, NarInfo.niNarSize = -1} - case Validate.validateFull pk ni (BS.pack [99]) (BS.pack [99]) of - Left errs -> assertTrue "at least 4 errors" (length errs >= 4) - Right _ -> do - putStrLn " expected Left, got Right" - pure False - ] - --- --------------------------------------------------------------------------- --- Helpers --- --------------------------------------------------------------------------- - --- | Create a temporary test directory. -createTestDir :: IO FilePath -createTestDir = do - let dir = "/tmp/nova-cache-test" - createDirectoryIfMissing True dir - pure dir +{-# LANGUAGE LambdaCase #-} + +module Main (main) where + +import Control.Exception (SomeException, try) +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import Data.Bits (shiftR, (.&.)) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Lazy as BL +import Data.Either (isLeft) +import Data.IORef (atomicModifyIORef', newIORef) +import Data.List (sort) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Word (Word64, Word8) +import qualified Network.HTTP.Types as HTTP +import Network.Wai (RequestBodyLength (..), defaultRequest, pathInfo, requestBodyLength, requestHeaders, requestMethod) +import qualified Network.Wai.Test as WT +import qualified NovaCache.Base32 as Base32 +import qualified NovaCache.Hash as Hash +import qualified NovaCache.NAR as NAR +import qualified NovaCache.NAR.Stream as Stream +import qualified NovaCache.NarInfo as NarInfo +import qualified NovaCache.Server as Server +import qualified NovaCache.Signing as Signing +import qualified NovaCache.Store as Store +import qualified NovaCache.StorePath as StorePath +import qualified NovaCache.Validate as Validate +import System.Directory (createDirectory, getTemporaryDirectory, listDirectory, removeDirectoryRecursive) +import System.Exit (exitFailure, exitSuccess) +import System.IO (hFlush, stdout) +import qualified System.Info + +-- --------------------------------------------------------------------------- +-- Test harness (hand-rolled, no framework) +-- --------------------------------------------------------------------------- + +-- | Run a named test, short-circuit on first failure. +test :: String -> IO Bool -> IO Bool +test name action = do + putStr (" " ++ name ++ "... ") + hFlush stdout + result <- action + if result + then do + putStrLn "OK" + pure True + else do + putStrLn "FAILED" + pure False + +-- | Assert equality. +assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool +assertEqual label expected actual + | expected == actual = pure True + | otherwise = do + putStrLn "" + putStrLn (" " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual: " ++ show actual) + pure False + +-- | Assert a Right value matches. +assertRight :: (Eq a, Show a) => String -> a -> Either String a -> IO Bool +assertRight label expected (Right actual) = assertEqual label expected actual +assertRight label _ (Left err) = do + putStrLn "" + putStrLn (" " ++ label) + putStrLn (" expected Right, got Left: " ++ err) + pure False + +-- | Assert a Left (error case). +assertLeft :: (Show a) => String -> Either String a -> IO Bool +assertLeft _ (Left _) = pure True +assertLeft label (Right val) = do + putStrLn "" + putStrLn (" " ++ label) + putStrLn (" expected Left, got Right: " ++ show val) + pure False + +-- | Assert a Bool is True. +assertTrue :: String -> Bool -> IO Bool +assertTrue _ True = pure True +assertTrue label False = do + putStrLn "" + putStrLn (" " ++ label ++ ": expected True") + pure False + +-- | Assert a Bool is False. +assertFalse :: String -> Bool -> IO Bool +assertFalse _ False = pure True +assertFalse label True = do + putStrLn "" + putStrLn (" " ++ label ++ ": expected False") + pure False + +-- | Run a group of tests, stopping at first failure. +runGroup :: String -> [IO Bool] -> IO Bool +runGroup name tests = do + putStrLn (name ++ ":") + go tests + where + go [] = pure True + go (t : ts) = do + ok <- t + if ok then go ts else pure False + +-- | Run all test groups. +runAll :: [IO Bool] -> IO () +runAll groups = do + results <- sequence groups + let passed = length (filter id results) + total = length results + putStrLn "" + if and results + then do + putStrLn ("All " ++ show total ++ " groups passed.") + exitSuccess + else do + putStrLn (show passed ++ "/" ++ show total ++ " groups passed.") + exitFailure + +main :: IO () +main = do + putStrLn "nova-cache test suite" + putStrLn "======================" + putStrLn "" + runAll + [ testBase32, + testHash, + testStorePath, + testNAR, + testStream, + testNarInfo, + testSigning, + testFileStore, + testValidate, + testServer + ] + +-- --------------------------------------------------------------------------- +-- Base32 tests +-- --------------------------------------------------------------------------- + +testBase32 :: IO Bool +testBase32 = + runGroup + "Base32" + [ test "encode empty" $ + assertEqual "encode empty" "" (Base32.encode BS.empty), + test "decode empty" $ + assertRight "decode empty" BS.empty (Base32.decode ""), + test "encode/decode roundtrip (single byte)" $ + let bs = BS.singleton 0xFF + encoded = Base32.encode bs + in assertRight "roundtrip 0xFF" bs (Base32.decode encoded), + test "encode/decode roundtrip (known SHA-256)" $ + let bs = BS.pack [0 .. 31] + encoded = Base32.encode bs + in assertRight "roundtrip 32 bytes" bs (Base32.decode encoded), + test "encode/decode roundtrip (all zeros)" $ + let bs = BS.replicate 32 0 + encoded = Base32.encode bs + in assertRight "roundtrip zeros" bs (Base32.decode encoded), + test "encode/decode roundtrip (all 0xFF)" $ + let bs = BS.replicate 32 0xFF + encoded = Base32.encode bs + in assertRight "roundtrip 0xFF*32" bs (Base32.decode encoded), + test "decode invalid character" $ + assertLeft "invalid char" (Base32.decode "hello!"), + test "encode length for 32 bytes" $ + -- 32 bytes gives ceil(32*8/5) = ceil(51.2) = 52 chars + let bs = BS.replicate 32 0x42 + encoded = Base32.encode bs + in assertEqual "encoded length" 52 (T.length encoded), + test "nix known vector" $ + -- SHA-256 of the empty string exactly as real Nix renders it. A + -- wrong alphabet or bit order stays self-consistent in roundtrips; + -- only an external vector catches it. + assertEqual + "sha256 of empty in nix-base32" + "sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73" + (Hash.formatNixHash (Hash.hashBytes BS.empty)), + test "decode rejects nonzero padding bits" $ + -- 52 chars carry 260 bits for a 256-bit value; the 4 spare bits + -- must be zero in canonical nix-base32. + assertLeft "nonzero padding" (Base32.decode (T.replicate 52 "z")) + ] + +-- --------------------------------------------------------------------------- +-- Hash tests +-- --------------------------------------------------------------------------- + +testHash :: IO Bool +testHash = + runGroup + "Hash" + [ test "hashBytes deterministic" $ + let h1 = Hash.hashBytes (BS.pack [1, 2, 3]) + h2 = Hash.hashBytes (BS.pack [1, 2, 3]) + in assertEqual "deterministic" h1 h2, + test "hashBytes different inputs differ" $ + let h1 = Hash.hashBytes (BS.pack [1, 2, 3]) + h2 = Hash.hashBytes (BS.pack [4, 5, 6]) + in assertTrue "different" (h1 /= h2), + test "hashBytes is 32 bytes" $ + let Hash.NixHash raw = Hash.hashBytes BS.empty + in assertEqual "32 bytes" 32 (BS.length raw), + test "formatNixHash prefix" $ + let formatted = Hash.formatNixHash (Hash.hashBytes BS.empty) + in assertTrue "sha256: prefix" (T.isPrefixOf "sha256:" formatted), + test "formatNixHash/parseNixHash roundtrip" $ + let h = Hash.hashBytes (BS.pack [42]) + formatted = Hash.formatNixHash h + in assertRight "roundtrip" h (Hash.parseNixHash formatted), + test "parseNixHash bad prefix" $ + assertLeft "bad prefix" (Hash.parseNixHash "md5:abc"), + test "parseNixHash bad base32" $ + assertLeft "bad base32" (Hash.parseNixHash "sha256:!!invalid!!") + ] + +-- --------------------------------------------------------------------------- +-- StorePath tests +-- --------------------------------------------------------------------------- + +testStorePath :: IO Bool +testStorePath = + runGroup + "StorePath" + [ test "parse/render roundtrip" $ + let storeDir = StorePath.defaultStoreDir + input = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0" + in case StorePath.parseStorePath storeDir input of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right sp -> + assertEqual "roundtrip" input (StorePath.renderStorePath storeDir sp), + test "parse basename only" $ + let storeDir = StorePath.defaultStoreDir + basename = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0" + in case StorePath.parseStorePath storeDir basename of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right sp -> + assertEqual "basename" basename (StorePath.storePathBaseName sp), + test "parse extracts hash" $ + let storeDir = StorePath.defaultStoreDir + input = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-test" + in case StorePath.parseStorePath storeDir input of + Left _ -> pure False + Right sp -> + assertEqual "hash" "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" (StorePath.storePathHashString sp), + test "reject too short" $ + let storeDir = StorePath.defaultStoreDir + in assertLeft "too short" (StorePath.parseStorePath storeDir "abc-def"), + test "reject empty name" $ + let storeDir = StorePath.defaultStoreDir + in assertLeft "empty name" (StorePath.parseStorePath storeDir "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-"), + test "reject invalid name chars" $ + let storeDir = StorePath.defaultStoreDir + input = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello world" + in assertLeft "invalid chars" (StorePath.parseStorePath storeDir input), + -- Upstream's dot rule: the first dash-separated component may not + -- be "." or ".."; other dot-leading names stay valid. + test "reject dot-segment names" $ + let hash = T.replicate 32 "a" + rejected name = assertLeft (T.unpack name) (StorePath.parseStorePathBaseName (hash <> "-" <> name)) + in do + ok1 <- rejected "." + ok2 <- rejected ".." + ok3 <- rejected ".-x" + ok4 <- rejected "..-y" + pure (ok1 && ok2 && ok3 && ok4), + test "dotfile-style names stay valid" $ + let hash = T.replicate 32 "a" + in do + ok1 <- assertTrue "dotfile" (either (const False) (const True) (StorePath.parseStorePathBaseName (hash <> "-.config-1.0"))) + ok2 <- assertTrue "interior dots" (either (const False) (const True) (StorePath.parseStorePathBaseName (hash <> "-x.y.z"))) + pure (ok1 && ok2) + ] + +-- --------------------------------------------------------------------------- +-- NAR tests +-- --------------------------------------------------------------------------- + +testNAR :: IO Bool +testNAR = + runGroup + "NAR" + [ test "serialise/deserialise roundtrip (regular file)" $ + let entry = NAR.NarRegular False (BS.pack [72, 101, 108, 108, 111]) + serialised = NAR.serialise entry + in assertRight "roundtrip regular" entry (NAR.deserialise serialised), + test "serialise/deserialise roundtrip (empty file)" $ + let entry = NAR.NarRegular False BS.empty + serialised = NAR.serialise entry + in assertRight "roundtrip empty" entry (NAR.deserialise serialised), + test "serialise/deserialise roundtrip (executable)" $ + let entry = NAR.NarRegular True (BS.pack [0x7F, 0x45, 0x4C, 0x46]) + serialised = NAR.serialise entry + in assertRight "roundtrip exec" entry (NAR.deserialise serialised), + test "serialise/deserialise roundtrip (symlink)" $ + let entry = NAR.NarSymlink "/usr/bin/hello" + serialised = NAR.serialise entry + in assertRight "roundtrip symlink" entry (NAR.deserialise serialised), + test "serialise/deserialise roundtrip (directory)" $ + let entry = + NAR.NarDirectory + [ ("bar", NAR.NarRegular False (BS.pack [2])), + ("foo", NAR.NarRegular False (BS.pack [1])) + ] + serialised = NAR.serialise entry + in assertRight "roundtrip dir" entry (NAR.deserialise serialised), + test "serialise/deserialise roundtrip (nested directory)" $ + let entry = + NAR.NarDirectory + [ ("bin", NAR.NarDirectory [("hello", NAR.NarRegular True (BS.pack [42]))]), + ("lib", NAR.NarSymlink "../lib64") + ] + serialised = NAR.serialise entry + in assertRight "roundtrip nested" entry (NAR.deserialise serialised), + test "directory entries sorted" $ + let entry = + NAR.NarDirectory + [ ("zebra", NAR.NarRegular False BS.empty), + ("alpha", NAR.NarRegular False BS.empty) + ] + serialised = NAR.serialise entry + in case NAR.deserialise serialised of + Left err -> do + putStrLn (" deserialise failed: " ++ err) + pure False + Right (NAR.NarDirectory entries) -> + assertEqual "sorted" ["alpha", "zebra"] (map fst entries) + Right other -> do + putStrLn (" expected directory, got: " ++ show other) + pure False, + test "narHash deterministic" $ + let entry = NAR.NarRegular False (BS.pack [1, 2, 3]) + h1 = NAR.narHash entry + h2 = NAR.narHash entry + in assertEqual "deterministic hash" h1 h2, + test "narHash differs for different content" $ + let h1 = NAR.narHash (NAR.NarRegular False (BS.pack [1])) + h2 = NAR.narHash (NAR.NarRegular False (BS.pack [2])) + in assertTrue "different hashes" (h1 /= h2), + test "deserialise garbage fails" $ + assertLeft "garbage" (NAR.deserialise (BS.pack [0, 0, 0, 0, 0, 0, 0, 0])), + test "roundtrip edge: empty directory" $ + let entry = NAR.NarDirectory [] + in assertRight "empty dir" entry (NAR.deserialise (NAR.serialise entry)), + test "roundtrip edge: contents a multiple of 8 (zero padding)" $ + let entry = NAR.NarRegular False (BS.replicate 8 0x41) + in assertRight "8-byte contents" entry (NAR.deserialise (NAR.serialise entry)), + test "roundtrip edge: executable empty file" $ + let entry = NAR.NarRegular True BS.empty + in assertRight "exec empty" entry (NAR.deserialise (NAR.serialise entry)), + -- Cache-served archives are untrusted input: every name that could + -- traverse out of a POSIX extraction root must fail the parse. + test "unsafe directory entry names rejected" $ + let evil name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")]) + names = ["..", ".", "", "a/b", "a\0b"] + rejected bytes = either (const True) (const False) (NAR.deserialise bytes) + in assertTrue "all unsafe names rejected" (all (rejected . evil) names), + test "duplicate directory entries rejected" $ + let dup = + NAR.serialise + ( NAR.NarDirectory + [ ("same", NAR.NarRegular False "1"), + ("same", NAR.NarRegular False "2") + ] + ) + in assertLeft "duplicate entries" (NAR.deserialise dup), + test "out-of-order directory entries rejected" $ + assertLeft "unsorted entries" (NAR.deserialise outOfOrderDirNar), + test "trailing bytes after the root node rejected" $ + let valid = NAR.serialise (NAR.NarRegular False "x") + in assertLeft "trailing bytes" (NAR.deserialise (valid <> "junk1234")), + test "nonzero string padding rejected" $ + assertLeft "nonzero padding" (NAR.deserialise badPaddingNar), + -- The format fixes the executable marker's value as empty; upstream + -- rejects a nonempty value, and NAR.serialise cannot produce one. + test "nonempty executable marker rejected" $ + let marked = + BS.concat + ( map + (narWireStr 0) + ["nix-archive-1", "(", "type", "regular", "executable", "X", "contents", "hi", ")"] + ) + in assertLeft "nonempty marker" (NAR.deserialise marked), + -- Upstream's restore accepts these on Unix, and real + -- cache.nixos.org archives carry them (perl man pages named + -- ExtUtils::MakeMaker.3, kernel trees carrying aux.c): the + -- parser must too, or substitution fails where upstream + -- succeeds. Rejecting them is the store writer's call, via + -- NAR.isWindowsHazardName, where the target filesystem needs it. + test "Windows-hazard names parse, as upstream accepts" $ + let entryFor name = NAR.NarDirectory [(name, NAR.NarRegular False "x")] + names = ["ExtUtils::MakeMaker.3", "aux.c", "a:b", "a\\b", "nul", "foo.", "foo "] + roundTrips name = NAR.deserialise (NAR.serialise (entryFor name)) == Right (entryFor name) + in assertTrue "all parse and round-trip" (all roundTrips names), + -- Windows resolves these names to something other than a file of + -- this spelling (drive/stream colon, separator backslash, device, + -- NTFS dot/space strip). + test "isWindowsHazardName flags the hazard categories" $ + -- Among the devices: COM0/LPT0 are reserved alongside COM1-9, + -- the device stem is compared with trailing spaces trimmed + -- ("NUL .txt" still opens the device), and the superscript + -- digits (here U+00B9 as UTF-8) count as device digits. + let names = + [ "C:evil", + "a:b", + "a\\b", + "nul", + "NUL", + "com1", + "nul.txt", + "foo.", + "foo ", + "com0", + "lpt0", + "nul .txt", + "CON .x", + "com" <> BS.pack [0xC2, 0xB9] + ] + in assertTrue "all hazard names flagged" (all NAR.isWindowsHazardName names), + test "near-miss names parse and pass the hazard predicate" $ + let plain name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")]) + -- "com" followed by a non-digit non-superscript byte (here + -- U+00B4, acute accent) is an ordinary name; so are stems + -- one character too long. + names = ["nul2", "com10", "conx", "foo.bar", "a.b.c", "lpt00", "com" <> BS.pack [0xC2, 0xB4]] + accepted bytes = either (const False) (const True) (NAR.deserialise bytes) + clean name = accepted (plain name) && not (NAR.isWindowsHazardName name) + in assertTrue "all near-miss names accepted" (all clean names), + -- Upstream carries names and targets as raw bytes: entries that + -- do not decode as UTF-8 parse and round-trip. + test "non-UTF-8 entry name round-trips" $ + let entry = NAR.NarDirectory [(BS.pack [0x66, 0xFF], NAR.NarRegular False "x")] + in assertRight "raw-byte name" entry (NAR.deserialise (NAR.serialise entry)), + test "non-UTF-8 symlink target round-trips" $ + let entry = NAR.NarSymlink (BS.pack [0x2F, 0x74, 0x6D, 0x70, 0x2F, 0xFF]) + in assertRight "raw-byte target" entry (NAR.deserialise (NAR.serialise entry)), + test "entries sort bytewise, non-UTF-8 names included" $ + let entry = + NAR.NarDirectory + [ (BS.pack [0xFF], NAR.NarRegular False "hi"), + ("b", NAR.NarRegular False "lo") + ] + in case NAR.deserialise (NAR.serialise entry) of + Left err -> do + putStrLn (" deserialise failed: " ++ err) + pure False + Right (NAR.NarDirectory entries) -> + assertEqual "byte order" ["b", BS.pack [0xFF]] (map fst entries) + Right other -> do + putStrLn (" expected directory, got: " ++ show other) + pure False, + -- The hazard checks are ASCII-structural, so they fire inside + -- names that do not decode as text. + test "hazards inside non-UTF-8 names still flagged" $ + let names = ["nul." <> BS.pack [0xFF], BS.pack [0xFF, 0x2E], BS.pack [0xFF] <> ":x"] + in assertTrue "all hazard bytes flagged" (all NAR.isWindowsHazardName names), + -- The case-hack strip: a tree materialized with upstream's + -- collision suffix serialises back under its NAR names. + test "serialiseFromPathWith strips the case-hack suffix" $ do + dir <- caseHackFixture "nova-cache-test-casehack" + BS.writeFile (dir <> "/Foo") "upper" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "lower" + entry <- NAR.serialiseFromPathWith NAR.CaseHackEnabled dir + removeDirectoryRecursive dir + let expected = + NAR.NarDirectory + [ ("Foo", NAR.NarRegular False "upper"), + ("foo", NAR.NarRegular False "lower") + ] + roundTrip <- assertRight "stripped tree reparses" expected (NAR.deserialise (NAR.serialise entry)) + pure (entry == expected && roundTrip), + test "serialiseFromPathWith keeps the suffix verbatim when disabled" $ do + dir <- caseHackFixture "nova-cache-test-casehack-off" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "kept" + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + removeDirectoryRecursive dir + assertEqual + "verbatim name" + (NAR.NarDirectory [("foo~nix~case~hack~1", NAR.NarRegular False "kept")]) + entry, + test "serialiseFromPathWith fails loudly on an unhack collision" $ do + dir <- caseHackFixture "nova-cache-test-casehack-clash" + BS.writeFile (dir <> "/foo") "plain" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "hacked" + outcome <- try (NAR.serialiseFromPathWith NAR.CaseHackEnabled dir) + removeDirectoryRecursive dir + pure $ case (outcome :: Either SomeException NAR.NarEntry) of + Left _ -> True + Right _ -> False, + -- The walk's boundary encoding: a Unicode disk name enters the + -- archive as its UTF-8 bytes on every platform. + test "serialiseFromPath encodes a Unicode disk name as UTF-8" $ do + dir <- caseHackFixture "nova-cache-test-uniname" + BS.writeFile (dir <> "/caf\233") "au lait" + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + removeDirectoryRecursive dir + assertEqual + "utf8 name" + (NAR.NarDirectory [(BS.pack [0x63, 0x61, 0x66, 0xC3, 0xA9], NAR.NarRegular False "au lait")]) + entry, + -- POSIX names are bytes; one that is not valid UTF-8 must archive + -- verbatim (it used to be silently rewritten with replacement + -- characters). Linux-gated: NTFS and APFS names are Unicode, so + -- the fixture cannot exist there. "\56575" is the lone surrogate + -- GHC's filesystem encoding round-trips to byte 0xFF. + test "serialiseFromPath carries a non-UTF-8 disk name verbatim" $ + if System.Info.os /= "linux" + then pure True + else do + dir <- caseHackFixture "nova-cache-test-rawname" + BS.writeFile (dir <> "/f\56575") "raw" + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + removeDirectoryRecursive dir + assertEqual + "raw byte name" + (NAR.NarDirectory [(BS.pack [0x66, 0xFF], NAR.NarRegular False "raw")]) + entry + ] + +-- | A fresh, empty fixture directory under the system temp dir. +caseHackFixture :: String -> IO FilePath +caseHackFixture name = do + tmpBase <- getTemporaryDirectory + let dir = tmpBase <> "/" <> name + _ <- try (removeDirectoryRecursive dir) :: IO (Either SomeException ()) + createDirectory dir + pure dir + +-- | Encode one NAR wire string with a chosen padding byte. The spec +-- demands zero padding, so a nonzero byte builds archives the parser +-- must reject - and 'NAR.serialise' (rightly) cannot produce them. +narWireStr :: Word8 -> ByteString -> ByteString +narWireStr padByte str = lenLE <> str <> BS.replicate padLen padByte + where + n = BS.length str + lenLE = BS.pack [fromIntegral ((n `shiftR` (8 * i)) .&. 0xff) | i <- [0 .. 7]] + padLen = (8 - n `mod` 8) `mod` 8 + +-- | A directory NAR whose entries arrive out of sorted order - again not +-- producible via 'NAR.serialise', which sorts on write. +outOfOrderDirNar :: ByteString +outOfOrderDirNar = + BS.concat + ( map + (narWireStr 0) + ( ["nix-archive-1", "(", "type", "directory"] + ++ entryFor "b" + ++ entryFor "a" + ++ [")"] + ) + ) + where + entryFor name = ["entry", "(", "name", name, "node", "(", "type", "regular", "contents", "", ")", ")"] + +-- | A regular-file NAR whose contents padding is nonzero. +badPaddingNar :: ByteString +badPaddingNar = + BS.concat + [ BS.concat (map (narWireStr 0) ["nix-archive-1", "(", "type", "regular", "contents"]), + narWireStr 1 "abc", + narWireStr 0 ")" + ] + +-- --------------------------------------------------------------------------- +-- NAR.Stream tests +-- --------------------------------------------------------------------------- + +-- | Drive the streaming parser over the given chunks (all non-empty), +-- then signal end of input, collecting events. +runStream :: [ByteString] -> Either String [Stream.NarEvent] +runStream = runStreamFrom Stream.narStream + +-- | 'runStream' from an explicitly constructed machine, for tests that +-- need a bound other than the default. +runStreamFrom :: Stream.NarStep -> [ByteString] -> Either String [Stream.NarEvent] +runStreamFrom start chunks = go start chunks [] + where + go step pending acc = case step of + Stream.NarFail err -> Left err + Stream.NarDone -> Right (reverse acc) + Stream.NarYield event continue -> go continue pending (event : acc) + Stream.NarAwait continue -> case pending of + [] -> go (continue BS.empty) [] acc + (chunk : rest) -> go (continue chunk) rest acc + +-- | Entry shapes the chunking-independence test sweeps: every node +-- kind, empty and aligned contents, nesting, and a non-UTF-8 name. +streamCorpus :: [NAR.NarEntry] +streamCorpus = + [ NAR.NarRegular False "hello", + NAR.NarRegular True BS.empty, + NAR.NarRegular False (BS.replicate 8 0x41), + NAR.NarSymlink "/usr/bin/hello", + NAR.NarDirectory [], + NAR.NarDirectory + [ ("bin", NAR.NarDirectory [("hello", NAR.NarRegular True (BS.pack [42]))]), + ("lib", NAR.NarSymlink "../lib64"), + (BS.pack [0x66, 0xFF], NAR.NarRegular False "raw") + ] + ] + +-- | Merge consecutive contents slices. Slice granularity deliberately +-- follows the fed chunks, so parses of different chunkings compare by +-- structure and content, not by how the input happened to arrive. +coalesceChunks :: [Stream.NarEvent] -> [Stream.NarEvent] +coalesceChunks (Stream.EventRegularChunk a : Stream.EventRegularChunk b : rest) = + coalesceChunks (Stream.EventRegularChunk (a <> b) : rest) +coalesceChunks (event : rest) = event : coalesceChunks rest +coalesceChunks [] = [] + +-- | Split a byte string into fixed-size pieces. +chunksOf :: Int -> ByteString -> [ByteString] +chunksOf n bs + | BS.null bs = [] + | otherwise = case BS.splitAt n bs of + (piece, rest) -> piece : chunksOf n rest + +-- | Pull a source dry, collecting its chunks (the terminating empty +-- chunk excluded). +collectChunks :: IO ByteString -> IO [ByteString] +collectChunks pull = go [] + where + go acc = do + chunk <- pull + if BS.null chunk then pure (reverse acc) else go (chunk : acc) + +-- | Pull a source dry into one byte string. +drainSource :: IO ByteString -> IO ByteString +drainSource pull = BS.concat <$> collectChunks pull + +-- | Hash a source chunk by chunk as it is pulled. +hashPull :: Hash.HashContext -> IO ByteString -> IO Hash.NixHash +hashPull ctx pull = do + chunk <- pull + if BS.null chunk + then pure (Hash.hashFinalize ctx) + else hashPull (Hash.hashUpdate ctx chunk) pull + +testStream :: IO Bool +testStream = + runGroup + "NAR.Stream" + [ test "events for a regular file" $ + assertEqual + "event sequence" + ( Right + [ Stream.EventRegularBegin True 2, + Stream.EventRegularChunk "hi", + Stream.EventRegularEnd + ] + ) + (runStream [NAR.serialise (NAR.NarRegular True "hi")]), + test "events for a directory arrive entry by entry" $ + let entry = NAR.NarDirectory [("a", NAR.NarSymlink "t"), ("b", NAR.NarRegular False "")] + expected = + [ Stream.EventDirectoryBegin, + Stream.EventEntryBegin "a", + Stream.EventSymlink "t", + Stream.EventEntryEnd, + Stream.EventEntryBegin "b", + Stream.EventRegularBegin False 0, + Stream.EventRegularEnd, + Stream.EventEntryEnd, + Stream.EventDirectoryEnd + ] + in assertEqual "event sequence" (Right expected) (runStream [NAR.serialise entry]), + test "byte-at-a-time chunking equals whole-input parsing" $ + let normalize = fmap coalesceChunks + agrees entry = + let bytes = NAR.serialise entry + in normalize (runStream [bytes]) == normalize (runStream (map BS.singleton (BS.unpack bytes))) + in assertTrue "chunking-independent" (all agrees streamCorpus), + test "contents slices reassemble across misaligned chunks" $ + -- 7-byte chunks sit deliberately askew of the 8-byte wire + -- alignment, so every length prefix and padding run straddles + -- a chunk boundary somewhere. + let payload = BS.pack (concat (replicate 40 [0 .. 7])) + bytes = NAR.serialise (NAR.NarRegular False payload) + in case runStream (chunksOf 7 bytes) of + Left err -> do + putStrLn (" streaming parse failed: " ++ err) + pure False + Right events -> + assertEqual + "reassembled contents" + payload + (BS.concat [c | Stream.EventRegularChunk c <- events]), + test "streaming agrees with deserialise on the malformed corpus" $ + let evil name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")]) + malformed = + [ outOfOrderDirNar, + badPaddingNar, + NAR.serialise (NAR.NarRegular False "x") <> "junk1234", + evil "..", + evil "a/b", + evil "" + ] + bothReject bytes = isLeft (runStream [bytes]) && isLeft (NAR.deserialise bytes) + in assertTrue "all rejected by both parsers" (all bothReject malformed), + test "the structural bound applies to streaming, not deserialise" $ + -- deserialise instantiates the machine with its input's length + -- as the bound, so a name this size stays accepted there; the + -- streaming default caps structural strings at 64 KiB. + let longName = BS.replicate 70000 0x61 + bytes = NAR.serialise (NAR.NarDirectory [(longName, NAR.NarRegular False "x")]) + in do + ok1 <- assertTrue "deserialise accepts" (either (const False) (const True) (NAR.deserialise bytes)) + ok2 <- assertTrue "streaming rejects" (isLeft (runStream [bytes])) + pure (ok1 && ok2), + test "a truncated archive fails" $ + let bytes = NAR.serialise (NAR.NarRegular False "some contents here") + in assertLeft "eof" (runStream [BS.take (BS.length bytes - 9) bytes]), + -- Regression: under a huge caller bound, a declared length near + -- maxBound Int once wrapped the padded Int demand negative, so + -- the machine "read" the string instantly as empty at an unmoved + -- position and this archive parsed as a complete empty symlink. + -- The parse must fail, as upstream would at end of input. + test "a near-maxBound declared length fails under a huge bound" $ + let declared = fromIntegral (maxBound :: Int) :: Word64 + lenPrefix = BS.pack [fromIntegral ((declared `shiftR` (8 * i)) .&. 0xff) | i <- [0 .. 7]] + bytes = + BS.concat (map (narWireStr 0) ["nix-archive-1", "(", "type", "symlink", "target"]) + <> lenPrefix + <> narWireStr 0 ")" + in assertLeft + "overflowing padded demand" + (runStreamFrom (Stream.narStreamBounded (maxBound :: Word64)) [bytes]), + test "the declared contents size arrives before the bytes" $ + case runStream [NAR.serialise (NAR.NarRegular False (BS.replicate 24 0x2A))] of + Right (Stream.EventRegularBegin False declared : _) -> + assertEqual "declared size" 24 declared + other -> do + putStrLn (" expected EventRegularBegin first, got: " ++ show other) + pure False, + test "withNarSource streams byte-identically to serialise" $ do + dir <- caseHackFixture "nova-cache-test-narsource" + createDirectory (dir <> "/sub") + -- Larger than two pull chunks, so mid-file continuation runs. + BS.writeFile (dir <> "/big.bin") (BS.replicate 300000 0x41) + BS.writeFile (dir <> "/sub/small") "tiny" + BS.writeFile (dir <> "/zero") "" + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + streamed <- NAR.withNarSource NAR.CaseHackDisabled dir drainSource + removeDirectoryRecursive dir + assertTrue "bytes equal" (NAR.serialise entry == streamed), + test "withNarSource under the case-hack matches the strict walk" $ do + dir <- caseHackFixture "nova-cache-test-narsource-hack" + BS.writeFile (dir <> "/Foo") "upper" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "lower" + entry <- NAR.serialiseFromPathWith NAR.CaseHackEnabled dir + streamed <- NAR.withNarSource NAR.CaseHackEnabled dir drainSource + removeDirectoryRecursive dir + assertTrue "bytes equal" (NAR.serialise entry == streamed), + test "withNarSource keeps returning empty after the end" $ do + dir <- caseHackFixture "nova-cache-test-narsource-end" + BS.writeFile (dir <> "/f") "x" + ends <- NAR.withNarSource NAR.CaseHackDisabled dir $ \pull -> do + _ <- collectChunks pull + endA <- pull + endB <- pull + pure (endA, endB) + removeDirectoryRecursive dir + assertEqual "stable end" ("", "") ends, + test "pulled chunks parse back to the walked tree" $ do + dir <- caseHackFixture "nova-cache-test-narsource-loop" + BS.writeFile (dir <> "/data.bin") (BS.replicate 200000 0x5A) + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + chunks <- NAR.withNarSource NAR.CaseHackDisabled dir collectChunks + removeDirectoryRecursive dir + ok1 <- assertRight "strict parse of the stream" entry (NAR.deserialise (BS.concat chunks)) + ok2 <- assertTrue "streaming parse of the chunk list" (either (const False) (const True) (runStream chunks)) + pure (ok1 && ok2), + test "incremental hashing equals whole-input hashing" $ + let payload = BS.pack [0 .. 255] + pieces = [BS.take 100 payload, BS.take 55 (BS.drop 100 payload), BS.drop 155 payload] + incremental = Hash.hashFinalize (foldl' Hash.hashUpdate Hash.hashInit pieces) + in do + ok1 <- assertEqual "split arbitrarily" (Hash.hashBytes payload) incremental + ok2 <- assertEqual "empty input" (Hash.hashBytes BS.empty) (Hash.hashFinalize Hash.hashInit) + pure (ok1 && ok2), + test "hashing a pulled source equals narHash of the walk" $ do + dir <- caseHackFixture "nova-cache-test-streamhash" + BS.writeFile (dir <> "/blob") (BS.replicate 150000 0x07) + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + digest <- NAR.withNarSource NAR.CaseHackDisabled dir (hashPull Hash.hashInit) + removeDirectoryRecursive dir + assertEqual "hash matches" (NAR.narHash entry) digest + ] + +-- --------------------------------------------------------------------------- +-- NarInfo tests +-- --------------------------------------------------------------------------- + +sampleNarInfoText :: Text +sampleNarInfoText = + T.unlines + [ "StorePath: /nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0", + "URL: nar/1234abcd.nar.xz", + "Compression: xz", + "FileHash: sha256:abcdef1234567890", + "FileSize: 12345", + "NarHash: sha256:fedcba0987654321", + "NarSize: 67890", + "References: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0 bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-glibc-2.38", + "Deriver: cccccccccccccccccccccccccccccccc-hello-1.0.drv", + "Sig: cache.example.com:c2lnbmF0dXJl", + "Sig: backup.example.com:YW5vdGhlcnNpZw==" + ] + +testNarInfo :: IO Bool +testNarInfo = + runGroup + "NarInfo" + [ test "parse sample narinfo" $ + case NarInfo.parseNarInfo sampleNarInfoText of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> do + ok1 <- assertEqual "storePath" "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0" (NarInfo.niStorePath ni) + ok2 <- assertEqual "url" "nar/1234abcd.nar.xz" (NarInfo.niUrl ni) + ok3 <- assertEqual "compression" "xz" (NarInfo.niCompression ni) + ok4 <- assertEqual "fileSize" (Just 12345) (NarInfo.niFileSize ni) + ok5 <- assertEqual "narSize" 67890 (NarInfo.niNarSize ni) + ok6 <- assertEqual "refs count" 2 (length (NarInfo.niReferences ni)) + ok7 <- assertEqual "deriver" (Just "cccccccccccccccccccccccccccccccc-hello-1.0.drv") (NarInfo.niDeriver ni) + ok8 <- assertEqual "sigs count" 2 (length (NarInfo.niSigs ni)) + pure (ok1 && ok2 && ok3 && ok4 && ok5 && ok6 && ok7 && ok8), + test "parse/render roundtrip" $ + case NarInfo.parseNarInfo sampleNarInfoText of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> + let rendered = NarInfo.renderNarInfo ni + in case NarInfo.parseNarInfo rendered of + Left err -> do + putStrLn (" re-parse failed: " ++ err) + pure False + Right reparsed -> + assertEqual "roundtrip" ni reparsed, + test "parse minimal narinfo (no optional fields)" $ + let minimal = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "Compression: xz", + "FileHash: sha256:abc", + "FileSize: 100", + "NarHash: sha256:def", + "NarSize: 200", + "References: " + ] + in case NarInfo.parseNarInfo minimal of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> do + ok1 <- assertEqual "deriver" Nothing (NarInfo.niDeriver ni) + ok2 <- assertEqual "sigs" [] (NarInfo.niSigs ni) + ok3 <- assertEqual "ca" Nothing (NarInfo.niCA ni) + ok4 <- assertEqual "refs" [] (NarInfo.niReferences ni) + pure (ok1 && ok2 && ok3 && ok4), + test "CRLF-terminated narinfo parses identically" $ + assertEqual + "crlf tolerated" + (NarInfo.parseNarInfo sampleNarInfoText) + (NarInfo.parseNarInfo (T.replace "\n" "\r\n" sampleNarInfoText)), + test "upstream-optional fields default as upstream" $ + -- Only StorePath, URL, NarHash, NarSize are mandatory upstream; + -- Compression defaults to bzip2 and FileHash/FileSize stay absent. + let bare = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "NarHash: sha256:def", + "NarSize: 200" + ] + in case NarInfo.parseNarInfo bare of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> do + ok1 <- assertEqual "compression default" "bzip2" (NarInfo.niCompression ni) + ok2 <- assertEqual "fileHash absent" Nothing (NarInfo.niFileHash ni) + ok3 <- assertEqual "fileSize absent" Nothing (NarInfo.niFileSize ni) + pure (ok1 && ok2 && ok3), + test "CA field parse/render roundtrip" $ + let withCA = sampleNarInfoText <> "CA: fixed:r:sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73\n" + in case NarInfo.parseNarInfo withCA of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> do + ok1 <- + assertEqual + "ca parsed" + (Just "fixed:r:sha256:0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73") + (NarInfo.niCA ni) + ok2 <- assertRight "ca survives render" ni (NarInfo.parseNarInfo (NarInfo.renderNarInfo ni)) + pure (ok1 && ok2), + test "parse missing required key fails" $ + let incomplete = T.unlines ["StorePath: /nix/store/aaaa-test", "URL: nar/test.nar.xz"] + in assertLeft "missing key" (NarInfo.parseNarInfo incomplete), + test "parse bad integer fails" $ + let bad = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "Compression: xz", + "FileHash: sha256:abc", + "FileSize: not-a-number", + "NarHash: sha256:def", + "NarSize: 200", + "References: " + ] + in assertLeft "bad integer" (NarInfo.parseNarInfo bad), + -- Sizes are uint64 on the wire: at most 20 digits. A longer field + -- rejects before the quadratic bignum accumulation. + test "parse rejects an overlong size field" $ + let long = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "NarHash: sha256:def", + "NarSize: 123456789012345678901" + ] + in assertLeft "overlong size" (NarInfo.parseNarInfo long), + test "a 20-digit size field still parses" $ + let capped = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "NarHash: sha256:def", + "NarSize: 18446744073709551615" + ] + in case NarInfo.parseNarInfo capped of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> assertEqual "uint64 max" 18446744073709551615 (NarInfo.niNarSize ni), + -- Twenty digits still fit values past 2^64 - 1; upstream's + -- string2Int refuses them, so signing one here would + -- produce a narinfo every real client rejects as corrupt. + test "a 20-digit size above the uint64 maximum rejects" $ + let overCap = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "NarHash: sha256:def", + "NarSize: 18446744073709551616" + ] + in assertLeft "size above uint64" (NarInfo.parseNarInfo overCap), + -- Upstream assigns fields as it reads, so a duplicated scalar key + -- resolves to the LAST value (Sig stays the repeatable exception). + test "duplicate scalar keys resolve last-wins" $ + let dup = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/first.nar", + "URL: nar/last.nar", + "Compression: xz", + "Compression: zstd", + "NarHash: sha256:def", + "NarSize: 200" + ] + in case NarInfo.parseNarInfo dup of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> do + ok1 <- assertEqual "url last" "nar/last.nar" (NarInfo.niUrl ni) + ok2 <- assertEqual "compression last" "zstd" (NarInfo.niCompression ni) + pure (ok1 && ok2) + ] + +-- --------------------------------------------------------------------------- +-- Signing tests +-- --------------------------------------------------------------------------- + +testSigning :: IO Bool +testSigning = + runGroup + "Signing" + [ test "fingerprint format" $ + let ni = mkTestNarInfo + fp = Signing.fingerprint ni + in do + ok1 <- assertTrue "starts with 1;" (T.isPrefixOf "1;" fp) + ok2 <- assertTrue "contains storePath" (T.isInfixOf "/nix/store/" fp) + pure (ok1 && ok2), + test "fingerprint renders references as full store paths" $ + let ni = mkTestNarInfo {NarInfo.niReferences = ["00000000000000000000000000000000-glibc-2.40"]} + fp = Signing.fingerprint ni + in assertTrue + "reference is a full /nix/store path in the fingerprint" + (T.isInfixOf "/nix/store/00000000000000000000000000000000-glibc-2.40" fp), + test "fingerprint sorts and dedupes references" $ + let ni = + mkTestNarInfo + { NarInfo.niReferences = + [ "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-zlib-1.3", + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-glibc-2.40", + "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-zlib-1.3" + ] + } + fp = Signing.fingerprint ni + in assertTrue + "references sorted by basename and deduplicated (C++ Nix parity)" + -- The leading field separator pins the WHOLE references + -- field: without it, the pre-fix "zlib,glibc,zlib" + -- rendering also ends in "...glibc...,...zlib..." and the + -- assertion cannot fail on a regression to unsorted output. + ( T.isSuffixOf + ";/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-glibc-2.40,/nix/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-zlib-1.3" + fp + ), + test "SecretKey Show redacts the key bytes" $ + let sk = Signing.SecretKey {Signing.skName = "test-key", Signing.skBytes = BS.pack ([1 .. 32] ++ [33 .. 64])} + in assertEqual "redacted" "SecretKey \"test-key\" " (show sk), + test "SecretKey equality compares name and bytes" $ + let bytesA = BS.pack ([1 .. 32] ++ [33 .. 64]) + skA = Signing.SecretKey "k" bytesA + skB = Signing.SecretKey "k" bytesA + skC = Signing.SecretKey "k" (BS.pack (0 : [2 .. 64])) + in do + ok1 <- assertTrue "equal keys" (skA == skB) + ok2 <- assertTrue "different bytes differ" (skA /= skC) + pure (ok1 && ok2), + test "parseSecretKey valid" $ + let keyBytes = BS.pack ([1 .. 32] ++ [33 .. 64]) + keyB64 = TE.decodeUtf8 (B64.encode keyBytes) + keyStr = "test-key:" <> keyB64 + in case Signing.parseSecretKey keyStr of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right sk -> + assertEqual "key name" "test-key" (Signing.skName sk), + test "parsePublicKey valid" $ + let keyBytes = BS.pack [1 .. 32] + keyB64 = TE.decodeUtf8 (B64.encode keyBytes) + keyStr = "test-key:" <> keyB64 + in case Signing.parsePublicKey keyStr of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right pk -> + assertEqual "key name" "test-key" (Signing.pkName pk), + test "parseSecretKey no colon fails" $ + assertLeft "no colon" (Signing.parseSecretKey "nokeyname"), + test "empty key name rejected" $ + -- An empty-named key would emit :sig lines no named trust anchor + -- matches; the misconfiguration must fail at load time. + let material = TE.decodeUtf8 (B64.encode (BS.pack [1 .. 64])) + in assertLeft "empty name" (Signing.parseSecretKey (":" <> material)), + test "empty key material rejected" $ + assertLeft "empty material" (Signing.parsePublicKey "test-key:"), + test "signature from a different keypair rejected" $ do + signingKey <- generateTestSecretKey + otherKey <- generateTestSecretKey + let verifier = deriveTestPublicKey otherKey + case Signing.sign signingKey mkTestNarInfo of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right signed -> + assertTrue "cross-key rejected" (not (Signing.verify verifier mkTestNarInfo signed)), + test "valid signature under a renamed trust anchor rejected" $ do + signingKey <- generateTestSecretKey + let renamed = (deriveTestPublicKey signingKey) {Signing.pkName = "some-other-cache"} + case Signing.sign signingKey mkTestNarInfo of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right signed -> + assertTrue "name mismatch rejected" (not (Signing.verify renamed mkTestNarInfo signed)), + test "malformed signature lines rejected" $ do + signingKey <- generateTestSecretKey + let verifier = deriveTestPublicKey signingKey + wrongSize = "test-key:" <> TE.decodeUtf8 (B64.encode (BS.pack [1 .. 16])) + badLines = ["test-key:!!!not-base64!!!", wrongSize, "test-key:", "no-colon-at-all"] + assertTrue + "all malformed rejected" + (not (any (Signing.verify verifier mkTestNarInfo) badLines)), + test "parsePublicKey wrong size fails" $ + let keyStr = "test-key:" <> TE.decodeUtf8 (B64.encode (BS.pack [1 .. 16])) + in assertLeft "wrong size" (Signing.parsePublicKey keyStr), + test "sign/verify roundtrip" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + ni = mkTestNarInfo + case Signing.sign sk ni of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right sig -> + assertTrue "verify passes" (Signing.verify pk ni sig), + test "verify rejects tampered narinfo" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + ni = mkTestNarInfo + case Signing.sign sk ni of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right sig -> + let tampered = ni {NarInfo.niNarSize = 999999} + in assertFalse "verify rejects tampered" (Signing.verify pk tampered sig), + test "toPublicKey derives the verifying key" $ do + sk <- generateTestSecretKey + case Signing.toPublicKey sk of + Left err -> do + putStrLn (" toPublicKey failed: " ++ err) + pure False + Right pk -> do + okName <- assertEqual "key name carried over" (Signing.skName sk) (Signing.pkName pk) + okBytes <- assertEqual "matches the stored public half" (BS.drop 32 (Signing.skBytes sk)) (Signing.pkBytes pk) + case Signing.sign sk mkTestNarInfo of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right sig -> do + okVerify <- assertTrue "derived key verifies a signature" (Signing.verify pk mkTestNarInfo sig) + pure (okName && okBytes && okVerify), + test "renderPublicKey round-trips through parsePublicKey" $ do + sk <- generateTestSecretKey + case Signing.toPublicKey sk of + Left err -> do + putStrLn (" toPublicKey failed: " ++ err) + pure False + Right pk -> case Signing.parsePublicKey (Signing.renderPublicKey pk) of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right reparsed -> assertEqual "round-trip" pk reparsed, + test "normalizeKeyText strips BOM and whitespace" $ do + ok1 <- assertEqual "BOM stripped" "test-key:abc" (Signing.normalizeKeyText ("\xFEFF" <> "test-key:abc")) + ok2 <- assertEqual "CRLF stripped" "test-key:abc" (Signing.normalizeKeyText "test-key:abc\r\n") + ok3 <- assertEqual "spaces stripped" "test-key:abc" (Signing.normalizeKeyText " test-key:abc ") + ok4 <- assertEqual "clean text unchanged" "test-key:abc" (Signing.normalizeKeyText "test-key:abc") + pure (ok1 && ok2 && ok3 && ok4) + ] + +-- | Create a test NarInfo for signing tests. +mkTestNarInfo :: NarInfo.NarInfo +mkTestNarInfo = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/aaaa-hello-1.0", + NarInfo.niUrl = "nar/test.nar.xz", + NarInfo.niCompression = "xz", + NarInfo.niFileHash = Just "sha256:abc", + NarInfo.niFileSize = Just 100, + NarInfo.niNarHash = "sha256:def", + NarInfo.niNarSize = 200, + NarInfo.niReferences = ["aaaa-hello-1.0"], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + +-- --------------------------------------------------------------------------- +-- FileStore tests +-- --------------------------------------------------------------------------- + +testFileStore :: IO Bool +testFileStore = + runGroup + "FileStore" + [ test "narinfo write/read roundtrip" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + let hashKey = "testhash123" + content = TE.encodeUtf8 ("StorePath: /nix/store/test\n" :: Text) + wOk <- Store.writeNarInfo store hashKey content + result <- Store.readNarInfo store hashKey + removeDirectoryRecursive tmpDir + ok1 <- assertTrue "write succeeded" wOk + ok2 <- assertEqual "narinfo roundtrip" (Just content) result + pure (ok1 && ok2), + test "nar write/read roundtrip" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + let fileName = "test.nar.xz" + content = BS.pack [1, 2, 3, 4, 5] + wOk <- Store.writeNar store fileName content + result <- Store.readNar store fileName + removeDirectoryRecursive tmpDir + ok1 <- assertTrue "write succeeded" wOk + ok2 <- assertEqual "nar roundtrip" (Just content) result + pure (ok1 && ok2), + test "read nonexistent returns Nothing" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + result <- Store.readNarInfo store "nonexistent" + removeDirectoryRecursive tmpDir + assertEqual "not found" Nothing result, + test "cacheInfo defaults" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + let info = Store.getCacheInfo store + removeDirectoryRecursive tmpDir + ok1 <- assertEqual "storeDir" "/nix/store" (Store.ciStoreDir info) + ok2 <- assertTrue "wantMassQuery" (Store.ciWantMassQuery info) + ok3 <- assertEqual "priority" 50 (Store.ciPriority info) + pure (ok1 && ok2 && ok3), + test "sanitizePath rejects traversal" $ + assertEqual "dotdot" Nothing (Store.sanitizePath ".."), + test "sanitizePath rejects slash" $ + assertEqual "slash" Nothing (Store.sanitizePath "../../etc/passwd"), + test "sanitizePath rejects backslash" $ + assertEqual "backslash" Nothing (Store.sanitizePath "..\\..\\etc\\passwd"), + test "sanitizePath rejects empty" $ + assertEqual "empty" Nothing (Store.sanitizePath ""), + test "sanitizePath accepts valid hash" $ + assertEqual "valid" (Just "abc123def456") (Store.sanitizePath "abc123def456"), + test "sanitizePath rejects windows device name" $ + assertEqual "device nul" Nothing (Store.sanitizePath "nul"), + test "sanitizePath rejects the zero-numbered devices" $ do + ok1 <- assertEqual "com0" Nothing (Store.sanitizePath "com0") + ok2 <- assertEqual "lpt0" Nothing (Store.sanitizePath "lpt0") + ok3 <- assertEqual "com10 stays valid" (Just "com10") (Store.sanitizePath "com10") + pure (ok1 && ok2 && ok3), + test "sanitizePath rejects dotfile" $ + assertEqual "dotfile" Nothing (Store.sanitizePath ".hidden"), + test "sanitizePath rejects a trailing dot" $ + assertEqual "trailing dot" Nothing (Store.sanitizePath "foo."), + test "sanitizePath keeps interior dots valid" $ + assertEqual "interior dots" (Just "foo.nar.xz") (Store.sanitizePath "foo.nar.xz"), + test "read rejects traversal" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + result <- Store.readNarInfo store "../../etc/passwd" + removeDirectoryRecursive tmpDir + assertEqual "blocked" Nothing result, + test "writeNarInfo rejects traversal" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + ok <- Store.writeNarInfo store "../../etc/passwd" "bad" + removeDirectoryRecursive tmpDir + assertFalse "write rejected" ok, + test "writeNar rejects traversal" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + ok <- Store.writeNar store "../escape.nar" "bad" + removeDirectoryRecursive tmpDir + assertFalse "write rejected" ok, + test "listNarInfoHashes returns stored hashes" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + _ <- Store.writeNarInfo store "hash1" "content1" + _ <- Store.writeNarInfo store "hash2" "content2" + hashes <- Store.listNarInfoHashes store + removeDirectoryRecursive tmpDir + let sorted = sort hashes + assertEqual "listed hashes" ["hash1", "hash2"] sorted, + test "listNarInfoHashes empty store" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + hashes <- Store.listNarInfoHashes store + removeDirectoryRecursive tmpDir + assertEqual "empty" [] hashes + ] + +-- --------------------------------------------------------------------------- +-- Validate tests +-- --------------------------------------------------------------------------- + +-- | Bytes whose SHA-256 is used as the NarHash in 'mkValidNarInfo'. +validNarBytes :: ByteString +validNarBytes = BS.pack [1, 2, 3, 4, 5] + +-- | Bytes whose SHA-256 is used as the FileHash in 'mkValidNarInfo'. +validFileBytes :: ByteString +validFileBytes = BS.pack [10, 20, 30, 40, 50] + +-- | A narinfo that passes all field validation. +mkValidNarInfo :: NarInfo.NarInfo +mkValidNarInfo = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0", + NarInfo.niUrl = "nar/test.nar.xz", + NarInfo.niCompression = "xz", + NarInfo.niFileHash = Just (Hash.formatNixHash (Hash.hashBytes validFileBytes)), + NarInfo.niFileSize = Just 5, + NarInfo.niNarHash = Hash.formatNixHash (Hash.hashBytes validNarBytes), + NarInfo.niNarSize = 5, + NarInfo.niReferences = ["aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello-1.0"], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + +testValidate :: IO Bool +testValidate = + runGroup + "Validate" + [ test "validateNarInfo valid" $ + assertEqual + "valid narinfo" + (Right mkValidNarInfo) + (Validate.validateNarInfo mkValidNarInfo), + test "validateNarInfo negative FileSize" $ + let ni = mkValidNarInfo {NarInfo.niFileSize = Just (-1)} + in assertEqual + "negative filesize" + (Left [Validate.NegativeFileSize (-1)]) + (Validate.validateNarInfo ni), + test "validateNarInfo negative NarSize" $ + let ni = mkValidNarInfo {NarInfo.niNarSize = -1} + in assertEqual + "negative narsize" + (Left [Validate.NegativeNarSize (-1)]) + (Validate.validateNarInfo ni), + test "validateNarInfo derivation StorePath rejected" $ + let drvPath = "/nix/store/abc12345678901234567890123456789-foo.drv" + ni = mkValidNarInfo {NarInfo.niStorePath = drvPath} + in case Validate.validateNarInfo ni of + Left [Validate.DerivationStorePath raw] -> + assertEqual "raw value" drvPath raw + other -> do + putStrLn (" expected Left [DerivationStorePath ..], got: " ++ show other) + pure False, + test "validateNarInfo bad StorePath" $ + let ni = mkValidNarInfo {NarInfo.niStorePath = "not-a-store-path"} + in case Validate.validateNarInfo ni of + Left [Validate.InvalidStorePath raw _] -> + assertEqual "raw value" "not-a-store-path" raw + other -> do + putStrLn (" expected Left [InvalidStorePath ..], got: " ++ show other) + pure False, + test "validateNarInfo bad FileHash" $ + let ni = mkValidNarInfo {NarInfo.niFileHash = Just "md5:bogus"} + in case Validate.validateNarInfo ni of + Left [Validate.InvalidFileHash raw _] -> + assertEqual "raw value" "md5:bogus" raw + other -> do + putStrLn (" expected Left [InvalidFileHash ..], got: " ++ show other) + pure False, + test "validateNarInfo bad NarHash" $ + let ni = mkValidNarInfo {NarInfo.niNarHash = "md5:bogus"} + in case Validate.validateNarInfo ni of + Left [Validate.InvalidNarHash raw _] -> + assertEqual "raw value" "md5:bogus" raw + other -> do + putStrLn (" expected Left [InvalidNarHash ..], got: " ++ show other) + pure False, + test "validateNarInfo bad reference" $ + let ni = mkValidNarInfo {NarInfo.niReferences = ["bad"]} + in case Validate.validateNarInfo ni of + Left [Validate.InvalidReference raw _] -> + assertEqual "raw value" "bad" raw + other -> do + putStrLn (" expected Left [InvalidReference ..], got: " ++ show other) + pure False, + test "validateNarInfo multiple errors collected" $ + let ni = + mkValidNarInfo + { NarInfo.niFileSize = Just (-1), + NarInfo.niNarSize = -1, + NarInfo.niStorePath = "bad" + } + in case Validate.validateNarInfo ni of + Left errs -> assertTrue "at least 3 errors" (length errs >= 3) + Right _ -> do + putStrLn " expected Left, got Right" + pure False, + test "validateNarHash correct" $ + assertEqual + "correct nar hash" + (Right ()) + (Validate.validateNarHash mkValidNarInfo validNarBytes), + test "validateNarHash wrong" $ + case Validate.validateNarHash mkValidNarInfo (BS.pack [99]) of + Left (Validate.NarHashMismatch _ _) -> pure True + other -> do + putStrLn (" expected Left NarHashMismatch, got: " ++ show other) + pure False, + test "validateFileHash correct" $ + assertEqual + "correct file hash" + (Right ()) + (Validate.validateFileHash mkValidNarInfo validFileBytes), + test "validateFileHash wrong" $ + case Validate.validateFileHash mkValidNarInfo (BS.pack [99]) of + Left (Validate.FileHashMismatch _ _) -> pure True + other -> do + putStrLn (" expected Left FileHashMismatch, got: " ++ show other) + pure False, + test "validateSignature valid" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + ni = mkValidNarInfo + case Signing.sign sk ni of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right sig -> + let niSigned = ni {NarInfo.niSigs = [sig]} + in assertEqual "valid sig" (Right ()) (Validate.validateSignature pk niSigned), + test "validateSignature invalid" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + bogusSig = "bogus-key:aW52YWxpZA==" + ni = mkValidNarInfo {NarInfo.niSigs = [bogusSig]} + assertEqual + "invalid sig" + (Left [Validate.SignatureInvalid bogusSig]) + (Validate.validateSignature pk ni), + test "validateSignature no sigs" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + assertEqual + "no sigs" + (Left [Validate.NoSignatures]) + (Validate.validateSignature pk mkValidNarInfo), + test "validateFull all good" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + ni = mkValidNarInfo + case Signing.sign sk ni of + Left err -> do + putStrLn (" sign failed: " ++ err) + pure False + Right sig -> + let niSigned = ni {NarInfo.niSigs = [sig]} + in assertEqual + "full valid" + (Right ()) + (Validate.validateFull pk niSigned validNarBytes validFileBytes), + test "validateFull multiple failures" $ do + sk <- generateTestSecretKey + let pk = deriveTestPublicKey sk + ni = mkValidNarInfo {NarInfo.niFileSize = Just (-1), NarInfo.niNarSize = -1} + case Validate.validateFull pk ni (BS.pack [99]) (BS.pack [99]) of + Left errs -> assertTrue "at least 4 errors" (length errs >= 4) + Right _ -> do + putStrLn " expected Left, got Right" + pure False + ] + +-- --------------------------------------------------------------------------- +-- Server (WAI) tests +-- --------------------------------------------------------------------------- + +-- | The write key the authenticated-server tests configure. +serverTestApiKey :: ByteString +serverTestApiKey = "test-api-key" + +-- | The Authorization header 'serverTestApiKey' expects. +serverAuthHeader :: HTTP.Header +serverAuthHeader = (HTTP.hAuthorization, "Bearer " <> serverTestApiKey) + +-- | Store-path hash of 'validServerNarInfo' (32 nix-base32 zeros). +validNarInfoHashKey :: Text +validNarInfoHashKey = T.replicate 32 "0" + +-- | A canonical all-zero sha256 in nix-base32: 52 digits, and the 4 +-- spare bits of the 260-bit encoding are zero, so it parses. +zeroNarHash :: Text +zeroNarHash = "sha256:" <> T.replicate 52 "0" + +-- | A narinfo that passes 'Validate.validateNarInfo' end to end, keyed +-- under 'validNarInfoHashKey'. +validServerNarInfo :: NarInfo.NarInfo +validServerNarInfo = + NarInfo.NarInfo + { NarInfo.niStorePath = "/nix/store/" <> validNarInfoHashKey <> "-hello-1.0", + NarInfo.niUrl = "nar/test.nar", + NarInfo.niCompression = "none", + NarInfo.niFileHash = Nothing, + NarInfo.niFileSize = Nothing, + NarInfo.niNarHash = zeroNarHash, + NarInfo.niNarSize = 200, + NarInfo.niReferences = [validNarInfoHashKey <> "-hello-1.0"], + NarInfo.niDeriver = Nothing, + NarInfo.niSigs = [], + NarInfo.niCA = Nothing + } + +-- | Rendered wire form of 'validServerNarInfo'. +validServerNarInfoBytes :: BL.ByteString +validServerNarInfoBytes = + BL.fromStrict (TE.encodeUtf8 (NarInfo.renderNarInfo validServerNarInfo)) + +-- | Run one test against a fresh server (configurable write key and +-- signing key), removing the store directory afterwards. +withServer :: Maybe ByteString -> Maybe Signing.SecretKey -> (Server.ServerConfig -> IO Bool) -> IO Bool +withServer apiKey sigKey body = do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + passed <- + body + Server.ServerConfig + { Server.scStore = store, + Server.scApiKey = apiKey, + Server.scSigningKey = sigKey, + Server.scRootResponse = Server.defaultRootResponse + } + removeDirectoryRecursive tmpDir + pure passed + +-- | 'withServer' with write auth armed and no signing - the common case. +withAuthedServer :: (Server.ServerConfig -> IO Bool) -> IO Bool +withAuthedServer = withServer (Just serverTestApiKey) Nothing + +-- | Execute a single request against the server. +serverRequest :: Server.ServerConfig -> BS.ByteString -> [Text] -> [HTTP.Header] -> BL.ByteString -> IO WT.SResponse +serverRequest cfg method segments headers body = + WT.runSession (WT.srequest (WT.SRequest req body)) (Server.cacheApp cfg) + where + req = + defaultRequest + { requestMethod = method, + pathInfo = segments, + requestHeaders = headers + } + +-- | Like 'serverRequest', with a declared Content-Length - for the +-- reject-before-reading limit checks. +serverRequestSized :: Server.ServerConfig -> BS.ByteString -> [Text] -> [HTTP.Header] -> Word -> IO WT.SResponse +serverRequestSized cfg method segments headers declared = + WT.runSession (WT.srequest (WT.SRequest req "")) (Server.cacheApp cfg) + where + req = + defaultRequest + { requestMethod = method, + pathInfo = segments, + requestHeaders = headers, + requestBodyLength = KnownLength (fromIntegral declared) + } + +-- | A chunk source yielding the given chunks, then empty (end of input). +chunkSource :: [ByteString] -> IO (IO ByteString) +chunkSource chunks = do + remaining <- newIORef chunks + pure $ + atomicModifyIORef' remaining $ \case + [] -> ([], BS.empty) + (c : cs) -> (cs, c) + +-- | Body bytes as strict ByteString, for infix assertions. +strictBody :: WT.SResponse -> ByteString +strictBody = BL.toStrict . WT.simpleBody + +testServer :: IO Bool +testServer = + runGroup + "Server" + [ test "GET / serves the default root response" $ + withServer Nothing Nothing $ \cfg -> do + resp <- serverRequest cfg "GET" [] [] "" + ok1 <- assertEqual "status" HTTP.status200 (WT.simpleStatus resp) + ok2 <- assertEqual "body" "nova-cache: a Nix binary cache\n" (WT.simpleBody resp) + pure (ok1 && ok2), + -- newTTLCache: within the TTL the action runs once; a zero TTL + -- never satisfies the freshness check, so every call re-runs. + test "newTTLCache memoizes within the TTL and re-runs past it" $ do + counter <- newIORef (0 :: Int) + let bump = atomicModifyIORef' counter (\n -> (n + 1, n + 1)) + cachedHour <- Server.newTTLCache 3600 bump + firstRead <- cachedHour + secondRead <- cachedHour + cachedNever <- Server.newTTLCache 0 bump + thirdRead <- cachedNever + fourthRead <- cachedNever + ok1 <- assertEqual "memoized" (1, 1) (firstRead, secondRead) + ok2 <- assertEqual "re-run each call" (2, 3) (thirdRead, fourthRead) + pure (ok1 && ok2), + test "GET /nix-cache-info renders cache metadata" $ + withServer Nothing Nothing $ \cfg -> do + resp <- serverRequest cfg "GET" ["nix-cache-info"] [] "" + ok1 <- assertEqual "status" HTTP.status200 (WT.simpleStatus resp) + ok2 <- assertTrue "StoreDir line" (BS.isInfixOf "StoreDir: /nix/store" (strictBody resp)) + pure (ok1 && ok2), + test "unknown route is 404" $ + withServer Nothing Nothing $ \cfg -> do + resp <- serverRequest cfg "GET" ["no", "such", "route"] [] "" + assertEqual "status" HTTP.status404 (WT.simpleStatus resp), + -- HEAD is routed exactly like GET (upstream clients probe narinfo + -- existence with HEAD; it used to fall through to 404). + test "HEAD is served wherever GET is" $ + withServer Nothing Nothing $ \cfg -> do + okResp <- serverRequest cfg "HEAD" ["nix-cache-info"] [] "" + missingResp <- serverRequest cfg "HEAD" [validNarInfoHashKey <> ".narinfo"] [] "" + ok1 <- assertEqual "present" HTTP.status200 (WT.simpleStatus okResp) + ok2 <- assertEqual "absent" HTTP.status404 (WT.simpleStatus missingResp) + pure (ok1 && ok2), + -- Write authentication + test "PUT narinfo without auth is 401" $ + withAuthedServer $ \cfg -> do + resp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [] validServerNarInfoBytes + assertEqual "status" HTTP.status401 (WT.simpleStatus resp), + test "PUT narinfo with the wrong key is 401" $ + withAuthedServer $ \cfg -> do + let wrongAuth = (HTTP.hAuthorization, "Bearer not-the-key") + resp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [wrongAuth] validServerNarInfoBytes + assertEqual "status" HTTP.status401 (WT.simpleStatus resp), + test "PUT then GET narinfo roundtrip" $ + withAuthedServer $ \cfg -> do + putResp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] validServerNarInfoBytes + getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" + ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) + ok2 <- assertEqual "GET status" HTTP.status200 (WT.simpleStatus getResp) + ok3 <- assertTrue "StorePath present" (BS.isInfixOf (TE.encodeUtf8 validNarInfoHashKey) (strictBody getResp)) + ok4 <- + assertEqual + "revalidatable, never immutable" + (Just "public, max-age=3600, must-revalidate") + (lookup HTTP.hCacheControl (WT.simpleHeaders getResp)) + pure (ok1 && ok2 && ok3 && ok4), + test "PUT narinfo signs when a key is configured" $ do + sigKey <- generateTestSecretKey + withServer (Just serverTestApiKey) (Just sigKey) $ \cfg -> do + putResp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] validServerNarInfoBytes + getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" + ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) + ok2 <- assertTrue "Sig line present" (BS.isInfixOf "Sig: test-key:" (strictBody getResp)) + pure (ok1 && ok2), + -- The confused-deputy gate: a narinfo describing path X cannot be + -- stored under path Y's key. + test "PUT narinfo under a mismatched hash is 400" $ + withAuthedServer $ \cfg -> do + let otherKey = T.replicate 32 "1" <> ".narinfo" + resp <- serverRequest cfg "PUT" [otherKey] [serverAuthHeader] validServerNarInfoBytes + assertEqual "status" HTTP.status400 (WT.simpleStatus resp), + test "PUT malformed narinfo is 400" $ + withAuthedServer $ \cfg -> do + resp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] "not a narinfo" + assertEqual "status" HTTP.status400 (WT.simpleStatus resp), + test "PUT narinfo with an oversized declared length is 413" $ + withAuthedServer $ \cfg -> do + resp <- + serverRequestSized + cfg + "PUT" + [validNarInfoHashKey <> ".narinfo"] + [serverAuthHeader] + (fromIntegral Server.maxNarInfoBodySize + 1) + assertEqual "status" HTTP.status413 (WT.simpleStatus resp), + -- The hash listing is push-tool plumbing: authenticated, uncacheable. + test "GET /narinfo-hashes without auth is 401" $ + withAuthedServer $ \cfg -> do + resp <- serverRequest cfg "GET" ["narinfo-hashes"] [] "" + assertEqual "status" HTTP.status401 (WT.simpleStatus resp), + test "GET /narinfo-hashes with auth lists hashes, uncacheable" $ + withAuthedServer $ \cfg -> do + putResp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] validServerNarInfoBytes + resp <- serverRequest cfg "GET" ["narinfo-hashes"] [serverAuthHeader] "" + ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) + ok2 <- assertEqual "status" HTTP.status200 (WT.simpleStatus resp) + ok3 <- assertTrue "uploaded hash listed" (BS.isInfixOf (TE.encodeUtf8 validNarInfoHashKey) (strictBody resp)) + ok4 <- assertEqual "no-store" (Just "no-store") (lookup HTTP.hCacheControl (WT.simpleHeaders resp)) + pure (ok1 && ok2 && ok3 && ok4), + test "GET /narinfo-hashes in open mode needs no auth" $ + withServer Nothing Nothing $ \cfg -> do + resp <- serverRequest cfg "GET" ["narinfo-hashes"] [] "" + assertEqual "status" HTTP.status200 (WT.simpleStatus resp), + -- NAR transfer + test "PUT then GET and HEAD a NAR" $ + withAuthedServer $ \cfg -> do + putResp <- serverRequest cfg "PUT" ["nar", "test.nar"] [serverAuthHeader] "nar-payload-bytes" + getResp <- serverRequest cfg "GET" ["nar", "test.nar"] [] "" + headResp <- serverRequest cfg "HEAD" ["nar", "test.nar"] [] "" + ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) + ok2 <- assertEqual "GET status" HTTP.status200 (WT.simpleStatus getResp) + ok3 <- assertEqual "GET body" "nar-payload-bytes" (WT.simpleBody getResp) + ok4 <- + assertEqual + "immutable content address" + (Just "public, max-age=31536000, immutable") + (lookup HTTP.hCacheControl (WT.simpleHeaders getResp)) + ok5 <- assertEqual "HEAD status" HTTP.status200 (WT.simpleStatus headResp) + pure (ok1 && ok2 && ok3 && ok4 && ok5), + test "PUT NAR without auth is 401" $ + withAuthedServer $ \cfg -> do + resp <- serverRequest cfg "PUT" ["nar", "test.nar"] [] "nar-payload-bytes" + assertEqual "status" HTTP.status401 (WT.simpleStatus resp), + test "PUT NAR with a traversal name is 400" $ + withAuthedServer $ \cfg -> do + resp <- serverRequest cfg "PUT" ["nar", ".."] [serverAuthHeader] "escape" + assertEqual "status" HTTP.status400 (WT.simpleStatus resp), + test "PUT NAR with an oversized declared length is 413" $ + withAuthedServer $ \cfg -> do + resp <- + serverRequestSized + cfg + "PUT" + ["nar", "test.nar"] + [serverAuthHeader] + (fromIntegral Server.maxNarBodySize + 1) + assertEqual "status" HTTP.status413 (WT.simpleStatus resp), + test "GET absent NAR is 404" $ + withServer Nothing Nothing $ \cfg -> do + resp <- serverRequest cfg "GET" ["nar", "absent.nar"] [] "" + assertEqual "status" HTTP.status404 (WT.simpleStatus resp), + -- Streaming write, at the store layer + test "writeNarStreaming writes chunks and lands atomically" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + source <- chunkSource ["ab", "cd", "ef"] + result <- Store.writeNarStreaming store "streamed.nar" 16 source + stored <- Store.readNar store "streamed.nar" + located <- Store.narFilePath store "streamed.nar" + removeDirectoryRecursive tmpDir + ok1 <- assertEqual "result" Store.NarWriteOk result + ok2 <- assertEqual "content" (Just "abcdef") stored + ok3 <- assertTrue "narFilePath resolves" (isJust located) + pure (ok1 && ok2 && ok3), + test "writeNarStreaming over the cap deletes the partial file" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + source <- chunkSource ["four", "more", "over"] + result <- Store.writeNarStreaming store "big.nar" 8 source + leftovers <- listDirectory (tmpDir ++ "/nar") + removeDirectoryRecursive tmpDir + ok1 <- assertEqual "result" Store.NarWriteTooLarge result + ok2 <- assertEqual "no partial files" [] leftovers + pure (ok1 && ok2), + test "writeNarStreaming rejects a traversal name" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + source <- chunkSource ["x"] + result <- Store.writeNarStreaming store "../escape" 8 source + removeDirectoryRecursive tmpDir + assertEqual "result" Store.NarWriteBadPath result, + test "narFilePath rejects a traversal name" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + located <- Store.narFilePath store "../escape" + removeDirectoryRecursive tmpDir + assertEqual "path" Nothing located + ] + +-- --------------------------------------------------------------------------- +-- Helpers +-- --------------------------------------------------------------------------- + +-- | A fresh, unique directory under the system temp dir. A fixed +-- machine-global path poisons later runs whenever cleanup is skipped and +-- races concurrent checkouts; probing numbered names until createDirectory +-- succeeds gives uniqueness against both. +createTestDir :: IO FilePath +createTestDir = do + base <- getTemporaryDirectory + probe base (0 :: Int) + where + probe base n = do + let dir = base ++ "/nova-cache-test-" ++ show n + made <- try (createDirectory dir) :: IO (Either SomeException ()) + case made of + Right () -> pure dir + Left _ -> probe base (n + 1) -- | Generate a test Ed25519 secret key using crypton. generateTestSecretKey :: IO Signing.SecretKey diff --git a/test/XzTest.hs b/test/XzTest.hs new file mode 100644 --- /dev/null +++ b/test/XzTest.hs @@ -0,0 +1,276 @@ +-- | Tests for the bounded xz decoder. A separate suite because the +-- decoder lives in the nova-cache:xz sublibrary; the fixtures are real @xz -6@ +-- output embedded as hex, so no external tool runs at test time. +module Main (main) where + +import Control.Exception (throwIO, try) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char (isDigit) +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified NovaCache.Xz as Xz +import System.Exit (exitFailure, exitSuccess) +import System.IO (hFlush, stdout) +import System.IO.Error (isUserError) + +-- --------------------------------------------------------------------------- +-- Harness (mirrors test/Main.hs) +-- --------------------------------------------------------------------------- + +test :: String -> IO Bool -> IO Bool +test name action = do + putStr (" " ++ name ++ "... ") + hFlush stdout + result <- action + putStrLn (if result then "OK" else "FAILED") + pure result + +assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool +assertEqual label expected actual + | expected == actual = pure True + | otherwise = do + putStrLn "" + putStrLn (" " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual: " ++ show actual) + pure False + +assertTrue :: String -> Bool -> IO Bool +assertTrue _ True = pure True +assertTrue label False = do + putStrLn "" + putStrLn (" " ++ label ++ ": expected True") + pure False + +-- --------------------------------------------------------------------------- +-- Fixtures +-- --------------------------------------------------------------------------- + +-- | Decode a hex fixture literal. Fixtures are constants, so a +-- malformed one decodes short and the assertions fail loudly. +unhex :: String -> ByteString +unhex = BS.pack . pairs + where + pairs (hi : lo : rest) = case (hexVal hi, hexVal lo) of + (Just h, Just l) -> fromIntegral (h * 16 + l) : pairs rest + _ -> [] + pairs _ = [] + hexVal c + | isDigit c = Just (fromEnum c - fromEnum '0') + | c >= 'a' && c <= 'f' = Just (fromEnum c - fromEnum 'a' + 10) + | otherwise = Nothing + +-- | @xz -6@ of "nova-cache xz fixture\n" (22 bytes of output). +textXz :: ByteString +textXz = + unhex + "fd377a585a000004e6d6b44604c01a162101160000000000000000001caa3b74\ + \0100156e6f76612d636163686520787a20666978747572650a0000002c84d5d2\ + \3c233719000136160f914e5d1fb6f37d010000000004595a" + +-- | The bytes 'textXz' decompresses to. +textPlain :: ByteString +textPlain = "nova-cache xz fixture\n" + +-- | @xz -6@ of 65536 zero bytes: 148 bytes in, 64 KiB out - the +-- expansion shape the output bound exists for. The stream declares +-- an 8 MiB dictionary, which the memory-bound test leans on. +zerosXz :: ByteString +zerosXz = + unhex + "fd377a585a000004e6d6b44604c05480800421011600000000000000e6b515ff\ + \e0ffff004c5d00006ffdffffa3b7ff473e481572396151b89228e6a38607f9ee\ + \e41e82d32fc53a3c014bb17ec98a8a4d2fa30dd97fa6e38c231153e05918c575\ + \8ae277f8b6947f0c6ac0de7449645c9e3ad100005e654f49ca09af2600017080\ + \800400006977c193b1c467fb020000000004595a" + +-- | Output size of 'zerosXz'. +zerosLength :: Word +zerosLength = 65536 + +-- | Generous limits for the happy paths. +openLimits :: Xz.XzLimits +openLimits = + Xz.XzLimits + { Xz.xzMaxOutputBytes = 1024 * 1024, + Xz.xzMaxDecoderMemoryBytes = Xz.defaultXzDecoderMemoryBytes + } + +-- | 'openLimits' with the output bound replaced. +boundedTo :: Word -> Xz.XzLimits +boundedTo bound = openLimits {Xz.xzMaxOutputBytes = fromIntegral bound} + +-- | Split a byte string into fixed-size pieces. +chunksOf :: Int -> ByteString -> [ByteString] +chunksOf n bs + | BS.null bs = [] + | otherwise = case BS.splitAt n bs of + (piece, rest) -> piece : chunksOf n rest + +-- | A chunk source over a fixed list (empty chunk on exhaustion), for +-- feeding 'Xz.withXzSource'. +listSource :: [ByteString] -> IO (IO ByteString) +listSource chunks = scriptedSource (map pure chunks) + +-- | A chunk source that performs the given actions in order and +-- returns the empty chunk after they run out; an action may throw, +-- which is how the errored-source tests stage a failure. +scriptedSource :: [IO ByteString] -> IO (IO ByteString) +scriptedSource steps = do + remaining <- newIORef steps + pure $ do + held <- readIORef remaining + case held of + [] -> pure BS.empty + (act : rest) -> do + writeIORef remaining rest + act + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +main :: IO () +main = do + putStrLn "nova-cache xz test suite" + putStrLn "========================" + results <- + sequence + [ test "roundtrip under the exact output bound" $ + -- NarSize is exact, so output == bound must pass. + assertEqual + "text fixture" + (Right textPlain) + (Xz.decompress (boundedTo (fromIntegral (BS.length textPlain))) textXz), + test "high-expansion input inflates fully under an open bound" $ + case Xz.decompress openLimits zerosXz of + Left err -> do + putStrLn (" unexpected error: " ++ show err) + pure False + Right out -> do + ok1 <- assertEqual "length" zerosLength (fromIntegral (BS.length out)) + ok2 <- assertTrue "all zero" (BS.all (== 0) out) + pure (ok1 && ok2), + test "output over the bound is refused" $ + assertEqual + "far bound" + (Left (Xz.XzOutputOverBound 1000)) + (Xz.decompress (boundedTo 1000) zerosXz), + test "one byte under the true size is refused" $ + assertEqual + "tight bound" + (Left (Xz.XzOutputOverBound (fromIntegral (zerosLength - 1)))) + (Xz.decompress (boundedTo (zerosLength - 1)) zerosXz), + test "garbage input is a stream error" $ + assertTrue "garbage" (isStreamError (Xz.decompress openLimits "not an xz stream")), + test "a truncated stream is diagnosed as truncated" $ + -- The binding reports truncation as LzmaRetBufError (or + -- LzmaRetOK); the message must be the diagnosis, not the + -- raw constructor. + assertEqual + "truncated" + (Left (Xz.XzStreamError Xz.truncatedInputMessage)) + (Xz.decompress openLimits (BS.take 40 textXz)), + test "empty input is diagnosed as truncated" $ + -- Zero bytes drive the decoder straight to end of input + -- while the binding still reports LzmaRetOK, which shown + -- raw would read as success. + assertEqual + "empty input" + (Left (Xz.XzStreamError Xz.truncatedInputMessage)) + (Xz.decompress openLimits BS.empty), + test "concatenated streams decode as one output" $ + -- Upstream decodes with LZMA_CONCATENATED; two streams + -- back-to-back are one valid input. + assertEqual + "two text streams" + (Right (textPlain <> textPlain)) + (Xz.decompress openLimits (textXz <> textXz)), + test "trailing garbage after the stream is refused" $ + assertTrue + "trailing garbage" + (isStreamError (Xz.decompress openLimits (textXz <> "garbage!"))), + test "a dictionary past the memory bound is refused" $ + -- zerosXz declares an 8 MiB dictionary; cap the decoder at 1 MiB. + assertEqual + "memory bound" + (Left (Xz.XzMemoryOverBound smallMemory)) + (Xz.decompress openLimits {Xz.xzMaxDecoderMemoryBytes = smallMemory} zerosXz), + test "withXzSource decompresses a chunked source" $ do + source <- listSource (chunksOf 7 textXz) + out <- Xz.withXzSource openLimits source drainSource + assertEqual "streamed output" textPlain out, + test "withXzSource succeeds at the exact output bound" $ do + -- NarSize is exact, so the streaming path must accept + -- output == bound just as the pure path does. + source <- listSource (chunksOf 7 textXz) + out <- + Xz.withXzSource + (boundedTo (fromIntegral (BS.length textPlain))) + source + drainSource + assertEqual "exact-bound streamed output" textPlain out, + test "withXzSource throws past the output bound" $ do + source <- listSource (chunksOf 16 zerosXz) + outcome <- + try (Xz.withXzSource (boundedTo 1000) source drainSource) :: + IO (Either Xz.XzError ByteString) + assertEqual "thrown" (Left (Xz.XzOutputOverBound 1000)) outcome, + test "withXzSource keeps returning empty after the end" $ do + source <- listSource [textXz] + ends <- Xz.withXzSource openLimits source $ \pull -> do + _ <- drainSource pull + endA <- pull + endB <- pull + pure (endA, endB) + assertEqual "stable end" ("", "") ends, + test "withXzSource re-throws the same error on pulls after a failure" $ do + -- A caught error must not turn the next pull into the empty + -- chunk, the clean-end signal; a failed source stays failed. + source <- listSource (chunksOf 16 zerosXz) + Xz.withXzSource (boundedTo 1000) source $ \pull -> do + firstPull <- try (drainSource pull) :: IO (Either Xz.XzError ByteString) + secondPull <- try pull :: IO (Either Xz.XzError ByteString) + okFirst <- + assertEqual "first pull" (Left (Xz.XzOutputOverBound 1000)) firstPull + okSecond <- + assertEqual "later pull" (Left (Xz.XzOutputOverBound 1000)) secondPull + pure (okFirst && okSecond), + test "a source failure never becomes a clean end" $ do + -- The source delivers a full stream, errors on the pull + -- that would confirm the end, then reads as exhausted. An + -- unlatched decoder would answer the retry with the empty + -- chunk - a failed transfer posing as complete output. + source <- + scriptedSource [pure textXz, throwIO (userError sourceFailureText)] + Xz.withXzSource openLimits source $ \pull -> do + chunk <- pull + firstPull <- try pull :: IO (Either IOError ByteString) + laterPull <- try pull :: IO (Either IOError ByteString) + okChunk <- assertEqual "decoded chunk" textPlain chunk + okFirst <- assertTrue "first pull throws" (either isUserError (const False) firstPull) + okLater <- assertTrue "later pull throws" (either isUserError (const False) laterPull) + pure (okChunk && okFirst && okLater) + ] + if and results + then do + putStrLn "" + putStrLn ("All " ++ show (length results) ++ " tests passed.") + exitSuccess + else do + putStrLn "" + putStrLn "Some tests FAILED." + exitFailure + where + smallMemory = 1024 * 1024 + sourceFailureText = "staged transfer failure" + isStreamError outcome = case outcome of + Left (Xz.XzStreamError _) -> True + _ -> False + drainSource pull = go [] + where + go acc = do + chunk <- pull + if BS.null chunk + then pure (BS.concat (reverse acc)) + else go (chunk : acc) diff --git a/test/ZstdTest.hs b/test/ZstdTest.hs new file mode 100644 --- /dev/null +++ b/test/ZstdTest.hs @@ -0,0 +1,326 @@ +-- | Tests for the bounded zstd codec. A separate suite because the +-- codec lives in the nova-cache:zstandard sublibrary. Most +-- compressed fixtures come from the sublibrary's own pure +-- 'Zstd.compress'; two frames are embedded as bytes produced offline +-- by the reference zstd CLI (v1.5.7), grounding the decoder against +-- the reference encoder - no external tool runs at test time. +module Main (main) where + +import Control.Exception (throwIO, try) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (isJust, isNothing) +import Data.Word (Word8) +import qualified NovaCache.Zstd as Zstd +import System.Exit (exitFailure, exitSuccess) +import System.IO (hFlush, stdout) +import System.IO.Error (isUserError) + +-- --------------------------------------------------------------------------- +-- Harness (mirrors test/XzTest.hs) +-- --------------------------------------------------------------------------- + +test :: String -> IO Bool -> IO Bool +test name action = do + putStr (" " ++ name ++ "... ") + hFlush stdout + result <- action + putStrLn (if result then "OK" else "FAILED") + pure result + +assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool +assertEqual label expected actual + | expected == actual = pure True + | otherwise = do + putStrLn "" + putStrLn (" " ++ label) + putStrLn (" expected: " ++ show expected) + putStrLn (" actual: " ++ show actual) + pure False + +assertTrue :: String -> Bool -> IO Bool +assertTrue _ True = pure True +assertTrue label False = do + putStrLn "" + putStrLn (" " ++ label ++ ": expected True") + pure False + +-- --------------------------------------------------------------------------- +-- Fixtures +-- --------------------------------------------------------------------------- + +-- | Compressible ASCII payload, 2048 bytes. +payload :: ByteString +payload = BS.concat (replicate 64 "nova-cache zstd fixture payload\n") + +payloadSize :: Word +payloadSize = fromIntegral (BS.length payload) + +limitsOf :: Word -> Zstd.ZstdLimits +limitsOf n = Zstd.ZstdLimits {Zstd.zstdMaxOutputBytes = fromIntegral n} + +compressedPayload :: ByteString +compressedPayload = Zstd.compress Zstd.defaultCompressionLevel payload + +-- | A byte no zstd magic number starts with, for trailing-garbage +-- tails. +garbageByte :: Word8 +garbageByte = 0x47 + +-- | What 'referenceFrame' decompresses to: 16 copies of the +-- reference line, 544 bytes. +referencePayload :: ByteString +referencePayload = BS.concat (replicate 16 "nova-cache zstd reference fixture\n") + +-- | 'referencePayload' compressed offline by the reference CLI +-- (@zstd -3@ over a pipe, so the header carries no content size and +-- an XXH64 content checksum), byte for byte. +referenceFrame :: ByteString +referenceFrame = + BS.pack + [ 0x28, + 0xb5, + 0x2f, + 0xfd, + 0x04, + 0x58, + 0x5d, + 0x01, + 0x00, + 0x24, + 0x02, + 0x6e, + 0x6f, + 0x76, + 0x61, + 0x2d, + 0x63, + 0x61, + 0x63, + 0x68, + 0x65, + 0x20, + 0x7a, + 0x73, + 0x74, + 0x64, + 0x20, + 0x72, + 0x65, + 0x66, + 0x65, + 0x72, + 0x65, + 0x6e, + 0x63, + 0x65, + 0x20, + 0x66, + 0x69, + 0x78, + 0x74, + 0x75, + 0x72, + 0x65, + 0x0a, + 0x01, + 0x00, + 0xda, + 0x2f, + 0xaa, + 0x7a, + 0x02, + 0xd1, + 0x58, + 0x21, + 0xe9 + ] + +-- | A frame whose header declares a 1 GiB window (@zstd --long=30@ +-- over a pipe, offline): past libzstd's default window limit +-- (@ZSTD_WINDOWLOG_LIMIT_DEFAULT@, 2^27 = 128 MiB), so the decoder +-- must refuse rather than allocate what the peer's header asks for. +wideWindowFrame :: ByteString +wideWindowFrame = + BS.pack + [ 0x28, + 0xb5, + 0x2f, + 0xfd, + 0x04, + 0xa0, + 0x69, + 0x00, + 0x00, + 0x77, + 0x69, + 0x6e, + 0x64, + 0x6f, + 0x77, + 0x20, + 0x70, + 0x72, + 0x6f, + 0x62, + 0x65, + 0x0a, + 0x46, + 0x3e, + 0x21, + 0x43 + ] + +-- | A pull source yielding the given chunks, then empty forever. +chunkSource :: [ByteString] -> IO (IO ByteString) +chunkSource chunks = scriptedSource (map pure chunks) + +-- | A pull source that performs the given actions in order and +-- returns the empty chunk after they run out; an action may throw, +-- which is how the errored-source tests stage a failure. +scriptedSource :: [IO ByteString] -> IO (IO ByteString) +scriptedSource steps = do + ref <- newIORef steps + pure $ do + remaining <- readIORef ref + case remaining of + [] -> pure BS.empty + (act : rest) -> writeIORef ref rest >> act + +-- | Split a payload into bounded chunks so the streaming path sees +-- many small feeds, as a network body would deliver. +chunksOf :: Int -> ByteString -> [ByteString] +chunksOf n bs + | BS.null bs = [] + | otherwise = BS.take n bs : chunksOf n (BS.drop n bs) + +-- | Drain a decompressed pull source into one strict ByteString. +collectSource :: IO ByteString -> IO ByteString +collectSource pull = go [] + where + go acc = do + chunk <- pull + if BS.null chunk + then pure (BS.concat (reverse acc)) + else go (chunk : acc) + +isStreamError :: Either Zstd.ZstdError a -> Bool +isStreamError (Left (Zstd.ZstdStreamError _)) = True +isStreamError _ = False + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +main :: IO () +main = do + putStrLn "zstd" + results <- + sequence + [ test "roundtrip under the exact bound" $ do + out <- Zstd.decompress (limitsOf payloadSize) compressedPayload + assertEqual "roundtrip" (Right payload) out, + test "one byte under the real size refuses" $ do + out <- Zstd.decompress (limitsOf (payloadSize - 1)) compressedPayload + assertEqual "over-bound" (Left (Zstd.ZstdOutputOverBound (fromIntegral (payloadSize - 1)))) out, + test "garbage refuses" $ do + out <- Zstd.decompress (limitsOf 64) "not a zstd stream" + assertTrue "stream error" (isStreamError out), + test "concatenated frames decode as one output" $ do + let second = BS.concat (replicate 8 "second frame\n") + joined = compressedPayload <> Zstd.compress Zstd.defaultCompressionLevel second + out <- Zstd.decompress (limitsOf (payloadSize + fromIntegral (BS.length second))) joined + assertEqual "concatenated" (Right (payload <> second)) out, + test "trailing garbage after a frame refuses" $ do + out <- Zstd.decompress (limitsOf (payloadSize + 64)) (compressedPayload <> "trailing garbage") + assertTrue "trailing" (isStreamError out), + test "trailing garbage of one to four bytes refuses" $ do + outs <- + mapM + ( \n -> + Zstd.decompress + (limitsOf (payloadSize + 64)) + (compressedPayload <> BS.replicate n garbageByte) + ) + [1 .. 4] + assertTrue "each tail refuses" (all isStreamError outs), + test "truncated input refuses" $ do + out <- Zstd.decompress (limitsOf payloadSize) (BS.dropEnd 5 compressedPayload) + assertTrue "truncated" (isStreamError out), + test "empty input is empty output" $ do + out <- Zstd.decompress (limitsOf 0) BS.empty + assertEqual "empty" (Right BS.empty) out, + test "reference CLI frame roundtrips" $ do + out <- + Zstd.decompress + (limitsOf (fromIntegral (BS.length referencePayload))) + referenceFrame + assertEqual "reference" (Right referencePayload) out, + test "window past the default limit refuses" $ do + out <- Zstd.decompress (limitsOf 4096) wideWindowFrame + assertTrue "wide window" (isStreamError out), + test "compression level constructor enforces the range" $ + pure + ( isNothing (Zstd.zstdCompressionLevel 0) + && isJust (Zstd.zstdCompressionLevel 1) + && isJust (Zstd.zstdCompressionLevel Zstd.maxCompressionLevel) + && isNothing (Zstd.zstdCompressionLevel (Zstd.maxCompressionLevel + 1)) + ), + test "roundtrip at a constructed level" $ + case Zstd.zstdCompressionLevel 19 of + Nothing -> assertTrue "level 19 representable" False + Just level -> do + out <- Zstd.decompress (limitsOf payloadSize) (Zstd.compress level payload) + assertEqual "constructed level" (Right payload) out, + test "source: chunked roundtrip" $ do + source <- chunkSource (chunksOf 7 compressedPayload) + out <- Zstd.withZstdSource (limitsOf payloadSize) source collectSource + assertEqual "source roundtrip" payload out, + test "source: over-bound throws" $ do + source <- chunkSource (chunksOf 7 compressedPayload) + out <- try (Zstd.withZstdSource (limitsOf (payloadSize - 1)) source collectSource) + assertEqual "source over-bound" (Left (Zstd.ZstdOutputOverBound (fromIntegral (payloadSize - 1)))) out, + test "source: garbage throws" $ do + source <- chunkSource ["not a zstd stream"] + out <- try (Zstd.withZstdSource (limitsOf 64) source collectSource) :: IO (Either Zstd.ZstdError ByteString) + assertTrue "source garbage" (isStreamError out), + test "source: truncated input throws" $ do + source <- chunkSource (chunksOf 7 (BS.dropEnd 5 compressedPayload)) + out <- try (Zstd.withZstdSource (limitsOf payloadSize) source collectSource) :: IO (Either Zstd.ZstdError ByteString) + assertTrue "source truncated" (isStreamError out), + test "source: pull after an error keeps throwing" $ do + source <- chunkSource ["not a zstd stream"] + Zstd.withZstdSource (limitsOf 64) source $ \pull -> do + first <- try pull :: IO (Either Zstd.ZstdError ByteString) + second <- try pull :: IO (Either Zstd.ZstdError ByteString) + initial <- assertTrue "first pull throws" (isStreamError first) + repeated <- assertEqual "second pull rethrows the same error" first second + pure (initial && repeated), + test "source: a source failure never becomes a clean end" $ do + -- The source delivers a full frame, errors on the pull that + -- would confirm the end, then reads as exhausted. An + -- unlatched decoder would answer the retry with the empty + -- chunk - a failed transfer posing as complete output. + source <- + scriptedSource [pure compressedPayload, throwIO (userError sourceFailureText)] + Zstd.withZstdSource (limitsOf payloadSize) source $ \pull -> do + chunk <- pull + firstPull <- try pull :: IO (Either IOError ByteString) + laterPull <- try pull :: IO (Either IOError ByteString) + okChunk <- assertEqual "decoded chunk" payload chunk + okFirst <- assertTrue "first pull throws" (either isUserError (const False) firstPull) + okLater <- assertTrue "later pull throws" (either isUserError (const False) laterPull) + pure (okChunk && okFirst && okLater) + ] + if and results + then do + putStrLn "" + putStrLn ("All " ++ show (length results) ++ " tests passed.") + exitSuccess + else do + putStrLn "" + putStrLn "Some tests FAILED." + exitFailure + where + sourceFailureText = "staged transfer failure"