nova-cache 0.4.2.1 → 0.7.0.0
raw patch · 17 files changed
Files
- CHANGELOG.md +39/−0
- NOTICE +6/−0
- README.md +13/−9
- exe/LandingPage.hs +114/−0
- exe/Main.hs +79/−404
- nova-cache.cabal +13/−32
- src/NovaCache/Compression.hs +0/−35
- src/NovaCache/NAR.hs +208/−54
- src/NovaCache/NarInfo.hs +55/−25
- src/NovaCache/SafeName.hs +45/−0
- src/NovaCache/Server.hs +441/−0
- src/NovaCache/Signing.hs +31/−6
- src/NovaCache/Store.hs +66/−16
- src/NovaCache/StorePath.hs +43/−3
- src/NovaCache/Validate.hs +27/−14
- test/CompressionTest.hs +0/−88
- test/Main.hs +704/−22
CHANGELOG.md view
@@ -1,5 +1,44 @@ # Changelog +## 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~<N>` 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.
+ NOTICE view
@@ -0,0 +1,6 @@+nova-cache+Copyright 2026 Novavero AI Inc.++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
README.md view
@@ -1,7 +1,7 @@ <div align="center"> <h1>nova-cache</h1> <p><strong>The Nix binary cache protocol, in Haskell.</strong></p>-<p>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.</p>+<p>nix-base32, NAR archives, narinfo, store paths, and Ed25519 signing - with an optional WAI cache server. A pure core; IO is confined to the storage and server boundaries.</p> [](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml) [](https://hackage.haskell.org/package/nova-cache)@@ -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@@ -57,11 +54,16 @@ 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 +75,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` | `/<hash>.narinfo` | Fetch a narinfo |-| `GET` | `/nar/<file>` | Fetch a NAR |+| `GET` | `/nar/<file>` | Fetch a NAR (streamed from disk) | | `PUT` | `/<hash>.narinfo` | Upload a narinfo (authenticated, validated) |-| `PUT` | `/nar/<file>` | Upload a NAR (authenticated) |+| `PUT` | `/nar/<file>` | 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 +99,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 flag: `--flag server` builds the cache server. Requires GHC 9.8+ and cabal-install 3.10+. ---
+ exe/LandingPage.hs view
@@ -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+ [ "<!DOCTYPE html>",+ "<html lang=\"en\">",+ "<head>",+ "<meta charset=\"UTF-8\" />",+ "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\" />",+ "<title>cache.novavero.ai - Nix binary cache</title>",+ "<meta name=\"description\" content=\"The Novavero Nix binary cache, serving store paths for nova-nix - the Windows-native Nix.\" />",+ "<link rel=\"icon\" type=\"image/svg+xml\" href=\"data:image/svg+xml," <> novaveroLogoSvgEscaped <> "\" />",+ "<style>",+ "* { margin: 0; padding: 0; box-sizing: border-box; }",+ "body { background: #0a0b0e; color: #d6d9de; -webkit-font-smoothing: antialiased; font-family: 'Inter', system-ui, sans-serif; line-height: 1.75; }",+ "body::before { content: ''; position: fixed; inset: 0 0 auto 0; height: 320px; pointer-events: none; background: radial-gradient(ellipse 70% 100% at 50% -20%, rgba(52,211,153,0.07), transparent 70%); }",+ ".container { max-width: 720px; margin: 0 auto; padding: 80px 24px; position: relative; }",+ "a { color: #34d399; text-decoration: none; }",+ "a:hover { text-decoration: underline; }",+ ".brand { display: flex; align-items: center; gap: 14px; margin-bottom: 0.75rem; }",+ ".brand svg { width: 44px; height: 44px; border-radius: 10px; }",+ "h1 { color: #fff; font-size: 1.6rem; font-family: ui-monospace, Consolas, monospace; }",+ ".tagline { color: #9ca3af; margin-bottom: 2.5rem; }",+ ".stats { display: grid; grid-template-columns: repeat(auto-fit, minmax(140px, 1fr)); gap: 12px; margin-bottom: 2.5rem; }",+ ".stat { padding: 16px; border: 1px solid #232733; border-radius: 12px; text-align: center; }",+ ".stat .value { color: #fff; font-size: 1.4rem; font-weight: 600; }",+ ".stat .label { color: #6b7280; font-size: 0.75rem; text-transform: uppercase; letter-spacing: 0.05em; }",+ "h2 { color: #fff; font-size: 1rem; margin: 2rem 0 0.5rem; }",+ "p { font-size: 0.9rem; margin-bottom: 0.75rem; }",+ "pre { background: #0d0f14; border: 1px solid #232733; border-radius: 8px; padding: 14px; white-space: pre-wrap; word-break: break-all; margin: 0.75rem 0; }",+ "code { font-family: ui-monospace, Consolas, monospace; font-size: 0.85rem; color: #e5e7eb; }",+ ".footer { margin-top: 3rem; padding-top: 1.5rem; border-top: 1px solid #232733; font-size: 0.85rem; color: #6b7280; }",+ "</style>",+ "</head>",+ "<body>",+ "<div class=\"container\">",+ "<div class=\"brand\">" <> novaveroLogoSvg <> "<h1>cache.novavero.ai</h1></div>",+ "<p class=\"tagline\">Nix binary cache - serving store paths for <a href=\"https://github.com/Novavero-AI/nova-nix\">nova-nix</a>, the Windows-native Nix.</p>",+ "<div class=\"stats\">",+ "<div class=\"stat\"><div class=\"value\">" <> T.pack (show pathCount) <> "</div><div class=\"label\">store paths</div></div>",+ "<div class=\"stat\"><div class=\"value\">" <> (if signingEnabled then "ed25519" else "off") <> "</div><div class=\"label\">signing</div></div>",+ "<div class=\"stat\"><div class=\"value\">" <> T.pack (show (ciPriority info)) <> "</div><div class=\"label\">priority</div></div>",+ "</div>",+ "<h2>Use it</h2>",+ "<pre><code>substituters = https://cache.novavero.ai" <> trustAnchorLine <> "</code></pre>",+ "<p>Store dir: <code>" <> ciStoreDir info <> "</code> · protocol endpoints: <code>/nix-cache-info</code>, <code>/<hash>.narinfo</code>, <code>/nar/<file></code></p>",+ "<h2>What this is</h2>",+ "<p>The binary cache behind the Novavero Nix toolchain. Powered by <a href=\"https://github.com/Novavero-AI/nova-cache\">nova-cache</a>, a Haskell implementation of the Nix binary cache protocol. Read about the first package built by Nix natively on Windows on <a href=\"https://novavero.ai/blog/first-native-windows-nix-build.html\">the blog</a>.</p>",+ "<div class=\"footer\"><a href=\"https://novavero.ai\">Novavero AI</a> · Waterloo, Canada</div>",+ "</div>",+ "</body>",+ "</html>"+ ]+ 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 =+ "<svg xmlns=\"http://www.w3.org/2000/svg\" viewBox=\"0 0 64 64\" role=\"img\" aria-label=\"Novavero\">"+ <> "<g fill=\"#0a0f1a\"><rect width=\"64\" height=\"64\" rx=\"14\" ry=\"14\"/></g>"+ <> "<g fill=\"#ffffff\"><path d=\"M12 54L19 54L23 10L16 10Z\"/><path d=\"M16 10L23 10L48 54L41 54Z\"/><path d=\"M41 54L48 54L52 10L45 10Z\"/></g>"+ <> "</svg>"++-- | 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")+ ]
exe/Main.hs view
@@ -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 /<hash>.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/<file>- ("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 /<hash>.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/<file> (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 \<key\>@.--- 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- [ "<!DOCTYPE html>",- "<html lang=\"en\">",- "<head>",- "<meta charset=\"UTF-8\" />",- "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\" />",- "<title>cache.novavero.ai - Nix binary cache</title>",- "<meta name=\"description\" content=\"The Novavero Nix binary cache, serving store paths for nova-nix - the Windows-native Nix.\" />",- "<link rel=\"icon\" type=\"image/svg+xml\" href=\"data:image/svg+xml," <> novaveroLogoSvgEscaped <> "\" />",- "<style>",- "* { margin: 0; padding: 0; box-sizing: border-box; }",- "body { background: #0a0b0e; color: #d6d9de; -webkit-font-smoothing: antialiased; font-family: 'Inter', system-ui, sans-serif; line-height: 1.75; }",- "body::before { content: ''; position: fixed; inset: 0 0 auto 0; height: 320px; pointer-events: none; background: radial-gradient(ellipse 70% 100% at 50% -20%, rgba(52,211,153,0.07), transparent 70%); }",- ".container { max-width: 720px; margin: 0 auto; padding: 80px 24px; position: relative; }",- "a { color: #34d399; text-decoration: none; }",- "a:hover { text-decoration: underline; }",- ".brand { display: flex; align-items: center; gap: 14px; margin-bottom: 0.75rem; }",- ".brand svg { width: 44px; height: 44px; border-radius: 10px; }",- "h1 { color: #fff; font-size: 1.6rem; font-family: ui-monospace, Consolas, monospace; }",- ".tagline { color: #9ca3af; margin-bottom: 2.5rem; }",- ".stats { display: grid; grid-template-columns: repeat(auto-fit, minmax(140px, 1fr)); gap: 12px; margin-bottom: 2.5rem; }",- ".stat { padding: 16px; border: 1px solid #232733; border-radius: 12px; text-align: center; }",- ".stat .value { color: #fff; font-size: 1.4rem; font-weight: 600; }",- ".stat .label { color: #6b7280; font-size: 0.75rem; text-transform: uppercase; letter-spacing: 0.05em; }",- "h2 { color: #fff; font-size: 1rem; margin: 2rem 0 0.5rem; }",- "p { font-size: 0.9rem; margin-bottom: 0.75rem; }",- "pre { background: #0d0f14; border: 1px solid #232733; border-radius: 8px; padding: 14px; white-space: pre-wrap; word-break: break-all; margin: 0.75rem 0; }",- "code { font-family: ui-monospace, Consolas, monospace; font-size: 0.85rem; color: #e5e7eb; }",- ".footer { margin-top: 3rem; padding-top: 1.5rem; border-top: 1px solid #232733; font-size: 0.85rem; color: #6b7280; }",- "</style>",- "</head>",- "<body>",- "<div class=\"container\">",- "<div class=\"brand\">" <> novaveroLogoSvg <> "<h1>cache.novavero.ai</h1></div>",- "<p class=\"tagline\">Nix binary cache - serving store paths for <a href=\"https://github.com/Novavero-AI/nova-nix\">nova-nix</a>, the Windows-native Nix.</p>",- "<div class=\"stats\">",- "<div class=\"stat\"><div class=\"value\">" <> T.pack (show pathCount) <> "</div><div class=\"label\">store paths</div></div>",- "<div class=\"stat\"><div class=\"value\">" <> (if signingEnabled then "ed25519" else "off") <> "</div><div class=\"label\">signing</div></div>",- "<div class=\"stat\"><div class=\"value\">" <> T.pack (show (ciPriority info)) <> "</div><div class=\"label\">priority</div></div>",- "</div>",- "<h2>Use it</h2>",- "<pre><code>substituters = https://cache.novavero.ai" <> trustAnchorLine <> "</code></pre>",- "<p>Store dir: <code>" <> ciStoreDir info <> "</code> · protocol endpoints: <code>/nix-cache-info</code>, <code>/<hash>.narinfo</code>, <code>/nar/<file></code></p>",- "<h2>What this is</h2>",- "<p>The binary cache behind the Novavero Nix toolchain. Powered by <a href=\"https://github.com/Novavero-AI/nova-cache\">nova-cache</a>, a Haskell implementation of the Nix binary cache protocol. Read about the first package built by Nix natively on Windows on <a href=\"https://novavero.ai/blog/first-native-windows-nix-build.html\">the blog</a>.</p>",- "<div class=\"footer\"><a href=\"https://novavero.ai\">Novavero AI</a> · Waterloo, Canada</div>",- "</div>",- "</body>",- "</html>"- ]- 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 =- "<svg xmlns=\"http://www.w3.org/2000/svg\" viewBox=\"0 0 64 64\" role=\"img\" aria-label=\"Novavero\">"- <> "<g fill=\"#0a0f1a\"><rect width=\"64\" height=\"64\" rx=\"14\" ry=\"14\"/></g>"- <> "<g fill=\"#ffffff\"><path d=\"M12 54L19 54L23 10L16 10Z\"/><path d=\"M16 10L23 10L48 54L41 54Z\"/><path d=\"M41 54L48 54L52 10L45 10Z\"/></g>"- <> "</svg>"---- | 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")- ]
nova-cache.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: nova-cache-version: 0.4.2.1+version: 0.7.0.0 synopsis: Pure-first Nix binary cache protocol library description: A pure-first library implementing the Nix binary cache protocol -@@ -20,18 +20,14 @@ tested-with: GHC == 9.8.4 extra-doc-files: CHANGELOG.md+ NOTICE README.md 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@@ -39,26 +35,26 @@ NovaCache.Hash NovaCache.NAR 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 , 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@@ -77,6 +73,7 @@ buildable: False main-is: Main.hs+ other-modules: LandingPage hs-source-dirs: exe default-language: Haskell2010 default-extensions:@@ -86,9 +83,7 @@ build-depends: base >= 4.16 && < 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@@ -110,26 +105,12 @@ , 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--test-suite nova-cache-compression-test- if !flag(compression)- buildable: False-- type: exitcode-stdio-1.0- main-is: CompressionTest.hs- hs-source-dirs: test- default-language: Haskell2010- default-extensions:- OverloadedStrings- ghc-options: -Wall -Wcompat-- build-depends:- base >= 4.16 && < 5- , bytestring >= 0.11 && < 0.13- , nova-cache+ , wai >= 3.2 && < 3.3+ , wai-extra >= 3.1 && < 3.2 source-repository head type: git
− src/NovaCache/Compression.hs
@@ -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)))
src/NovaCache/NAR.hs view
@@ -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,12 +13,19 @@ -- 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. module NovaCache.NAR ( NarEntry (..), serialise, deserialise, narHash, serialiseFromPath,+ serialiseFromPathWith,+ CaseHack (..),+ defaultCaseHack,+ caseHackSuffix, ) where @@ -24,15 +33,14 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL 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.SafeName (hasTrailingDotOrSpace, isReservedDeviceName)+import System.Directory.OsPath ( doesDirectoryExist, doesFileExist, executable,@@ -41,7 +49,15 @@ 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+#else+import System.IO (latin1)+#endif -- --------------------------------------------------------------------------- -- Types@@ -51,12 +67,14 @@ 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) -- ---------------------------------------------------------------------------@@ -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" \<n\> "node" \<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@@ -197,7 +215,12 @@ where regular tok rest | tok == tokExecutable = do- (_, afterEmpty) <- readStr rest+ (marker, afterEmpty) <- readStr rest+ -- The format fixes the executable marker's value as the empty+ -- string; upstream rejects a nonempty value.+ if BS.null marker+ then Right ()+ else Left ("executable marker must be empty, got: " ++ show marker) (cTok, afterCTok) <- readStr afterEmpty expect tokContents cTok (contents, afterContents) <- readStr afterCTok@@ -214,7 +237,8 @@ -- a regular node without it is malformed - reject, matching Nix. Left ("expected 'executable' or 'contents' in regular, got: " ++ show tok) --- | Parse a symlink node.+-- | Parse a symlink node. The target is carried verbatim: upstream+-- imposes no text encoding on it. parseSymlink :: NarParser NarEntry parseSymlink bs = do (tgt, afterTgt) <- readStr bs@@ -222,8 +246,7 @@ (targetPath, afterPath) <- readStr afterTgt (rp, final) <- readStr afterPath expect tokRParen rp- symTarget <- decodeUtf8Safe targetPath- pure (NarSymlink symTarget, final)+ pure (NarSymlink targetPath, final) -- | Parse a directory node (zero or more child entries). parseDirectory :: NarParser NarEntry@@ -245,20 +268,35 @@ (entry, afterEntry) <- parseNode afterNodeTok (rp, afterRp) <- readStr afterEntry expect tokRParen rp- decodedName <- decodeUtf8Safe entryName- _ <- checkName prev decodedName- go (Just decodedName) ((decodedName, entry) : acc) afterRp+ _ <- checkName prev entryName+ go (Just entryName) ((entryName, 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.+ -- (sorted, unique) byte 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. Names are arbitrary bytes; every check here is+ -- ASCII-structural, so it stays exact whether or not the name+ -- decodes as text (see "NovaCache.SafeName"). 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)+ | BS.null name = Left "empty NAR directory entry name"+ -- Backslash is a directory separator on Windows - this library's+ -- primary consumer - so a name like "..\out.exe" is as much a+ -- traversal vector as one with '/'. A colon is a drive prefix+ -- ("C:evil") or an NTFS alternate data stream ("a:b"), either of+ -- which resolves the write somewhere other than a file of this name.+ | name == "." || name == ".." || BS8.any (\c -> c == '/' || c == '\\' || c == '\0' || c == ':') name =+ Left ("unsafe NAR directory entry name: " ++ show name)+ -- Windows-unsafe categories, shared with the store-key allowlist+ -- (NovaCache.SafeName): a device name resolves to the device, and+ -- NTFS strips a trailing dot or space so the on-disk name would+ -- silently diverge from the NAR name.+ | isReservedDeviceName name =+ Left ("Windows reserved device name as NAR directory entry: " ++ show name)+ | hasTrailingDotOrSpace name =+ Left ("NAR directory entry name ends with a dot or space: " ++ show name) | Just p <- prev, name <= p =- Left ("NAR directory entries not strictly increasing: " ++ T.unpack name)+ Left ("NAR directory entries not strictly increasing: " ++ show name) | otherwise = Right () -- ---------------------------------------------------------------------------@@ -287,12 +325,17 @@ ++ " exceeds remaining " ++ show (BS.length payload) )+ -- Nix's reader rejects nonzero padding; accepting it would let archives+ -- that upstream tooling refuses round-trip through this library.+ | BS.any (/= 0) padding =+ Left "nonzero padding bytes in NAR string" | 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)+ padding = BS.take (totalLen - fromIntegral len) (BS.drop (fromIntegral len) payload) -- | Read a little-endian 'Word64' from the first 8 bytes. readWord64LE :: ByteString -> Word64@@ -318,12 +361,6 @@ | got == expected = Right () | otherwise = Left ("expected " ++ show expected ++ ", got " ++ show got) --- | 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)- -- --------------------------------------------------------------------------- -- Hashing -- ---------------------------------------------------------------------------@@ -336,51 +373,168 @@ -- 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~<N>@ 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+-- ('walkPath') 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+-- | Build a directory entry by recursively walking children. 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.+buildDirectory :: CaseHack -> OsPath -> IO NarEntry+buildDirectory mode path = do names <- sort <$> listDirectory path- entries <- traverse walkChild names- pure (NarDirectory entries)+ named <- traverse withNameBytes names+ case unhackedDirNames mode named of+ Left (first, second) -> do+ firstPath <- decodeFS (path </> first)+ secondPath <- decodeFS (path </> second)+ fail+ ( "serialiseFromPath: file name collision between '"+ ++ firstPath+ ++ "' and '"+ ++ secondPath+ ++ "' after case-hack stripping"+ )+ Right resolved -> NarDirectory <$> traverse walkChild resolved where- walkChild name = do- entry <- serialiseFromPath (path </> name)- pure (T.pack name, entry)+ withNameBytes diskName = do+ nameBytes <- osPathBytes diskName+ pure (nameBytes, diskName)+ walkChild (entryName, diskName) = do+ entry <- walkPath mode (path </> diskName)+ pure (entryName, entry) +-- | 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+ else do -- 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)+ 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
src/NovaCache/NarInfo.hs view
@@ -10,7 +10,7 @@ ) where -import Data.List (find)+import Data.List (foldl') import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T@@ -21,12 +21,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 +74,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 '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.@@ -112,13 +123,14 @@ 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)@@ -151,8 +163,14 @@ 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 +178,30 @@ -- | 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+ -- | 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. 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 -> Right n+ _ -> Left ("invalid integer for " ++ T.unpack key ++ ": " ++ T.unpack txt) -- | Show a value as 'Text'. showT :: (Show a) => a -> Text
+ src/NovaCache/SafeName.hs view
@@ -0,0 +1,45 @@+-- | Windows-unsafe name categories, shared by the store-key allowlist+-- ('NovaCache.Store.sanitizePath') and the NAR entry-name guard in+-- "NovaCache.NAR": 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. Every+-- category here is ASCII-structural, 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.Char8 as BS8+import Data.Char (isAsciiUpper, toLower)++-- | 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 consumer is safe too.+--+-- Device matching is ASCII case-insensitive, so only @A@-@Z@ fold; any+-- other byte passes through and can never match the reserved set.+isReservedDeviceName :: ByteString -> Bool+isReservedDeviceName name =+ BS8.map asciiLower (BS8.takeWhile (/= '.') name) `elem` reservedNames+ where+ asciiLower c = if isAsciiUpper c then toLower c else c+ reservedNames =+ ["con", "prn", "aux", "nul"]+ ++ [device <> digit | device <- ["com", "lpt"], digit <- digits]+ digits = [BS8.pack (show n) | n <- [1 .. 9 :: Int]]++-- | 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
+ src/NovaCache/Server.hs view
@@ -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 \/\<hash\>.narinfo narinfo by store-path hash+-- GET \/nar\/\<file\> NAR payload (streamed from disk)+-- GET \/narinfo-hashes stored-hash listing (authenticated; push-tool plumbing)+-- PUT \/\<hash\>.narinfo validated, signed, stored (authenticated)+-- PUT \/nar\/\<file\> 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 (@\/\<hash\>.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 /<hash>.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/<file> - 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 /<hash>.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/<file> (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 '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 \<key\>@.+-- 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 '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 '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")+ ]
src/NovaCache/Signing.hs view
@@ -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 ++ " <redacted>"++-- | 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/<hash>-<name>), 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
src/NovaCache/Store.hs view
@@ -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,@@ -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
src/NovaCache/StorePath.hs view
@@ -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,10 +101,31 @@ -- | Parse a store path from a full path or bare basename. -- -- Accepts @\/nix\/store\/\<hash\>-\<name\>@ or just @\<hash\>-\<name\>@.+-- 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 @\<hash\>-\<name\>@ 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 @\<store-dir\>\/\<hash\>-\<name\>@ 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 =@@ -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
src/NovaCache/Validate.hs view
@@ -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@@ -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:<nix-base32> 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
− test/CompressionTest.hs
@@ -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
test/Main.hs view
@@ -1,25 +1,38 @@+{-# 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.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 (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.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 (createDirectoryIfMissing, removeDirectoryRecursive)+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)@@ -123,7 +136,8 @@ testNarInfo, testSigning, testFileStore,- testValidate+ testValidate,+ testServer ] -- ---------------------------------------------------------------------------@@ -162,10 +176,17 @@ 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)+ -- 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")) ] -- ---------------------------------------------------------------------------@@ -242,7 +263,24 @@ test "reject invalid name chars" $ let storeDir = StorePath.defaultStoreDir input = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello world"- in assertLeft "invalid chars" (StorePath.parseStorePath storeDir input)+ 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) ] -- ---------------------------------------------------------------------------@@ -311,9 +349,198 @@ 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]))+ 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 an 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\\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),+ -- Windows resolves these names to something other than a file of+ -- this spelling (drive/stream colon, device, NTFS dot/space strip).+ test "Windows-hazard entry names rejected" $+ let evil name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")])+ names = ["C:evil", "a:b", "nul", "NUL", "com1", "nul.txt", "foo.", "foo "]+ rejected bytes = either (const True) (const False) (NAR.deserialise bytes)+ in assertTrue "all hazard names rejected" (all (rejected . evil) names),+ test "near-miss names still parse" $+ let plain name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")])+ names = ["nul2", "com10", "conx", "foo.bar", "a.b.c", "lpt0"]+ accepted bytes = either (const False) (const True) (NAR.deserialise bytes)+ in assertTrue "all near-miss names accepted" (all (accepted . plain) 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 rejected" $+ let evil name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")])+ names = ["nul." <> BS.pack [0xFF], BS.pack [0xFF, 0x2E], BS.pack [0xFF] <> ":x"]+ rejected bytes = either (const True) (const False) (NAR.deserialise bytes)+ in assertTrue "all hazard bytes rejected" (all (rejected . evil) 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 ")"+ ]+ -- --------------------------------------------------------------------------- -- NarInfo tests -- ---------------------------------------------------------------------------@@ -347,7 +574,7 @@ 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)+ 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)@@ -388,6 +615,44 @@ 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),@@ -403,7 +668,52 @@ "NarSize: 200", "References: " ]- in assertLeft "bad integer" (NarInfo.parseNarInfo bad)+ 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),+ -- 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) ] -- ---------------------------------------------------------------------------@@ -427,6 +737,38 @@ 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\" <redacted>" (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)@@ -449,6 +791,40 @@ 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),@@ -515,8 +891,8 @@ { 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.niFileHash = Just "sha256:abc",+ NarInfo.niFileSize = Just 100, NarInfo.niNarHash = "sha256:def", NarInfo.niNarSize = 200, NarInfo.niReferences = ["aaaa-hello-1.0"],@@ -584,6 +960,10 @@ assertEqual "device nul" Nothing (Store.sanitizePath "nul"), 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@@ -638,8 +1018,8 @@ { 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.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"],@@ -658,7 +1038,7 @@ (Right mkValidNarInfo) (Validate.validateNarInfo mkValidNarInfo), test "validateNarInfo negative FileSize" $- let ni = mkValidNarInfo {NarInfo.niFileSize = -1}+ let ni = mkValidNarInfo {NarInfo.niFileSize = Just (-1)} in assertEqual "negative filesize" (Left [Validate.NegativeFileSize (-1)])@@ -687,7 +1067,7 @@ putStrLn (" expected Left [InvalidStorePath ..], got: " ++ show other) pure False, test "validateNarInfo bad FileHash" $- let ni = mkValidNarInfo {NarInfo.niFileHash = "md5:bogus"}+ let ni = mkValidNarInfo {NarInfo.niFileHash = Just "md5:bogus"} in case Validate.validateNarInfo ni of Left [Validate.InvalidFileHash raw _] -> assertEqual "raw value" "md5:bogus" raw@@ -713,7 +1093,7 @@ test "validateNarInfo multiple errors collected" $ let ni = mkValidNarInfo- { NarInfo.niFileSize = -1,+ { NarInfo.niFileSize = Just (-1), NarInfo.niNarSize = -1, NarInfo.niStorePath = "bad" }@@ -788,7 +1168,7 @@ test "validateFull multiple failures" $ do sk <- generateTestSecretKey let pk = deriveTestPublicKey sk- ni = mkValidNarInfo {NarInfo.niFileSize = -1, NarInfo.niNarSize = -1}+ 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@@ -797,15 +1177,317 @@ ] -- ---------------------------------------------------------------------------+-- 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 -- --------------------------------------------------------------------------- --- | Create a temporary test directory.+-- | 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- let dir = "/tmp/nova-cache-test"- createDirectoryIfMissing True dir- pure dir+ 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