diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog +## 0.12.0.0 - 2026-11-01 + +- **`nova-cache-server reclaim-nars` lists, and with `--delete` removes, the NARs no narinfo references.** A client uploads a path's NAR before its narinfo, as upstream's `BinaryCacheStore::addToStoreCommon` does, so a NAR whose narinfo the server refuses, or whose push dies before the narinfo, stayed under `nar/` for good: the server has no route that deletes, and gains none. The subcommand runs on the host against the store directory. A narinfo names its NAR by its `URL` alone, as upstream reads it (`getFile(info->url)`), with the compression suffix part of the name. Three rules guard a run. A NAR is eligible only once it is two weeks old by its modification time (`--min-age-hours` overrides), because a NAR is unreferenced until its push sends the narinfo and nothing bounds how long a push takes; git's `gc.pruneExpire` gives unreferenced objects the same two weeks against the same race. A narinfo that cannot be read, parsed, or resolved to `nar/` blocks the whole run instead of being skipped, since the NAR it names would otherwise look unreferenced. And a store holding NARs and no narinfo at all blocks it too, since one that lost its `narinfo/` directory, which the server recreates empty when it starts, looks the same as one whose every NAR is unreferenced. A run is not atomic with the server, so it belongs on a cache with no push in progress: a narinfo that arrives during a run for a NAR past the minimum age, as upstream's `nix copy` can send after skipping a NAR already present, loses that NAR. Upstream ships no garbage collection for binary caches, so there is no behavior to match beyond the URL. The library gains `NovaCache.Reclaim` (the pure selection and the store scan) and, in `NovaCache.Store`, `listNarFiles`, `listNarInfoFiles`, `removeNar` and `fileStoreAt`, a constructor that creates no directories; `time` joins the dependencies. +- **A narinfo is refused unless the NAR its `URL` names is stored and matches its `FileSize` and `FileHash`.** `PUT /.narinfo` validated the narinfo's own fields and signed it without looking at the NAR, so a NAR that arrived short or wrong sat behind a signed narinfo: clients rejected the NAR on its hash, and nova-nix's push never repaired it, because a push skips every path whose narinfo exists. Warp before 3.4.17 made the short case reachable: it ended a chunked request body at the connection's end of input as if the terminating chunk had arrived (yesodweb/wai#1129), so a `PUT /nar/` cut off mid-chunk got 200 and stored a prefix. The narinfo is now refused with a 400 naming the problem unless its `URL` resolves, exactly as a GET for it is routed, to a file under `nar/` of `FileSize` bytes that hashes to `FileHash`, so an upload that went wrong fails at the narinfo. nova-nix's next push sends both again. Upstream's `nix copy` skips a NAR whose file already exists, so a wrong file under that name goes on refusing the narinfo until `reclaim-nars` removes it. A narinfo without `FileSize` or `FileHash` is refused as well, since the signature does not cover them and nothing else records which file the narinfo describes, and so is a `URL` that is not under `nar/`, such as an absolute one, which upstream can read but its `BinaryCacheStore` never writes. Upstream's `BinaryCacheStore::addToStoreCommon` and nova-nix's push both send the two fields and a relative `nar/` URL, and both upload the NAR before its narinfo, so a complete upload from either is accepted. `cacheApp` refuses requests it used to accept, which is why this is a major version. The server reads the stored NAR through once more when the narinfo arrives, in constant memory, and answers 500 if that read fails. The library gains the check's pure pieces in `NovaCache.Server` (`narUrlFileName`, `narClaim`, `judgeStoredNar`, `renderNarRefusal`). + ## 0.11.1.1 - 2026-08-26 - **A symlink target with a separator serialises to its POSIX spelling on every platform.** Windows stores a symlink's reparse point with backslashes, so a target written `bin/tool` reads back `bin\tool`, and `getSymbolicLinkTarget` returned that verbatim into the NAR. NAR targets are host-independent byte strings in the POSIX spelling, so the archive of the same logical tree diverged between Windows and POSIX, and an unpack-then-recheck round-trip failed its on-disk hash comparison on Windows for any symlink whose target had more than one component. Both producers now normalise the separator to `/` when reading a target on Windows, where a backslash is only ever a separator and encodes as the single byte `0x5C` that no multi-byte UTF-8 sequence contains, so the byte-level replacement is exact. POSIX is untouched, where a backslash is a legitimate filename byte. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,23 +1,38 @@ -
-

nova-cache

-

The Nix binary cache protocol, in Haskell.

-

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

+# nova-cache [![CI](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml/badge.svg)](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/nova-cache.svg)](https://hackage.haskell.org/package/nova-cache) -![GHC](https://img.shields.io/badge/GHC-9.14-purple) -![License](https://img.shields.io/badge/license-Apache--2.0-blue) +[![License](https://img.shields.io/badge/license-Apache--2.0-blue)](LICENSE) -
+nova-cache implements the Nix binary cache protocol in Haskell: nix-base32, +NAR serialization (whole-tree and streaming), narinfo parsing, store paths, +Ed25519 signing and upload validation, and an optional WAI cache server. +Bounded xz, zstd and bzip2 codecs are the public `nova-cache:xz`, +`nova-cache:zstandard` and `nova-cache:bzip2` sublibraries, and the zstd codec +also compresses for uploads. ---- +Parsing, formatting, hashing, signing and validation are pure. Reading and +writing trees, hashing files, the codecs, the store and the server run in +`IO`. nova-cache is the protocol layer under +[nova-nix](https://github.com/Novavero-AI/nova-nix). ## Installation ```cabal -build-depends: nova-cache +build-depends: nova-cache >= 0.11 && < 0.12 ``` +The codecs are separate sublibraries, named alongside the main library: + +```cabal +build-depends: nova-cache:{nova-cache, xz, zstandard} >= 0.11 && < 0.12 +``` + +libbz2 and libzstd are bundled. liblzma comes from the `xz` package, which +prefers a system liblzma found through pkg-config and falls back to its bundled +sources. `constraints: xz -system-xz` in `cabal.project` forces the bundled +copy, as this repository does. + ## Usage ```haskell @@ -41,23 +56,21 @@ ```haskell import NovaCache.Validate (validateFull) --- Validate an upload: fields + NAR hash + file hash + signatures. --- Pure, and every error is collected rather than failing on the first. +-- Validate an upload: fields, NAR hash, file hash and signatures. Every +-- error is collected rather than stopping at the first. case validateFull publicKey ni narBytes fileBytes of Right () -> accept Left errs -> reject errs ``` ```haskell +import qualified Data.ByteString as BS import NovaCache.NAR (defaultCaseHack, withNarSource) import qualified NovaCache.Hash as Hash --- Stream a tree's NAR and hash it in one pass; the archive never --- exists in memory. The parsing side is NovaCache.NAR.Stream, a --- chunk-fed event machine; the nova-cache:xz, nova-cache:zstandard, --- and nova-cache:bzip2 sublibraries add decompression bounded by a --- narinfo's declared NarSize, and the zstd side also compresses for --- the push direction. +-- Stream a tree's NAR and hash it in one pass, without holding the archive +-- in memory. NovaCache.NAR.Stream parses NARs incrementally, and the codec +-- sublibraries bound decompression by a narinfo's declared NarSize. narHash <- withNarSource defaultCaseHack path $ \pull -> let go ctx = do chunk <- pull @@ -73,9 +86,9 @@ 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. +The protocol lives in the `NovaCache.Server` library module as a WAI +`Application`, so the cache can be embedded in another server with its own +root page. The bundled executable is one such embedding. ### Configuration @@ -83,7 +96,7 @@ | --- | --- | | `PORT` | Listen port (default: 5000; also `--port`) | | `HOST` | Bind host (default: all interfaces; also `--host`) | -| `NIX_CACHE_DIR` | Store directory (default: `./nix-cache`) | +| `NIX_CACHE_DIR` | Store directory (default: `./nix-cache`; also `--store`) | | `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 | | `LOG_REQUESTS` | Set to `0` to disable request logging | @@ -97,29 +110,64 @@ | `GET` | `/narinfo-hashes` | All cached narinfo hashes, newline-delimited (authenticated) | | `GET` | `/.narinfo` | Fetch a narinfo | | `GET` | `/nar/` | Fetch a NAR (streamed from disk) | -| `PUT` | `/.narinfo` | Upload a narinfo (authenticated, validated) | +| `PUT` | `/.narinfo` | Upload a narinfo (authenticated, validated; refused unless the NAR its `URL` names is stored with its `FileSize` and `FileHash`) | | `PUT` | `/nar/` | Upload a NAR (authenticated, streamed to disk) | `HEAD` is answered wherever `GET` is. +### Reclaiming unreferenced NARs + +A client uploads each NAR before its narinfo, so a NAR whose narinfo was +refused, or never sent because the push died, stays under `nar/` with nothing +referencing it. No endpoint deletes anything. The `reclaim-nars` subcommand +does, run on the host against the store directory: + +```bash +nova-cache-server reclaim-nars --store /var/lib/nix-cache # list +nova-cache-server reclaim-nars --store /var/lib/nix-cache --delete # remove +``` + +- A NAR is eligible only once it is at least `--min-age-hours` old (default + 336, two weeks), measured from its modification time. A NAR is unreferenced + until its push sends the narinfo, and a push can run for hours. +- If any narinfo cannot be read or parsed, or its `URL` is not `nar/`, + the run prints those narinfos, lists and deletes nothing, and exits nonzero: + the NAR such a narinfo names is unknown, so no NAR can be called unreferenced. +- If the store holds NARs and no narinfo at all, the run lists and deletes + nothing and exits nonzero: a store that lost its narinfos looks the same as + one whose every NAR is unreferenced. +- A run is not atomic with the server, so run it with no push in progress. A + narinfo that arrives during a run for a NAR past the minimum age loses that + NAR, which leaves a signed narinfo with nothing behind it. +- A deletion that fails is reported for that file, and the exit status is + nonzero. +- The store root comes from `--store`, then `NIX_CACHE_DIR`, then + `./nix-cache`, as for the server. A missing `narinfo/` or `nar/` directory is + an error, never an empty store. + ### Public cache -A public instance runs at `cache.novavero.ai`: +A public instance runs at `cache.novavero.ai`. It serves store paths that +nova-nix builds, which today means its Windows MinGW-w64 toolchain seed +([nova-nix#207](https://github.com/Novavero-AI/nova-nix/issues/207)). To use +it from Nix, add it to `/etc/nix/nix.conf`. On a multi-user install, Nix +ignores substituters set by users it does not trust. ``` extra-substituters = https://cache.novavero.ai extra-trusted-public-keys = cache.novavero.ai-1:9gQ7tLWMM+2tdC9H5sKMJltDIPfD7X2GWlZe8Aa8hHQ= ``` -## Build & test +## Building from source +Tested with GHC 9.14.1. CI uses the latest cabal-install release. + ```bash -cabal build -cabal test +cabal update +cabal build all -f server --enable-tests --ghc-options="-Werror" +cabal test -f server --ghc-options="-Werror" ``` -Optional extras: `--flag server` builds the cache server, and the public `nova-cache:xz`, `nova-cache:bzip2`, and `nova-cache:zstandard` sublibraries carry the bounded codecs - consumers depend on them with `build-depends: nova-cache:xz` and the like. libbz2 and libzstd are bundled; liblzma comes from the `xz` package, which prefers a pkg-config system liblzma and falls back to its bundled `xz-clib` (pin `constraints: xz -system-xz` to force the bundled copy, as this repo's cabal.project does). Requires GHC 9.14+ and cabal-install 3.10+. - ---- +## License -

Apache-2.0 - Novavero AI Inc.

+Apache-2.0. See [LICENSE](LICENSE) and [NOTICE](NOTICE). diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -14,6 +14,7 @@ import NovaCache.Server (ServerConfig (..), cacheApp, newTTLCache, onExceptionResponse) import NovaCache.Signing (SecretKey, normalizeKeyText, parseSecretKey, renderPublicKey, toPublicKey) import NovaCache.Store (listNarInfoHashes, newFileStore) +import ReclaimNars (reclaimCommand, reclaimMain) import System.Environment (getArgs, lookupEnv) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -76,6 +77,16 @@ main :: IO () main = do args <- getArgs + case args of + command : rest + | command == reclaimCommand -> do + storeEnv <- lookupEnv storeEnvVar + reclaimMain (fromMaybe defaultStoreRoot storeEnv) rest + _ -> serve args + +-- | Run the cache server. +serve :: [String] -> IO () +serve args = do portEnv <- lookupEnv portEnvVar hostEnv <- lookupEnv hostEnvVar storeEnv <- lookupEnv storeEnvVar diff --git a/exe/ReclaimNars.hs b/exe/ReclaimNars.hs new file mode 100644 --- /dev/null +++ b/exe/ReclaimNars.hs @@ -0,0 +1,185 @@ +-- | The @reclaim-nars@ subcommand: list, and with @--delete@ remove, +-- the NARs in a store directory that no narinfo references. +-- +-- A host tool run against the store directory rather than a route, +-- since nothing over HTTP should be able to delete. The decision is +-- "NovaCache.Reclaim"'s; this module parses arguments, prints, and +-- deletes. +module ReclaimNars (reclaimCommand, reclaimMain) where + +import Control.Exception (IOException, displayException, try) +import Control.Monad (when) +import Data.Foldable (for_, traverse_) +import Data.Time.Clock (NominalDiffTime) +import NovaCache.Reclaim (ReclaimBlocked (..), ReclaimPlan (..), Unresolved (..), defaultMinimumAge, planReclaim, scanStore) +import NovaCache.Store (FileStore, NarFile (..), NarRemoveResult (..), fileStoreAt, removeNar) +import System.Exit (exitFailure) +import System.IO (BufferMode (LineBuffering), hPutStrLn, hSetBuffering, stderr, stdout) +import System.IO.Error (ioeGetErrorString) +import Text.Read (readMaybe) + +-- --------------------------------------------------------------------------- +-- Arguments +-- --------------------------------------------------------------------------- + +-- | The subcommand's name, the first argument to the executable. +reclaimCommand :: String +reclaimCommand = "reclaim-nars" + +storeFlag, minAgeFlag, deleteFlag :: String +storeFlag = "--store" +minAgeFlag = "--min-age-hours" +deleteFlag = "--delete" + +usage :: String +usage = + "usage: nova-cache-server " + ++ reclaimCommand + ++ " [" + ++ storeFlag + ++ " DIR] [" + ++ minAgeFlag + ++ " N] [" + ++ deleteFlag + ++ "]" + +secondsPerHour :: NominalDiffTime +secondsPerHour = 3600 + +-- | Whether a run removes what it finds. Listing is the default. +data Mode = ListOnly | Delete + +data Options = Options + { optStoreRoot :: !FilePath, + optMinimumAge :: !NominalDiffTime, + optMode :: !Mode + } + +-- | Parse the subcommand's arguments over the store root the +-- environment chose. Unlike the server's flags, an unknown or +-- malformed argument is an error: a typo here must not run with a +-- default the operator did not choose. +parseOptions :: FilePath -> [String] -> Either String Options +parseOptions storeRoot = + go Options {optStoreRoot = storeRoot, optMinimumAge = defaultMinimumAge, optMode = ListOnly} + where + go opts [] = Right opts + go opts (flag : value : rest) + | flag == storeFlag = go opts {optStoreRoot = value} rest + | flag == minAgeFlag = case readMaybe value of + Just hours + | hours >= (0 :: Integer) -> + go opts {optMinimumAge = fromInteger hours * secondsPerHour} rest + _ -> Left (minAgeFlag ++ " takes a whole number of hours, not " ++ show value) + go opts (flag : rest) + | flag == deleteFlag = go opts {optMode = Delete} rest + | flag == storeFlag || flag == minAgeFlag = Left (flag ++ " needs a value") + | otherwise = Left ("unknown argument: " ++ flag) + +-- --------------------------------------------------------------------------- +-- Command +-- --------------------------------------------------------------------------- + +-- | Run the subcommand. Exits nonzero when the arguments are wrong, +-- the store cannot be listed, the run is blocked, or a deletion fails. +reclaimMain :: FilePath -> [String] -> IO () +reclaimMain storeRoot args = case parseOptions storeRoot args of + Left err -> do + hPutStrLn stderr err + hPutStrLn stderr usage + exitFailure + Right opts -> do + -- Piped stdout is block buffered by default, which would print the + -- report out of order with the FAILED and FATAL lines on stderr. + hSetBuffering stdout LineBuffering + let root = optStoreRoot opts + store = fileStoreAt root + putStrLn ("store root: " ++ root) + putStrLn ("minimum age: " ++ counted (wholeHours (optMinimumAge opts)) "hour") + scanned <- try (scanStore store) + case scanned of + Left err -> + fatal ("cannot scan the store: " ++ displayException (err :: IOException)) + Right scan -> case planReclaim (optMinimumAge opts) scan of + Left blocked -> refuse blocked + Right plan -> case optMode opts of + ListOnly -> listPlan plan + Delete -> deletePlan store plan + +-- | List what a deleting run would remove. +listPlan :: ReclaimPlan -> IO () +listPlan plan = do + traverse_ (putStrLn . ("unreferenced: " ++) . describe) (rpEligible plan) + putStrLn + ( "eligible: " + ++ counted (length (rpEligible plan)) "NAR" + ++ ", " + ++ counted (sum (map nfSize (rpEligible plan))) "byte" + ++ " (pass " + ++ deleteFlag + ++ " to remove)" + ) + reportTooYoung plan + +-- | Remove every eligible NAR, reporting each, and exit nonzero if any +-- removal failed. +deletePlan :: FileStore -> ReclaimPlan -> IO () +deletePlan store plan = do + outcomes <- traverse removeOne (rpEligible plan) + let removed = [nar | (nar, NarRemoved) <- outcomes] + failures = length outcomes - length removed + putStrLn + ( "reclaimed: " + ++ counted (length removed) "NAR" + ++ ", " + ++ counted (sum (map nfSize removed)) "byte" + ) + reportTooYoung plan + when (failures > 0) $ + fatal ("failed to delete " ++ counted failures "NAR") + where + removeOne nar = do + outcome <- removeNar store (nfName nar) + case outcome of + NarRemoved -> putStrLn ("deleted: " ++ describe nar) + NarRemoveFailed err -> failed nar (ioeGetErrorString err) + NarRemoveBadPath -> failed nar "not a NAR filename" + pure (nar, outcome) + failed nar reason = hPutStrLn stderr ("FAILED: " ++ nfPath nar ++ ": " ++ reason) + +-- | Report what blocks the run and exit nonzero. +refuse :: ReclaimBlocked -> IO () +refuse (UnresolvedNarInfos unresolved) = do + for_ unresolved $ \u -> + hPutStrLn stderr ("UNRESOLVED: " ++ unresolvedPath u ++ ": " ++ unresolvedReason u) + fatal + ( counted (length unresolved) "unresolved narinfo" + ++ ": nothing was listed or deleted, since the NAR an unresolved narinfo names" + ++ " would look unreferenced. Fix or remove each one and run again." + ) +refuse NoNarInfos = + fatal + ( "the store holds NARs and no narinfo: nothing was listed or deleted, since a store" + ++ " that lost its narinfos looks the same as one whose every NAR is unreferenced." + ++ " Restore the narinfos, or remove the NARs by hand if none is referenced." + ) + +reportTooYoung :: ReclaimPlan -> IO () +reportTooYoung plan = + putStrLn ("kept, younger than the minimum age: " ++ counted (length (rpTooYoung plan)) "NAR") + +describe :: NarFile -> String +describe nar = nfPath nar ++ " (" ++ counted (nfSize nar) "byte" ++ ")" + +fatal :: String -> IO () +fatal msg = do + hPutStrLn stderr ("FATAL: " ++ msg) + exitFailure + +wholeHours :: NominalDiffTime -> Integer +wholeHours age = round (age / secondsPerHour) + +-- | A count with its noun: @1 NAR@, @2 NARs@. +counted :: (Show a, Eq a, Num a) => a -> String -> String +counted 1 noun = "1 " ++ noun +counted n noun = show n ++ " " ++ noun ++ "s" diff --git a/nova-cache.cabal b/nova-cache.cabal --- a/nova-cache.cabal +++ b/nova-cache.cabal @@ -4,15 +4,14 @@ -- 3.0 an in-package component name shadowed its external namesake -- (the hazard the zstandard library's name dodges, documented there). name: nova-cache -version: 0.11.1.1 -synopsis: Pure-first Nix binary cache protocol library +version: 0.12.0.0 +synopsis: Nix binary cache protocol: NAR, narinfo, signing and a WAI server description: - A pure-first library implementing the Nix binary cache protocol - - nix-base32, NAR serialization (whole-tree and streaming), narinfo - parsing, Ed25519 signing, store path handling, and content - validation - with an optional WAI server, and bounded xz, bzip2, - and zstd codecs as the public @nova-cache:xz@, @nova-cache:bzip2@, - and @nova-cache:zstandard@ sublibraries. + The Nix binary cache protocol in Haskell: nix-base32, NAR serialization + (whole-tree and streaming), narinfo parsing, store paths, Ed25519 + signing and upload validation, with an optional WAI cache server. + Bounded xz, bzip2 and zstd codecs are the public @nova-cache:xz@, + @nova-cache:bzip2@ and @nova-cache:zstandard@ sublibraries. license: Apache-2.0 license-file: LICENSE @@ -45,6 +44,7 @@ NovaCache.NAR NovaCache.NAR.Stream NovaCache.NarInfo + NovaCache.Reclaim NovaCache.SafeName NovaCache.Server NovaCache.Signing @@ -63,6 +63,7 @@ , http-types >= 0.12 && < 0.13 , ram >= 0.20 && < 1 , text >= 2.0 && < 2.2 + , time >= 1.9 && < 1.17 , vector >= 0.12 && < 0.14 , wai >= 3.2 && < 3.3 @@ -170,7 +171,9 @@ buildable: False main-is: Main.hs - other-modules: LandingPage + other-modules: + LandingPage + ReclaimNars hs-source-dirs: exe default-language: Haskell2010 default-extensions: @@ -183,6 +186,7 @@ , nova-cache , http-types >= 0.12 && < 0.13 , text >= 2.0 && < 2.2 + , time >= 1.9 && < 1.17 , wai >= 3.2 && < 3.3 , wai-extra >= 3.1 && < 3.2 , warp >= 3.3 && < 3.5 @@ -200,12 +204,17 @@ base >= 4.22 && < 5 , base64-bytestring >= 1.2 && < 1.3 , bytestring >= 0.11 && < 0.13 + , containers >= 0.6 && < 0.9 , crypton >= 1.1 && < 2 , directory >= 1.3 && < 1.4 , http-types >= 0.12 && < 0.13 , nova-cache + -- 2.12 dropped InsufficientCoverage, leaving the four Result + -- constructors the suite matches exhaustively. + , QuickCheck >= 2.12 && < 2.20 , ram >= 0.20 && < 1 , text >= 2.0 && < 2.2 + , time >= 1.9 && < 1.17 , wai >= 3.2 && < 3.3 , wai-extra >= 3.1 && < 3.2 diff --git a/src/NovaCache/Reclaim.hs b/src/NovaCache/Reclaim.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/Reclaim.hs @@ -0,0 +1,212 @@ +-- | Finding the NARs a file store holds that no narinfo references. +-- +-- A client uploads a path's NAR before its narinfo (upstream's +-- @BinaryCacheStore::addToStoreCommon@ does, and so does nova-nix's +-- push), so a NAR whose narinfo is refused, or never sent because the +-- push died, stays under @nar\/@ with nothing pointing at it. Which +-- NARs those are is decided purely ('planReclaim' over a 't:StoreScan'); +-- 'scanStore' is the IO edge that reads the store, and deletion is +-- 'NovaCache.Store.removeNar'. +-- +-- Three rules keep a run from deleting a NAR the cache still needs. A +-- NAR younger than the minimum age is never eligible, because a NAR is +-- unreferenced legitimately until its push sends the narinfo. A narinfo +-- that cannot be read, parsed, or resolved to a file under @nar\/@ +-- blocks the whole run: the NAR it names is unknown, so no NAR can be +-- shown to be unreferenced. And a store holding NARs and no narinfo at +-- all blocks it too ('NoNarInfos'). None of them makes a run atomic +-- with the server: 'scanStore' says what remains. +module NovaCache.Reclaim + ( -- * Narinfo references + NarInfoTarget (..), + narInfoTarget, + narInfoNarName, + Unresolved (..), + collectReferences, + + -- * Selection + defaultMinimumAge, + ReclaimPlan (..), + selectUnreferenced, + ReclaimBlocked (..), + planReclaim, + + -- * Scanning a store + StoreScan (..), + scanStore, + ) +where + +import Control.Exception (IOException, try) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime, nominalDay) +import NovaCache.NarInfo (NarInfo (..), parseNarInfo) +import NovaCache.Store (FileStore, NarFile (..), listNarFiles, listNarInfoFiles, sanitizePath) +import System.IO.Error (ioeGetErrorString) + +-- --------------------------------------------------------------------------- +-- Narinfo references +-- --------------------------------------------------------------------------- + +-- | The URL prefix under which the server serves NARs +-- (@GET \/nar\/\@), and the one every writer puts in a narinfo. +narUrlPrefix :: Text +narUrlPrefix = "nar/" + +-- | What one stored narinfo says about the NARs. +data NarInfoTarget + = -- | It names this file under @nar\/@. + NamesNar !Text + | -- | It could not be read, decoded, parsed or resolved, for this + -- reason, so the NAR it names is unknown. + Unresolvable !String + deriving (Eq, Show) + +-- | Resolve a narinfo file's contents, or the error reading them. +narInfoTarget :: Either IOException ByteString -> NarInfoTarget +narInfoTarget contents = either Unresolvable NamesNar $ do + bytes <- first ioeGetErrorString contents + text <- first (const "not valid UTF-8") (TE.decodeUtf8' bytes) + parseNarInfo text >>= narInfoNarName + +-- | The file under @nar\/@ a narinfo names. The URL is authoritative: +-- upstream fetches @info->url@ as written (appended to the cache URI, +-- or verbatim when absolute) and never rebuilds a name from FileHash +-- and Compression, so the compression suffix is whatever the URL +-- carries. Only the spelling writers produce resolves, @nar\/\@ +-- with a name 'sanitizePath' admits. Any other URL (absolute, with a +-- percent-escape, a dot segment or a query) might still reach a file +-- here through the server's routing, so it is unresolvable rather than +-- read as naming nothing. +narInfoNarName :: NarInfo -> Either String Text +narInfoNarName ni = case T.stripPrefix narUrlPrefix (niUrl ni) of + -- A copy, so the reference set holds the name and not the whole + -- narinfo text it was sliced from. + Just name | Just _ <- sanitizePath name -> Right (T.copy name) + _ -> Left ("URL " ++ show (niUrl ni) ++ " does not name a file under " ++ T.unpack narUrlPrefix) + +-- | A narinfo that blocks the run, and why. +data Unresolved = Unresolved + { unresolvedPath :: !FilePath, + unresolvedReason :: !String + } + deriving (Eq, Show) + +-- | The NARs the narinfos name, or every narinfo whose NAR is unknown. +-- One unknown is enough to block: skipping it would leave the NAR it +-- names looking unreferenced. +collectReferences :: [(FilePath, NarInfoTarget)] -> Either (NonEmpty Unresolved) (Set Text) +collectReferences narInfos = + case nonEmpty [Unresolved path reason | (path, Unresolvable reason) <- narInfos] of + Just unresolved -> Left unresolved + Nothing -> Right (Set.fromList [name | (_, NamesNar name) <- narInfos]) + +-- --------------------------------------------------------------------------- +-- Selection +-- --------------------------------------------------------------------------- + +-- | How old an unreferenced NAR must be before it is eligible: two +-- weeks. +-- +-- A NAR stays unreferenced for the rest of the push that uploaded it, +-- and nothing bounds that: nova-nix uploads every NAR of a closure +-- before the first narinfo, with no response timeout. Deleting one +-- early leaves a narinfo naming a missing NAR, which no later push +-- repairs (a push skips paths whose narinfo exists), while waiting +-- costs only disk. git guards the same race, between gc and a writer +-- that has stored an object but not yet referenced it, with the same +-- two weeks (@gc.pruneExpire@). +defaultMinimumAge :: NominalDiffTime +defaultMinimumAge = 14 * nominalDay + +-- | The unreferenced NARs of a store, split by the minimum age. +data ReclaimPlan = ReclaimPlan + { -- | Old enough to delete. + rpEligible :: ![NarFile], + -- | Younger than the minimum age: a push may yet reference them. + rpTooYoung :: ![NarFile] + } + deriving (Eq, Show) + +-- | Split the NARs no reference names by their age at the given time, +-- counted from the modification time. A NAR uploaded again is renamed +-- over the old file, which restarts its age. +selectUnreferenced :: NominalDiffTime -> UTCTime -> Set Text -> [NarFile] -> ReclaimPlan +selectUnreferenced minimumAge now references nars = + ReclaimPlan {rpEligible = old, rpTooYoung = young} + where + (old, young) = partition oldEnough (filter unreferenced nars) + unreferenced nar = Set.notMember (nfName nar) references + oldEnough nar = diffUTCTime now (nfModified nar) >= minimumAge + +-- | Why a run cannot be planned. +data ReclaimBlocked + = -- | These narinfos name NARs that are unknown. + UnresolvedNarInfos !(NonEmpty Unresolved) + | -- | The store holds NARs and no narinfo. A store whose every NAR is + -- unreferenced looks like this, and so does one that lost its + -- @narinfo\/@ directory, which the server recreates empty when it + -- starts. Deleting is right for the first and destroys the second, + -- and a scan cannot tell them apart. + NoNarInfos + deriving (Eq, Show) + +-- | Plan a run from a scan: the unreferenced NARs by age, or why the +-- run is blocked. +planReclaim :: NominalDiffTime -> StoreScan -> Either ReclaimBlocked ReclaimPlan +planReclaim minimumAge scan + | null (scanNarInfos scan) && not (null (scanNars scan)) = Left NoNarInfos + | otherwise = do + references <- first UnresolvedNarInfos (collectReferences (scanNarInfos scan)) + pure (selectUnreferenced minimumAge (scanTime scan) references (scanNars scan)) + +-- --------------------------------------------------------------------------- +-- Scanning a store +-- --------------------------------------------------------------------------- + +-- | What a scan read: each narinfo's target, each NAR, and the time the +-- NARs were listed. +data StoreScan = StoreScan + { scanNarInfos :: ![(FilePath, NarInfoTarget)], + scanNars :: ![NarFile], + scanTime :: !UTCTime + } + deriving (Eq, Show) + +-- | Read a store for 'planReclaim'. A directory that cannot be listed, +-- or a NAR that cannot be stat'd, fails the scan with its +-- 'IOException'; an unreadable narinfo is recorded as 'Unresolvable'. +-- +-- The narinfos are read before the NARs are listed, the order git's +-- prune uses (reachability first, then each object's age): a NAR +-- uploaded again while the narinfos are read shows its new +-- modification time. A run is still not atomic with the server, so it +-- belongs on a cache with no push in progress. A narinfo that arrives +-- after the narinfo listing for a NAR older than the minimum age loses +-- that NAR: a push slower than the minimum age does this, and so does a +-- client (upstream @nix copy@) that skips re-uploading a NAR already +-- present. A NAR uploaded again after the NARs are listed goes too, +-- since removal does not look at the file again. Only a lock shared +-- with the server would close these. +scanStore :: FileStore -> IO StoreScan +scanStore store = do + narInfos <- traverse readTarget =<< listNarInfoFiles store + nars <- listNarFiles store + now <- getCurrentTime + pure StoreScan {scanNarInfos = narInfos, scanNars = nars, scanTime = now} + where + -- Forced per file, so each narinfo's bytes are garbage once its + -- target is known instead of held until the scan is planned. + readTarget path = do + contents <- try (BS.readFile path) + let !target = narInfoTarget contents + pure (path, target) diff --git a/src/NovaCache/SafeName.hs b/src/NovaCache/SafeName.hs --- a/src/NovaCache/SafeName.hs +++ b/src/NovaCache/SafeName.hs @@ -28,8 +28,7 @@ -- form)? The comparison runs on the stem - the portion before the -- first dot, trailing spaces trimmed - since @nul.txt@ and @NUL .txt@ -- also open the device. Surfaced to store writers through --- 'NovaCache.NAR.Stream.isWindowsHazardName', and kept in step with --- the twin guard nova-nix applies when it materializes NAR entries. +-- 'NovaCache.NAR.Stream.isWindowsHazardName'. -- -- Device matching is ASCII case-insensitive, so only @A@-@Z@ fold; any -- other byte passes through and can never match the named set. diff --git a/src/NovaCache/Server.hs b/src/NovaCache/Server.hs --- a/src/NovaCache/Server.hs +++ b/src/NovaCache/Server.hs @@ -14,7 +14,7 @@ -- GET \/\.narinfo narinfo by store-path hash -- GET \/nar\/\ NAR payload (streamed from disk) -- GET \/narinfo-hashes stored-hash listing (authenticated; push-tool plumbing) --- PUT \/\.narinfo validated, signed, stored (authenticated) +-- PUT \/\.narinfo validated, checked against its stored NAR, signed, stored (authenticated) -- PUT \/nar\/\ streamed to disk under a size cap (authenticated) -- @ -- @@ -42,9 +42,19 @@ narInfoHashMatches, signNarInfo, renderCacheInfo, + + -- * Stored NAR check + NarClaim (..), + StoredNar (..), + NarRefusal (..), + narUrlFileName, + narClaim, + judgeStoredNar, + renderNarRefusal, ) where +import Control.Exception (IOException, try) import Data.Bifunctor (first) import Data.ByteArray (constEq) import Data.ByteString (ByteString) @@ -71,6 +81,7 @@ responseFile, responseLBS, ) +import NovaCache.Hash (NixHash, formatNixHash, hashFinalize, hashInit, hashUpdate, parseNixHash) import NovaCache.NarInfo (NarInfo (..), parseNarInfo, renderNarInfo) import NovaCache.Signing (SecretKey, sign) import NovaCache.Store @@ -81,12 +92,13 @@ listNarInfoHashes, narFilePath, readNarInfo, + sanitizePath, writeNarInfo, writeNarStreaming, ) import NovaCache.StorePath (defaultStoreDir, parseStorePath, storePathHashString) import NovaCache.Validate (validateNarInfo) -import System.IO (hPutStrLn, stderr) +import System.IO (IOMode (ReadMode), hPutStrLn, stderr, withBinaryFile) -- --------------------------------------------------------------------------- -- Constants @@ -106,6 +118,14 @@ narInfoSuffix :: Text narInfoSuffix = ".narinfo" +-- | First path segment of NAR request paths (@\/nar\/\@). +narRouteSegment :: Text +narRouteSegment = "nar" + +-- | Bytes read per step while hashing a stored NAR. +storedNarReadBytes :: Int +storedNarReadBytes = 128 * 1024 + -- --------------------------------------------------------------------------- -- Configuration -- --------------------------------------------------------------------------- @@ -189,42 +209,23 @@ respond notFound -- GET /nar/ - handed to the transport layer as a file so the -- OS streams it; a multi-GB NAR never transits the Haskell heap. - ("GET", ["nar", fileName]) -> do - found <- narFilePath (scStore cfg) fileName - case found of - Just path -> - respond (responseFile HTTP.status200 octetHeaders path Nothing) - Nothing -> - respond notFound + ("GET", segments) + | Just fileName <- narRoute segments -> do + found <- narFilePath (scStore cfg) fileName + case found of + Just path -> + respond (responseFile HTTP.status200 octetHeaders path Nothing) + Nothing -> + respond notFound -- PUT /.narinfo (auth required, validated) ("PUT", [hashNarinfo]) | Just hashKey <- T.stripSuffix narInfoSuffix hashNarinfo -> requireAuth cfg req respond $ - withLimitedBody maxNarInfoBodySize req respond $ \body -> - case decodeAndValidate body of - Left err -> do - logWarn req ("INVALID: " <> T.unpack err) - respond (badRequest err) - Right ni - | not (narInfoHashMatches hashKey ni) -> do - logWarn req "HASHMISMATCH" - respond (badRequest "narinfo StorePath hash does not match request") - | otherwise -> do - signedResult <- signNarInfo (scSigningKey cfg) ni - case signedResult of - Left err -> do - logWarn req ("SIGNFAIL: " <> err) - respond (responseLBS HTTP.status500 textHeaders "signing failed") - Right signed -> do - ok <- writeNarInfo (scStore cfg) hashKey signed - if ok - then respond (responseLBS HTTP.status200 textHeaders "ok") - else do - logWarn req "BADPATH" - respond (badRequest "invalid path") + withLimitedBody maxNarInfoBodySize req respond (putNarInfo cfg req respond hashKey) -- PUT /nar/ (auth required, streamed) - ("PUT", ["nar", fileName]) -> - requireAuth cfg req respond (putNar cfg req respond fileName) + ("PUT", segments) + | Just fileName <- narRoute segments -> + requireAuth cfg req respond (putNar cfg req respond fileName) -- Fallback _ -> respond notFound @@ -237,6 +238,36 @@ then HTTP.methodGet else requestMethod req +-- | The file a @\/nar\/\@ request path names. +narRoute :: [Text] -> Maybe Text +narRoute [segment, fileName] | segment == narRouteSegment = Just fileName +narRoute _ = Nothing + +-- | Validate a narinfo upload, check it against the NAR it names, then +-- sign and store it. +putNarInfo :: ServerConfig -> Request -> (Response -> IO ResponseReceived) -> Text -> ByteString -> IO ResponseReceived +putNarInfo cfg req respond hashKey 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 -> requireStoredNar (scStore cfg) req respond ni $ 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") + -- | 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 @@ -282,6 +313,146 @@ Left _ -> False -- --------------------------------------------------------------------------- +-- Stored NAR check +-- --------------------------------------------------------------------------- + +-- | What a narinfo declares about the NAR its URL names: the file's name +-- under @nar\/@, and the size and SHA-256 it must have. +data NarClaim = NarClaim + { ncFileName :: !Text, + ncFileSize :: !Integer, + ncFileHash :: !NixHash + } + deriving (Eq, Show) + +-- | A stored NAR as read: its size in bytes and its SHA-256. +data StoredNar = StoredNar + { snSize :: !Integer, + snHash :: !NixHash + } + deriving (Eq, Show) + +-- | Why a narinfo is refused over the NAR its URL names. +data NarRefusal + = -- | The URL names no file this cache serves under @nar\/@. + NarUrlNotServed !Text + | -- | No FileSize, so a short NAR could not be told from a whole one. + NarFileSizeUndeclared + | -- | No FileHash, so a NAR of the right size and the wrong content + -- could not be told from the right one. + NarFileHashUndeclared + | -- | The FileHash does not parse. (raw value, parse error) + NarFileHashInvalid !Text !String + | -- | No file is stored under the name. + NarNotStored !Text + | -- | The stored file has another size. (name, declared, stored) + NarSizeMismatch !Text !Integer !Integer + | -- | The stored file has other content. (name, declared, stored) + NarHashMismatch !Text !NixHash !NixHash + deriving (Eq, Show) + +-- | The file under @nar\/@ a GET for a narinfo's URL is routed to. +-- Upstream requests a relative URL at the cache URI joined by a slash +-- (@HttpBinaryCacheStore::makeRequest@), and Warp cuts the request +-- target at its first @?@ and splits and percent-decodes the path with +-- 'HTTP.decodePathSegments' into 'pathInfo', which is what +-- 'HTTP.decodePath' does to the same bytes. An absolute URL is fetched +-- from its own host, and resolves here to segments no route matches. +narUrlFileName :: Text -> Maybe Text +narUrlFileName url = narRoute (fst (HTTP.decodePath ("/" <> TE.encodeUtf8 url))) + +-- | Read what a narinfo declares about its NAR. A writer that omits +-- FileSize or FileHash is refused rather than half-checked: upstream's +-- @BinaryCacheStore::addToStoreCommon@ and nova-nix's push both always +-- send them, and the signature this cache adds does not cover them, so +-- they are the only record of which file the narinfo describes. +narClaim :: NarInfo -> Either NarRefusal NarClaim +narClaim ni = do + fileName <- maybe (Left (NarUrlNotServed (niUrl ni))) Right (narUrlFileName (niUrl ni) >>= storable) + fileSize <- maybe (Left NarFileSizeUndeclared) Right (niFileSize ni) + declaredHash <- maybe (Left NarFileHashUndeclared) Right (niFileHash ni) + fileHash <- first (NarFileHashInvalid declaredHash) (parseNixHash declaredHash) + pure NarClaim {ncFileName = fileName, ncFileSize = fileSize, ncFileHash = fileHash} + where + -- The router percent-decodes leniently, but every name the store + -- admits is ASCII, so bytes that are not UTF-8 never name a file. + storable name = name <$ sanitizePath name + +-- | Accept the stored NAR only when it is the file the narinfo declares: +-- present, FileSize bytes long, and hashing to FileHash. +judgeStoredNar :: NarClaim -> Maybe StoredNar -> Either NarRefusal () +judgeStoredNar claim stored = case stored of + Nothing -> Left (NarNotStored name) + Just (StoredNar size digest) + | size /= ncFileSize claim -> Left (NarSizeMismatch name (ncFileSize claim) size) + | digest /= ncFileHash claim -> Left (NarHashMismatch name (ncFileHash claim) digest) + | otherwise -> Right () + where + name = ncFileName claim + +-- | The message a refused narinfo upload answers with. +renderNarRefusal :: NarRefusal -> Text +renderNarRefusal refusal = case refusal of + NarUrlNotServed url -> + "narinfo URL " <> url <> " does not name a file under " <> narRouteSegment <> "/" + NarFileSizeUndeclared -> + "narinfo declares no FileSize to check its NAR against" + NarFileHashUndeclared -> + "narinfo declares no FileHash to check its NAR against" + NarFileHashInvalid raw err -> + "narinfo FileHash " <> raw <> " does not parse: " <> T.pack err + NarNotStored name -> + "NAR " <> narPath name <> " is not stored; upload it before its narinfo" + NarSizeMismatch name declared stored -> + "NAR " <> narPath name <> " is " <> showText stored <> " bytes, narinfo FileSize is " <> showText declared + NarHashMismatch name declared stored -> + "NAR " <> narPath name <> " hashes to " <> formatNixHash stored <> ", narinfo FileHash is " <> formatNixHash declared + where + showText = T.pack . show + +-- | The request path, relative to the cache root, that serves a NAR. +narPath :: Text -> Text +narPath name = narRouteSegment <> "/" <> name + +-- | Gate a narinfo write on the NAR it names (see 'narClaim' and +-- 'judgeStoredNar'). A refusal is a 400 naming the problem. A stored +-- NAR that cannot be read is the server's own failure, a 500 like a +-- signing failure, with the exception logged and kept out of the +-- response. +requireStoredNar :: FileStore -> Request -> (Response -> IO ResponseReceived) -> NarInfo -> IO ResponseReceived -> IO ResponseReceived +requireStoredNar store req respond ni action = case narClaim ni of + Left refusal -> refuse refusal + Right claim -> do + stored <- readStoredNar store (ncFileName claim) + case stored of + Left err -> do + logWarn req ("NARREAD: " <> show err) + respond (responseLBS HTTP.status500 textHeaders (textBody ("NAR " <> narPath (ncFileName claim) <> " could not be read"))) + Right found -> either refuse (const action) (judgeStoredNar claim found) + where + refuse refusal = do + let msg = renderNarRefusal refusal + logWarn req ("BADNAR: " <> T.unpack msg) + respond (badRequest msg) + +-- | Read a stored NAR through once in constant memory, for its size and +-- SHA-256; 'Nothing' when no file is stored under the name. The name +-- resolves through 'narFilePath', as @GET \/nar\/\@ does. +-- +-- An upload of the same name while this reads is renamed into place, +-- and on POSIX the open handle keeps reading the file it opened, so +-- the result describes one whole upload or the other, never a mix. +readStoredNar :: FileStore -> Text -> IO (Either IOException (Maybe StoredNar)) +readStoredNar store fileName = try (traverse measure =<< narFilePath store fileName) + where + measure path = withBinaryFile path ReadMode (consume 0 hashInit) + consume !size !ctx handle = do + chunk <- BS.hGetSome handle storedNarReadBytes + if BS.null chunk + then pure StoredNar {snSize = size, snHash = hashFinalize ctx} + else consume (size + fromIntegral (BS.length chunk)) (hashUpdate ctx chunk) handle + +-- --------------------------------------------------------------------------- -- Request body limiting -- --------------------------------------------------------------------------- @@ -402,7 +573,11 @@ -- | 400 Bad Request with a text error message. badRequest :: Text -> Response -badRequest msg = responseLBS HTTP.status400 textHeaders (BL.fromStrict (TE.encodeUtf8 msg)) +badRequest msg = responseLBS HTTP.status400 textHeaders (textBody msg) + +-- | A text response body. +textBody :: Text -> BL.ByteString +textBody = BL.fromStrict . TE.encodeUtf8 -- | Map any uncaught handler exception to a generic 500, so internal error -- detail (filesystem paths, exception text) is never leaked to clients. diff --git a/src/NovaCache/Store.hs b/src/NovaCache/Store.hs --- a/src/NovaCache/Store.hs +++ b/src/NovaCache/Store.hs @@ -9,6 +9,7 @@ module NovaCache.Store ( FileStore (..), newFileStore, + fileStoreAt, readNarInfo, writeNarInfo, readNar, @@ -16,24 +17,34 @@ NarWriteResult (..), writeNarStreaming, narFilePath, + NarRemoveResult (..), + removeNar, listNarInfoHashes, + listNarInfoFiles, + NarFile (..), + listNarFiles, CacheInfo (..), getCacheInfo, sanitizePath, ) where -import Control.Exception (IOException, SomeException, catch, onException) +import Control.Exception (IOException, SomeException, catch, onException, try) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char (isAsciiLower, isAsciiUpper, isDigit) +import Data.List (isPrefixOf) +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Data.Time.Clock (UTCTime) import NovaCache.SafeName (hasTrailingDotOrSpace, isReservedDeviceName) import System.Directory ( createDirectoryIfMissing, doesFileExist, + getFileSize, + getModificationTime, listDirectory, removeFile, renameFile, @@ -90,13 +101,21 @@ newFileStore root = do createDirectoryIfMissing True (root narinfoSubdir) createDirectoryIfMissing True (root narSubdir) - pure - FileStore - { fsRoot = root, - fsStoreDir = defaultStoreDir, - fsPriority = defaultPriority - } + pure (fileStoreAt root) +-- | A 't:FileStore' over a directory tree as it stands, creating +-- nothing. For a host tool that reads the store and acts on what it +-- finds: a mistyped root, or a store missing its @narinfo@ directory, +-- must fail the listing, not be scanned as an empty store whose every +-- NAR looks unreferenced. +fileStoreAt :: FilePath -> FileStore +fileStoreAt root = + FileStore + { fsRoot = root, + fsStoreDir = defaultStoreDir, + fsPriority = defaultPriority + } + -- --------------------------------------------------------------------------- -- NarInfo operations -- --------------------------------------------------------------------------- @@ -191,6 +210,26 @@ exists <- doesFileExist path pure (if exists then Just path else Nothing) +-- | Outcome of removing a stored NAR. +data NarRemoveResult + = -- | The file is gone. + NarRemoved + | -- | The filesystem refused; nothing was removed. + NarRemoveFailed !IOException + | -- | The filename failed 'sanitizePath'; nothing was touched. + NarRemoveBadPath + deriving (Eq, Show) + +-- | Remove a stored NAR by its filename. Nothing in the HTTP protocol +-- calls this: deletion is for a tool the host operator runs against +-- the store directory. +removeNar :: FileStore -> Text -> IO NarRemoveResult +removeNar fs fileName = case sanitizePath fileName of + Nothing -> pure NarRemoveBadPath + Just safe -> + either NarRemoveFailed (const NarRemoved) + <$> tryIO (removeFile (fsRoot fs narSubdir safe)) + -- --------------------------------------------------------------------------- -- Listing -- --------------------------------------------------------------------------- @@ -201,9 +240,58 @@ -- Filters out temporary files from in-progress atomic writes. listNarInfoHashes :: FileStore -> IO [Text] listNarInfoHashes fs = - filter (not . T.isPrefixOf ".") . map T.pack + map T.pack . filter (not . isHiddenEntry) <$> listDirectory (fsRoot fs narinfoSubdir) +-- | The path of every stored narinfo: the files 'listNarInfoHashes' +-- names. +listNarInfoFiles :: FileStore -> IO [FilePath] +listNarInfoFiles fs = + map (dir ) . filter (not . isHiddenEntry) <$> listDirectory dir + where + dir = fsRoot fs narinfoSubdir + +-- | A stored NAR as listed. +data NarFile = NarFile + { -- | The filename under @nar\/@, as @PUT \/nar\/\@ named it. + nfName :: !Text, + nfPath :: !FilePath, + nfSize :: !Integer, + nfModified :: !UTCTime + } + deriving (Eq, Show) + +-- | Every stored NAR: the regular files under @nar\/@ whose names +-- 'sanitizePath' admits, which are exactly the names an upload can +-- create. An upload is written to a dotfile and renamed into place +-- only once complete, and 'sanitizePath' admits no dotfile, so a +-- partial write is never listed. The rename keeps the temp file's +-- modification time, so 'nfModified' is when the upload's last bytes +-- were written. +listNarFiles :: FileStore -> IO [NarFile] +listNarFiles fs = catMaybes <$> (traverse describe =<< listDirectory dir) + where + dir = fsRoot fs narSubdir + describe entry = case sanitizePath (T.pack entry) of + Nothing -> pure Nothing + Just safe -> do + let path = dir safe + isFile <- doesFileExist path + if isFile + then do + size <- getFileSize path + modified <- getModificationTime path + pure + ( Just + NarFile + { nfName = T.pack safe, + nfPath = path, + nfSize = size, + nfModified = modified + } + ) + else pure Nothing + -- --------------------------------------------------------------------------- -- Cache metadata -- --------------------------------------------------------------------------- @@ -283,6 +371,17 @@ renameFile tmpPath target ) `onException` cleanup + +-- | A dotfile: every temp file the atomic writes create (the +-- template's leading dot survives 'openBinaryTempFile'), and never a +-- key 'sanitizePath' admits. +isHiddenEntry :: FilePath -> Bool +isHiddenEntry = isPrefixOf "." + +-- | 'try' at 'IOException', the failure a filesystem call is expected +-- to raise; anything else (an interrupt among them) propagates. +tryIO :: IO a -> IO (Either IOException a) +tryIO = try -- | Swallow all exceptions from a cleanup action. ignoringExceptions :: IO () -> IO () diff --git a/src/NovaCache/Xz.hs b/src/NovaCache/Xz.hs --- a/src/NovaCache/Xz.hs +++ b/src/NovaCache/Xz.hs @@ -160,7 +160,10 @@ -- zlib and bzlib bindings use for the same job. A pull that -- throws, or a consumer that exits early, holds the decoder state -- (bounded by 'xzMaxDecoderMemoryBytes') until a GC runs the --- finalizer. +-- finalizer. The binding keeps @endLzmaStream@ in a hidden module, +-- so nothing here can end a live stream early. Once xz exports it +-- (#46), this becomes a real bracket that ends the stream on every +-- exit. withXzSource :: XzLimits -> IO ByteString -> (IO ByteString -> IO a) -> IO a withXzSource limits compressedSource consume = do start <- Lzma.decompressIO (decompressParams limits) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,21 +2,27 @@ module Main (main) where -import Control.Exception (SomeException, try) +import Control.Exception (IOException, 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.Builder as Builder import qualified Data.ByteString.Lazy as BL -import Data.Either (isLeft) +import Data.Either (isLeft, isRight) +import Data.Foldable (toList) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (isSuffixOf, sort) import Data.Maybe (isJust) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay) import Data.Word (Word64, Word8) import qualified Network.HTTP.Types as HTTP import Network.Wai (RequestBodyLength (..), defaultRequest, pathInfo, requestBodyLength, requestHeaders, requestMethod) @@ -26,15 +32,17 @@ import qualified NovaCache.NAR as NAR import qualified NovaCache.NAR.Stream as Stream import qualified NovaCache.NarInfo as NarInfo +import qualified NovaCache.Reclaim as Reclaim import qualified NovaCache.Server as Server import qualified NovaCache.Signing as Signing import qualified NovaCache.Store as Store import qualified NovaCache.StorePath as StorePath import qualified NovaCache.Validate as Validate -import System.Directory (createDirectory, createFileLink, getPermissions, getTemporaryDirectory, listDirectory, removeDirectoryRecursive, setOwnerExecutable, setPermissions) +import System.Directory (createDirectory, createFileLink, doesDirectoryExist, emptyPermissions, getPermissions, getTemporaryDirectory, listDirectory, readable, removeDirectoryRecursive, removeFile, setModificationTime, setOwnerExecutable, setPermissions) import System.Exit (exitFailure, exitSuccess) import System.IO (hFlush, stdout) import qualified System.Info +import Test.QuickCheck (Args (chatty), Gen, Result (Failure, GaveUp, NoExpectedFailure, Success, output), Testable, arbitrary, choose, elements, forAll, frequency, listOf, listOf1, oneof, property, quickCheckWithResult, stdArgs, sublistOf, suchThat, vectorOf, (===)) -- --------------------------------------------------------------------------- -- Test harness (hand-rolled, no framework) @@ -139,8 +147,10 @@ testNarInfo, testSigning, testFileStore, + testReclaim, testValidate, - testServer + testServer, + testStoredNarCheck ] -- --------------------------------------------------------------------------- @@ -1395,6 +1405,245 @@ ] -- --------------------------------------------------------------------------- +-- Reclaim tests +-- --------------------------------------------------------------------------- + +testReclaim :: IO Bool +testReclaim = + runGroup + "Reclaim" + [ test "a nar/ URL names that file, compression suffix included" $ + assertEqual + "target" + (Reclaim.NamesNar "1w1fff338fvdw53sqgamddn1b2xgds473pv6y13gizdbqjv4i5p3.nar.zst") + (narInfoBytesTarget (mkValidNarInfo {NarInfo.niUrl = "nar/1w1fff338fvdw53sqgamddn1b2xgds473pv6y13gizdbqjv4i5p3.nar.zst"})), + test "a URL in any other spelling is unresolvable" $ + let spellings = + [ "https://cache.example/nar/x.nar", + "./nar/x.nar", + "nar/../x.nar", + "nar/a/x.nar", + "nar/x.nar?v=1", + "nar/x%2Enar", + "nar/.nova1.tmp", + "nar/", + "x.nar" + ] + resolved = [url | url <- spellings, not (isUnresolvable (narInfoBytesTarget (mkValidNarInfo {NarInfo.niUrl = url})))] + in assertEqual "spellings that resolved" [] resolved, + test "an unreadable, undecodable or unparseable narinfo is unresolvable" $ do + let unreadable = Reclaim.narInfoTarget (Left (userError "permission denied")) + undecodable = Reclaim.narInfoTarget (Right (BS.pack [0x55, 0x52, 0x4c, 0x3a, 0xff])) + unparseable = Reclaim.narInfoTarget (Right "StorePath: /nix/store/x\nNarSize: 5\n") + assertTrue "all unresolvable" (all isUnresolvable [unreadable, undecodable, unparseable]), + test "property: a nar/ URL resolves to the name through the parser" $ + checkProperty $ + forAll genSafeNarName $ \name -> + narInfoBytesTarget (mkValidNarInfo {NarInfo.niUrl = "nar/" <> name}) === Reclaim.NamesNar name, + test "property: a referenced NAR is never selected" $ + checkProperty $ + forAll genSelection $ \(minimumAge, references, nars) -> + let selected = selectAll minimumAge references nars + in all ((`Set.notMember` references) . Store.nfName) selected, + test "property: the selection is a subset of the NARs present" $ + checkProperty $ + forAll genSelection $ \(minimumAge, references, nars) -> + all (`elem` nars) (selectAll minimumAge references nars), + test "property: every unreferenced NAR is either eligible or kept, never both" $ + checkProperty $ + forAll genSelection $ \(minimumAge, references, nars) -> + sort (map Store.nfName (selectAll minimumAge references nars)) + === sort [Store.nfName nar | nar <- nars, Set.notMember (Store.nfName nar) references], + test "property: eligible NARs are at least the minimum age, kept ones younger" $ + checkProperty $ + forAll genSelection $ \(minimumAge, references, nars) -> + let plan = Reclaim.selectUnreferenced minimumAge referenceTime references nars + in all ((>= minimumAge) . ageOf) (Reclaim.rpEligible plan) + && all ((< minimumAge) . ageOf) (Reclaim.rpTooYoung plan), + test "property: adding a narinfo never grows the eligible set" $ + checkProperty $ + forAll genSelection $ \(minimumAge, references, nars) -> + forAll genNarName $ \added -> + let eligible refs = Reclaim.rpEligible (Reclaim.selectUnreferenced minimumAge referenceTime refs nars) + in all (`elem` eligible references) (eligible (Set.insert added references)), + test "property: raising the minimum age never grows the eligible set" $ + checkProperty $ + forAll genSelection $ \(minimumAge, references, nars) -> + forAll genMinimumAge $ \raise -> + let eligible age = Reclaim.rpEligible (Reclaim.selectUnreferenced age referenceTime references nars) + in all (`elem` eligible minimumAge) (eligible (minimumAge + raise)), + test "property: any unresolvable narinfo blocks the run, and all are reported" $ + checkProperty $ + forAll genSelection $ \(minimumAge, _, nars) -> + forAll (listOf genTarget) $ \targets -> + let narInfos = zip [show i | i <- [0 :: Int ..]] targets + scan = Reclaim.StoreScan {Reclaim.scanNarInfos = narInfos, Reclaim.scanNars = nars, Reclaim.scanTime = referenceTime} + blocking = [path | (path, Reclaim.Unresolvable _) <- narInfos] + in case Reclaim.planReclaim minimumAge scan of + Left (Reclaim.UnresolvedNarInfos unresolved) -> map Reclaim.unresolvedPath (toList unresolved) === blocking + Left Reclaim.NoNarInfos -> property (null targets && not (null nars)) + Right _ -> blocking === [], + test "property: a store with NARs and no narinfo blocks the run, and an empty store plans nothing" $ + checkProperty $ + forAll genSelection $ \(minimumAge, _, nars) -> + let scan = Reclaim.StoreScan {Reclaim.scanNarInfos = [], Reclaim.scanNars = nars, Reclaim.scanTime = referenceTime} + expected = case nars of + [] -> Right Reclaim.ReclaimPlan {Reclaim.rpEligible = [], Reclaim.rpTooYoung = []} + _ -> Left Reclaim.NoNarInfos + in Reclaim.planReclaim minimumAge scan === expected, + test "a NAR exactly the minimum age old is eligible" $ + let nar = narAged "edge.nar" Reclaim.defaultMinimumAge + plan = Reclaim.selectUnreferenced Reclaim.defaultMinimumAge referenceTime Set.empty [nar] + in assertEqual "eligible" [nar] (Reclaim.rpEligible plan), + test "a scan of a store: blocked by a broken narinfo, then reclaimed" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + now <- getCurrentTime + let monthAgo = addUTCTime (negate (30 * nominalDay)) now + narPath name = tmpDir ++ "/nar/" ++ name + putNar name modified = do + _ <- Store.writeNar store (T.pack name) "nar bytes" + setModificationTime (narPath name) modified + _ <- Store.writeNarInfo store "referencing" (TE.encodeUtf8 (NarInfo.renderNarInfo (mkValidNarInfo {NarInfo.niUrl = "nar/ref.nar.zst"}))) + _ <- Store.writeNarInfo store "broken" "not a narinfo\n" + putNar "ref.nar.zst" monthAgo + putNar "old.nar.zst" monthAgo + putNar "young.nar.zst" now + -- An upload in progress: the temp name a streaming write uses. + BS.writeFile (narPath ".nova123-4.tmp") "partial" + setModificationTime (narPath ".nova123-4.tmp") monthAgo + blocked <- Reclaim.planReclaim Reclaim.defaultMinimumAge <$> Reclaim.scanStore store + removeFile (tmpDir ++ "/narinfo/broken") + reclaimable <- Reclaim.planReclaim Reclaim.defaultMinimumAge <$> Reclaim.scanStore store + let blockedBy = case blocked of + Left (Reclaim.UnresolvedNarInfos unresolved) -> map Reclaim.unresolvedPath (toList unresolved) + _ -> [] + eligible = either (const []) (map Store.nfName . Reclaim.rpEligible) reclaimable + tooYoung = either (const []) (map Store.nfName . Reclaim.rpTooYoung) reclaimable + removals <- traverse (Store.removeNar store) eligible + remaining <- sort <$> listDirectory (tmpDir ++ "/nar") + removeDirectoryRecursive tmpDir + ok1 <- assertTrue "blocked by the broken narinfo alone" (case blockedBy of [path] -> "broken" `isSuffixOf` path; _ -> False) + ok2 <- assertEqual "eligible" ["old.nar.zst"] eligible + ok3 <- assertEqual "kept" ["young.nar.zst"] tooYoung + ok4 <- assertEqual "removals" [Store.NarRemoved] removals + ok5 <- assertEqual "remaining" [".nova123-4.tmp", "ref.nar.zst", "young.nar.zst"] remaining + pure (ok1 && ok2 && ok3 && ok4 && ok5), + test "a store whose narinfo directory the server recreated blocks the run" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + now <- getCurrentTime + _ <- Store.writeNar store "old.nar.zst" "nar bytes" + setModificationTime (tmpDir ++ "/nar/old.nar.zst") (addUTCTime (negate (30 * nominalDay)) now) + removeDirectoryRecursive (tmpDir ++ "/narinfo") + restarted <- Store.newFileStore tmpDir + plan <- Reclaim.planReclaim Reclaim.defaultMinimumAge <$> Reclaim.scanStore restarted + removeDirectoryRecursive tmpDir + assertEqual "blocked" (Left Reclaim.NoNarInfos) plan, + test "a scan of a missing store fails and creates nothing" $ do + tmpDir <- createTestDir + let missing = tmpDir ++ "/missing" + result <- try (Reclaim.scanStore (Store.fileStoreAt missing)) :: IO (Either IOException Reclaim.StoreScan) + created <- doesDirectoryExist missing + removeDirectoryRecursive tmpDir + ok1 <- assertTrue "scan failed" (isLeft result) + ok2 <- assertFalse "store created" created + pure (ok1 && ok2), + test "removeNar reports a missing file and refuses a traversal name" $ do + tmpDir <- createTestDir + store <- Store.newFileStore tmpDir + missing <- Store.removeNar store "absent.nar" + traversal <- Store.removeNar store "../escape.nar" + removeDirectoryRecursive tmpDir + ok1 <- assertTrue "missing file fails" (case missing of Store.NarRemoveFailed _ -> True; _ -> False) + ok2 <- assertEqual "traversal" Store.NarRemoveBadPath traversal + pure (ok1 && ok2) + ] + +-- | Run a QuickCheck property quietly, printing its report on failure. +checkProperty :: (Testable prop) => prop -> IO Bool +checkProperty prop = do + result <- quickCheckWithResult stdArgs {chatty = False} prop + case result of + Success {} -> pure True + Failure {output = report} -> failWith report + GaveUp {output = report} -> failWith report + NoExpectedFailure {output = report} -> failWith report + where + failWith report = do + putStrLn "" + putStr report + pure False + +-- | The target of a narinfo rendered and read back as the store holds it. +narInfoBytesTarget :: NarInfo.NarInfo -> Reclaim.NarInfoTarget +narInfoBytesTarget = Reclaim.narInfoTarget . Right . TE.encodeUtf8 . NarInfo.renderNarInfo + +isUnresolvable :: Reclaim.NarInfoTarget -> Bool +isUnresolvable (Reclaim.Unresolvable _) = True +isUnresolvable (Reclaim.NamesNar _) = False + +-- | Everything a selection names, eligible or kept. +selectAll :: NominalDiffTime -> Set Text -> [Store.NarFile] -> [Store.NarFile] +selectAll minimumAge references nars = + let plan = Reclaim.selectUnreferenced minimumAge referenceTime references nars + in Reclaim.rpEligible plan ++ Reclaim.rpTooYoung plan + +-- | The fixed "now" of the pure selection tests. +referenceTime :: UTCTime +referenceTime = UTCTime (fromGregorian 2026 10 9) 0 + +ageOf :: Store.NarFile -> NominalDiffTime +ageOf nar = diffUTCTime referenceTime (Store.nfModified nar) + +narAged :: Text -> NominalDiffTime -> Store.NarFile +narAged name age = + Store.NarFile + { Store.nfName = name, + Store.nfPath = "nar/" ++ T.unpack name, + Store.nfSize = 0, + Store.nfModified = addUTCTime (negate age) referenceTime + } + +-- | NAR names from a small pool, so references and listings overlap +-- often. +narNamePool :: [Text] +narNamePool = [T.pack ("n" ++ show i ++ ".nar.zst") | i <- [0 .. 11 :: Int]] + +genNarName :: Gen Text +genNarName = elements narNamePool + +-- | Whole hours, so ages land on the minimum age exactly now and then; +-- the negative end is a modification time in the future (a clock that +-- stepped back). +genAge :: Gen NominalDiffTime +genAge = (* 3600) . fromInteger <$> choose (-2, 24 * 30) + +genMinimumAge :: Gen NominalDiffTime +genMinimumAge = (* 3600) . fromInteger <$> choose (0, 24 * 21) + +-- | A listing has distinct names, as a directory does. +genListing :: Gen [Store.NarFile] +genListing = traverse (\name -> narAged name <$> genAge) =<< sublistOf narNamePool + +genSelection :: Gen (NominalDiffTime, Set Text, [Store.NarFile]) +genSelection = (,,) <$> genMinimumAge <*> (Set.fromList <$> sublistOf narNamePool) <*> genListing + +genTarget :: Gen Reclaim.NarInfoTarget +genTarget = + frequency + [ (4, Reclaim.NamesNar <$> genNarName), + (1, pure (Reclaim.Unresolvable "unparseable")) + ] + +-- | Names 'Store.sanitizePath' admits. +genSafeNarName :: Gen Text +genSafeNarName = + (T.pack <$> listOf1 (elements safeNameChars)) `suchThat` (isJust . Store.sanitizePath) + where + safeNameChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "._+-" + +-- --------------------------------------------------------------------------- -- Validate tests -- --------------------------------------------------------------------------- @@ -1592,16 +1841,25 @@ zeroNarHash :: Text zeroNarHash = "sha256:" <> T.replicate 52 "0" +-- | The file 'validServerNarInfo' names under @nar\/@. +serverNarName :: Text +serverNarName = "test.nar" + +-- | The bytes 'validServerNarInfo' declares for its NAR. +serverNarBytes :: ByteString +serverNarBytes = "nar-payload-bytes" + -- | A narinfo that passes 'Validate.validateNarInfo' end to end, keyed --- under 'validNarInfoHashKey'. +-- under 'validNarInfoHashKey', describing 'serverNarBytes' stored as +-- 'serverNarName'. validServerNarInfo :: NarInfo.NarInfo validServerNarInfo = NarInfo.NarInfo { NarInfo.niStorePath = "/nix/store/" <> validNarInfoHashKey <> "-hello-1.0", - NarInfo.niUrl = "nar/test.nar", + NarInfo.niUrl = "nar/" <> serverNarName, NarInfo.niCompression = "none", - NarInfo.niFileHash = Nothing, - NarInfo.niFileSize = Nothing, + NarInfo.niFileHash = Just (Hash.formatNixHash (Hash.hashBytes serverNarBytes)), + NarInfo.niFileSize = Just (fromIntegral (BS.length serverNarBytes)), NarInfo.niNarHash = zeroNarHash, NarInfo.niNarSize = 200, NarInfo.niReferences = [validNarInfoHashKey <> "-hello-1.0"], @@ -1612,9 +1870,29 @@ -- | Rendered wire form of 'validServerNarInfo'. validServerNarInfoBytes :: BL.ByteString -validServerNarInfoBytes = - BL.fromStrict (TE.encodeUtf8 (NarInfo.renderNarInfo validServerNarInfo)) +validServerNarInfoBytes = renderNarInfoBody validServerNarInfo +-- | A narinfo's wire form as a request body. +renderNarInfoBody :: NarInfo.NarInfo -> BL.ByteString +renderNarInfoBody = BL.fromStrict . TE.encodeUtf8 . NarInfo.renderNarInfo + +-- | Upload bytes as 'serverNarName', authenticated. +putServerNar :: Server.ServerConfig -> ByteString -> IO WT.SResponse +putServerNar cfg bytes = serverRequest cfg "PUT" ["nar", serverNarName] [serverAuthHeader] (BL.fromStrict bytes) + +-- | Upload a narinfo under 'validNarInfoHashKey', authenticated. +putServerNarInfo :: Server.ServerConfig -> NarInfo.NarInfo -> IO WT.SResponse +putServerNarInfo cfg ni = serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] (renderNarInfoBody ni) + +-- | Upload a NAR, then a narinfo for it; the narinfo's response, and the +-- status a GET of that narinfo answers afterwards. +putNarThenNarInfo :: Server.ServerConfig -> ByteString -> NarInfo.NarInfo -> IO (WT.SResponse, HTTP.Status) +putNarThenNarInfo cfg bytes ni = do + _ <- putServerNar cfg bytes + putResp <- putServerNarInfo cfg ni + getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" + pure (putResp, WT.simpleStatus getResp) + -- | 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 @@ -1675,6 +1953,18 @@ strictBody :: WT.SResponse -> ByteString strictBody = BL.toStrict . WT.simpleBody +-- | Take every permission from a file, and say whether that left it +-- unreadable. Windows has no mode bit that stops a read (and a +-- read-only file would then resist the test's cleanup), and root reads +-- a file whatever its mode, so on either there is no read failure to +-- cause. +makeUnreadable :: FilePath -> IO Bool +makeUnreadable path + | System.Info.os == "mingw32" = pure False + | otherwise = do + setPermissions path emptyPermissions + not . readable <$> getPermissions path + testServer :: IO Bool testServer = runGroup @@ -1730,6 +2020,7 @@ assertEqual "status" HTTP.status401 (WT.simpleStatus resp), test "PUT then GET narinfo roundtrip" $ withAuthedServer $ \cfg -> do + _ <- putServerNar cfg serverNarBytes putResp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] validServerNarInfoBytes getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) @@ -1744,6 +2035,7 @@ test "PUT narinfo signs when a key is configured" $ do sigKey <- generateTestSecretKey withServer (Just serverTestApiKey) (Just sigKey) $ \cfg -> do + _ <- putServerNar cfg serverNarBytes putResp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] validServerNarInfoBytes getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) @@ -1770,6 +2062,80 @@ [serverAuthHeader] (fromIntegral Server.maxNarInfoBodySize + 1) assertEqual "status" HTTP.status413 (WT.simpleStatus resp), + -- A narinfo is signed and stored only over the NAR it describes, + -- so an upload that went wrong fails here and the next push sends + -- both again. + test "PUT narinfo with no NAR stored is 400 and stores nothing" $ + withAuthedServer $ \cfg -> do + putResp <- putServerNarInfo cfg validServerNarInfo + getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" + ok1 <- assertEqual "PUT status" HTTP.status400 (WT.simpleStatus putResp) + ok2 <- assertEqual "body" "NAR nar/test.nar is not stored; upload it before its narinfo" (strictBody putResp) + ok3 <- assertEqual "GET status" HTTP.status404 (WT.simpleStatus getResp) + pure (ok1 && ok2 && ok3), + test "PUT narinfo over a short NAR is 400 and stores nothing" $ + withAuthedServer $ \cfg -> do + (putResp, getStatus) <- putNarThenNarInfo cfg (BS.take 10 serverNarBytes) validServerNarInfo + ok1 <- assertEqual "PUT status" HTTP.status400 (WT.simpleStatus putResp) + ok2 <- assertEqual "body" "NAR nar/test.nar is 10 bytes, narinfo FileSize is 17" (strictBody putResp) + ok3 <- assertEqual "GET status" HTTP.status404 getStatus + pure (ok1 && ok2 && ok3), + test "PUT narinfo over a same-size NAR of other content is 400 and stores nothing" $ + withAuthedServer $ \cfg -> do + let other = BS.map (+ 1) serverNarBytes + (putResp, getStatus) <- putNarThenNarInfo cfg other validServerNarInfo + let expected = + "NAR nar/test.nar hashes to " + <> TE.encodeUtf8 (Hash.formatNixHash (Hash.hashBytes other)) + <> ", narinfo FileHash is " + <> TE.encodeUtf8 (Hash.formatNixHash (Hash.hashBytes serverNarBytes)) + ok1 <- assertEqual "PUT status" HTTP.status400 (WT.simpleStatus putResp) + ok2 <- assertEqual "body" expected (strictBody putResp) + ok3 <- assertEqual "GET status" HTTP.status404 getStatus + pure (ok1 && ok2 && ok3), + test "PUT narinfo over its NAR is 200 and stores it" $ + withAuthedServer $ \cfg -> do + (putResp, getStatus) <- putNarThenNarInfo cfg serverNarBytes validServerNarInfo + ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) + ok2 <- assertEqual "GET status" HTTP.status200 getStatus + pure (ok1 && ok2), + test "a refused narinfo is accepted once the right NAR is uploaded again" $ + withAuthedServer $ \cfg -> do + (refused, _) <- putNarThenNarInfo cfg (BS.take 10 serverNarBytes) validServerNarInfo + (accepted, getStatus) <- putNarThenNarInfo cfg serverNarBytes validServerNarInfo + ok1 <- assertEqual "first PUT status" HTTP.status400 (WT.simpleStatus refused) + ok2 <- assertEqual "second PUT status" HTTP.status200 (WT.simpleStatus accepted) + ok3 <- assertEqual "GET status" HTTP.status200 getStatus + pure (ok1 && ok2 && ok3), + test "PUT narinfo whose URL is not under nar/ is 400" $ + withAuthedServer $ \cfg -> do + let elsewhere = validServerNarInfo {NarInfo.niUrl = "https://cache.example/nar/" <> serverNarName} + (putResp, getStatus) <- putNarThenNarInfo cfg serverNarBytes elsewhere + ok1 <- assertEqual "PUT status" HTTP.status400 (WT.simpleStatus putResp) + ok2 <- assertEqual "body" "narinfo URL https://cache.example/nar/test.nar does not name a file under nar/" (strictBody putResp) + ok3 <- assertEqual "GET status" HTTP.status404 getStatus + pure (ok1 && ok2 && ok3), + test "PUT narinfo without FileSize or FileHash is 400" $ + withAuthedServer $ \cfg -> do + (noSize, _) <- putNarThenNarInfo cfg serverNarBytes validServerNarInfo {NarInfo.niFileSize = Nothing} + (noHash, getStatus) <- putNarThenNarInfo cfg serverNarBytes validServerNarInfo {NarInfo.niFileHash = Nothing} + ok1 <- assertEqual "no FileSize" (HTTP.status400, "narinfo declares no FileSize to check its NAR against") (WT.simpleStatus noSize, strictBody noSize) + ok2 <- assertEqual "no FileHash" (HTTP.status400, "narinfo declares no FileHash to check its NAR against") (WT.simpleStatus noHash, strictBody noHash) + ok3 <- assertEqual "GET status" HTTP.status404 getStatus + pure (ok1 && ok2 && ok3), + test "PUT narinfo over an unreadable NAR is 500 and stores nothing" $ + withAuthedServer $ \cfg -> do + _ <- putServerNar cfg serverNarBytes + unreadable <- makeUnreadable (Store.fsRoot (Server.scStore cfg) ++ "/nar/" ++ T.unpack serverNarName) + if not unreadable + then pure True + else do + putResp <- putServerNarInfo cfg validServerNarInfo + getResp <- serverRequest cfg "GET" [validNarInfoHashKey <> ".narinfo"] [] "" + ok1 <- assertEqual "PUT status" HTTP.status500 (WT.simpleStatus putResp) + ok2 <- assertEqual "body" "NAR nar/test.nar could not be read" (strictBody putResp) + ok3 <- assertEqual "GET status" HTTP.status404 (WT.simpleStatus getResp) + pure (ok1 && ok2 && ok3), -- The hash listing is push-tool plumbing: authenticated, uncacheable. test "GET /narinfo-hashes without auth is 401" $ withAuthedServer $ \cfg -> do @@ -1777,6 +2143,7 @@ assertEqual "status" HTTP.status401 (WT.simpleStatus resp), test "GET /narinfo-hashes with auth lists hashes, uncacheable" $ withAuthedServer $ \cfg -> do + _ <- putServerNar cfg serverNarBytes putResp <- serverRequest cfg "PUT" [validNarInfoHashKey <> ".narinfo"] [serverAuthHeader] validServerNarInfoBytes resp <- serverRequest cfg "GET" ["narinfo-hashes"] [serverAuthHeader] "" ok1 <- assertEqual "PUT status" HTTP.status200 (WT.simpleStatus putResp) @@ -1863,6 +2230,119 @@ removeDirectoryRecursive tmpDir assertEqual "path" Nothing located ] + +-- --------------------------------------------------------------------------- +-- Stored NAR check (pure) +-- --------------------------------------------------------------------------- + +testStoredNarCheck :: IO Bool +testStoredNarCheck = + runGroup + "Stored NAR check" + [ test "a narinfo URL resolves to the file its GET is routed to" $ + let cases = + [ ("nar/1w1fff338fvdw53sqgamddn1b2xgds473pv6y13gizdbqjv4i5p3.nar.zst", Just "1w1fff338fvdw53sqgamddn1b2xgds473pv6y13gizdbqjv4i5p3.nar.zst"), + ("nar/a%2Bb.nar", Just "a+b.nar"), + ("nar/x.nar?v=1", Just "x.nar"), + ("/nar/x.nar", Nothing), + ("https://cache.example/nar/x.nar", Nothing), + ("nar/../x.nar", Nothing), + ("nar/a/x.nar", Nothing), + ("x.nar", Nothing) + ] + in assertEqual + "mismatches" + [] + [(url, expected, actual) | (url, expected) <- cases, let actual = Server.narUrlFileName url, actual /= expected], + test "property: a NAR's request path, as a narinfo URL, resolves to its name" $ + checkProperty $ + forAll (T.pack <$> arbitrary) $ \name -> + Server.narUrlFileName (relativeRequestPath ["nar", name]) === Just name, + test "property: a nar/ URL claims that name, FileSize and FileHash" $ + checkProperty $ + forAll genClaim $ \claim -> + Server.narClaim (claimingNarInfo claim) === Right claim, + test "a narinfo with no FileSize, no usable FileHash or no served URL claims nothing" $ do + let refusal ni = either Just (const Nothing) (Server.narClaim ni) + withUrl url = validServerNarInfo {NarInfo.niUrl = url} + ok1 <- assertEqual "no FileSize" (Just Server.NarFileSizeUndeclared) (refusal validServerNarInfo {NarInfo.niFileSize = Nothing}) + ok2 <- assertEqual "no FileHash" (Just Server.NarFileHashUndeclared) (refusal validServerNarInfo {NarInfo.niFileHash = Nothing}) + ok3 <- + assertTrue + "unparseable FileHash" + ( case refusal validServerNarInfo {NarInfo.niFileHash = Just "sha256:abc"} of + Just (Server.NarFileHashInvalid "sha256:abc" _) -> True + _ -> False + ) + ok4 <- + assertEqual + "names no store could hold" + [Just (Server.NarUrlNotServed url) | url <- unservedUrls] + (map (refusal . withUrl) unservedUrls) + pure (ok1 && ok2 && ok3 && ok4), + test "property: a stored NAR is accepted exactly when it is the declared file" $ + checkProperty $ + forAll genClaim $ \claim -> + forAll (genStoredNear claim) $ \stored -> + isRight (Server.judgeStoredNar claim (Just stored)) + === (stored == Server.StoredNar (Server.ncFileSize claim) (Server.ncFileHash claim)), + test "property: a NAR of another size is refused on its size" $ + checkProperty $ + forAll genClaim $ \claim -> + forAll (genFileSize `suchThat` (/= Server.ncFileSize claim)) $ \size -> + forAll genNixHash $ \digest -> + Server.judgeStoredNar claim (Just (Server.StoredNar size digest)) + === Left (Server.NarSizeMismatch (Server.ncFileName claim) (Server.ncFileSize claim) size), + test "property: a same-size NAR of other content is refused on its hash" $ + checkProperty $ + forAll genClaim $ \claim -> + forAll (genNixHash `suchThat` (/= Server.ncFileHash claim)) $ \digest -> + Server.judgeStoredNar claim (Just (Server.StoredNar (Server.ncFileSize claim) digest)) + === Left (Server.NarHashMismatch (Server.ncFileName claim) (Server.ncFileHash claim) digest), + test "property: an absent NAR is refused as not stored" $ + checkProperty $ + forAll genClaim $ \claim -> + Server.judgeStoredNar claim Nothing === Left (Server.NarNotStored (Server.ncFileName claim)) + ] + +-- | URLs that name nothing under @nar\/@ a store could hold: an empty +-- name, an upload's temp-file name, and a Windows device. +unservedUrls :: [Text] +unservedUrls = ["nar/", "nar/.nova123-4.tmp", "nar/nul"] + +-- | The request path a client forms for segments, relative to the cache +-- root and percent-encoded as http-types encodes a path. +relativeRequestPath :: [Text] -> Text +relativeRequestPath = + TE.decodeLatin1 . BL.toStrict . Builder.toLazyByteString . HTTP.encodePathSegmentsRelative + +-- | 'validServerNarInfo' declaring a claim's name, FileSize and FileHash. +claimingNarInfo :: Server.NarClaim -> NarInfo.NarInfo +claimingNarInfo claim = + validServerNarInfo + { NarInfo.niUrl = "nar/" <> Server.ncFileName claim, + NarInfo.niFileSize = Just (Server.ncFileSize claim), + NarInfo.niFileHash = Just (Hash.formatNixHash (Server.ncFileHash claim)) + } + +-- | A FileSize the narinfo parser admits: up to the uint64 maximum. +genFileSize :: Gen Integer +genFileSize = choose (0, 18446744073709551615) + +genNixHash :: Gen Hash.NixHash +genNixHash = Hash.NixHash . BS.pack <$> vectorOf 32 arbitrary + +genClaim :: Gen Server.NarClaim +genClaim = Server.NarClaim <$> genSafeNarName <*> genFileSize <*> genNixHash + +-- | A stored NAR that keeps or replaces each of the claim's size and +-- hash independently, so the exact file turns up about a quarter of +-- the time. +genStoredNear :: Server.NarClaim -> Gen Server.StoredNar +genStoredNear claim = + Server.StoredNar + <$> oneof [pure (Server.ncFileSize claim), genFileSize] + <*> oneof [pure (Server.ncFileHash claim), genNixHash] -- --------------------------------------------------------------------------- -- Helpers