diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ # Changelog +## 0.5.0.0 - 2026-07-12 + +- **Signing: fingerprints sort and deduplicate references.** C++ Nix computes and verifies narinfo fingerprints over a sorted, deduplicated store-path set; signing in the narinfo's file order produced signatures real Nix clients reject while nova-cache's own `verify` (recomputing from the same order) passed and masked the divergence. References are now sorted by basename and deduplicated before signing. +- **Removed `NovaCache.Compression`, the `compression` flag, and the `lzma` dependency.** The module had no consumer, and the default-on manual flag made every Hackage install require system liblzma dev files, which plain Windows and minimal Linux machines lack - `cabal install` of downstream packages failed while CI (which pins the flag off inside the repo) stayed green. xz support returns with its first real consumer as a size-bounded decoder suitable for untrusted cache data. +- **Wire-format strictness now matches upstream Nix.** `validateNarInfo` requires the StorePath field to be absolute and references to be bare basenames (the other spellings produce narinfos real clients reject at parse time, and a bare StorePath also derived an empty store dir inside the signed fingerprint); store-path names are ASCII-only and capped at 211 characters; NAR parsing rejects backslashes in entry names (the Windows traversal vector) and nonzero string padding; and key parsing rejects an empty name or empty key material at load time instead of producing signatures no trust anchor can match. New `parseStorePathBaseName` and `parseAbsoluteStorePath` expose the per-field parsers. +- **Upstream-optional narinfo fields are now optional.** Only StorePath, URL, NarHash, and NarSize are required; `Compression` defaults to bzip2 as upstream, and `FileHash`/`FileSize` are `Maybe` (breaking record change, covered by the major bump). Valid narinfos from foreign caches no longer fail to parse over absent optional fields. +- **New `NovaCache.Server` module: the cache's HTTP protocol as a WAI `Application`.** Routing, write authentication, request-body limits, and the narinfo validation/signing pipeline move from the server executable into tested library API. Deployment branding stays out of the library: embedders supply their own root-page response, and the bundled executable carries its landing page itself. Adds `wai` and `http-types` to the library dependencies. +- **`GET /narinfo-hashes` requires the write key and is `Cache-Control: no-store`.** The listing enumerates the whole store - something the public cache protocol deliberately never offers - and lists a directory per hit; it exists only for the push tool, which already holds the write key. +- **NAR bodies no longer transit memory.** Uploads stream to a temp file under a running size cap and rename into place atomically (`NovaCache.Store.writeNarStreaming`); downloads are served from disk via WAI's `responseFile` (`NovaCache.Store.narFilePath`). A multi-GB NAR previously occupied that much RAM per request in both directions. +- **`HEAD` is answered wherever `GET` is.** Clients probing narinfo existence with `HEAD` previously got 404. +- **The server refuses to start when `CACHE_API_KEY` normalizes to empty** (BOM or whitespace only - the copy-paste artifact). An empty armed key would authenticate an empty bearer token. +- **The server refuses to start when a configured signing key fails to load.** It previously logged a warning and ran unsigned, persisting narinfos no trust anchor can verify - the same misconfiguration class the key parser now rejects, closed at the process boundary too. +- **Configurable bind host: `--host` / `HOST`.** The default stays all interfaces, so existing deployments do not silently rebind. +- The deploy workflow pins cloudflared by version and checksum instead of pulling `latest`, and builds the server on GitHub's hosted arm64 image (same Ubuntu as the production box), shipping the binary over the Access tunnel - the production host deliberately carries no compiler toolchain. +- **The sdist ships `NOTICE`.** Apache-2.0 section 4(d) asks redistributions to carry it; the file existed in the repo but not in the released tarball. +- **CI builds from the sdist in isolation**, so tree-vs-tarball divergences (files missing from the tarball, dev-only project settings) fail the pipeline instead of surfacing at install time. CI also compiles the server executable and test suites under `-Werror` on every platform. +- Dropped the server executable's unused `crypton` dependency. +- Workflows run with a read-only `GITHUB_TOKEN`. + ## 0.4.2.1 - 2026-06-12 - **Relicensed from BSD-3-Clause to Apache-2.0.** Apache adds an explicit patent grant and trademark terms, and a `NOTICE` file now carries the copyright (Novavero AI Inc.). Earlier releases on Hackage remain under their original licenses. diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -0,0 +1,6 @@ +nova-cache +Copyright 2026 Novavero AI Inc. + +This product is licensed under the Apache License, Version 2.0. +A copy of the License is provided in the LICENSE file, or at +http://www.apache.org/licenses/LICENSE-2.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@

nova-cache

The Nix binary cache protocol, in Haskell.

-

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

+

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

[![CI](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml/badge.svg)](https://github.com/Novavero-AI/nova-cache/actions/workflows/ci.yml) [![Hackage](https://img.shields.io/hackage/v/nova-cache.svg)](https://hackage.haskell.org/package/nova-cache) @@ -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` | `/.narinfo` | Fetch a narinfo | -| `GET` | `/nar/` | Fetch a NAR | +| `GET` | `/nar/` | Fetch a NAR (streamed from disk) | | `PUT` | `/.narinfo` | Upload a narinfo (authenticated, validated) | -| `PUT` | `/nar/` | Upload a NAR (authenticated) | +| `PUT` | `/nar/` | Upload a NAR (authenticated, streamed to disk) | +`HEAD` is answered wherever `GET` is. + ### Public cache A public instance runs at `cache.novavero.ai`: @@ -95,7 +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+. --- diff --git a/exe/LandingPage.hs b/exe/LandingPage.hs new file mode 100644 --- /dev/null +++ b/exe/LandingPage.hs @@ -0,0 +1,110 @@ +-- | 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, listNarInfoHashes) + +-- | Build the @GET \/@ response: the branded page around live values +-- (store-path count, store dir, signing status, public key). +landingResponse :: FileStore -> Bool -> Maybe Text -> IO Response +landingResponse store signingEnabled pubKey = do + pathCount <- length <$> listNarInfoHashes store + let body = TE.encodeUtf8 (landingHtml (getCacheInfo store) signingEnabled pubKey pathCount) + pure (responseLBS HTTP.status200 htmlHeaders (BL.fromStrict body)) + +-- | The landing page markup. Static apart from four live values; styled +-- to match novavero.ai. Nothing user-supplied is interpolated - the key +-- line is operator configuration - so no escaping is needed. +landingHtml :: CacheInfo -> Bool -> Maybe Text -> Int -> Text +landingHtml info signingEnabled pubKey pathCount = + T.unlines + [ "", + "", + "", + "", + "", + "cache.novavero.ai - Nix binary cache", + "", + " novaveroLogoSvgEscaped <> "\" />", + "", + "", + "", + "
", + "
" <> novaveroLogoSvg <> "

cache.novavero.ai

", + "

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

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

Use it

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

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

", + "

What this is

", + "

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

", + "
Novavero AI · Waterloo, Canada
", + "
", + "", + "" + ] + where + trustAnchorLine = maybe "" ("\ntrusted-public-keys = " <>) pubKey + +-- | The Novavero mark (the novavero.ai favicon), inlined so the page stays +-- a single self-contained response with no external assets. +novaveroLogoSvg :: Text +novaveroLogoSvg = + "" + <> "" + <> "" + <> "" + +-- | The same mark, URL-escaped for a data-URI favicon link. +novaveroLogoSvgEscaped :: Text +novaveroLogoSvgEscaped = + T.concatMap escapeForDataUri novaveroLogoSvg + where + escapeForDataUri c = case c of + '<' -> "%3C" + '>' -> "%3E" + '"' -> "%22" + '#' -> "%23" + other -> T.singleton other + +-- | Content-Type and caching headers for the landing page. Stats change as +-- paths are added, so it stays briefly cacheable but revalidates. +htmlHeaders :: HTTP.ResponseHeaders +htmlHeaders = + [ (HTTP.hContentType, "text/html; charset=utf-8"), + (HTTP.hCacheControl, "public, max-age=300, must-revalidate") + ] diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,36 +1,19 @@ module Main (main) where -import Control.Exception (SomeException) +import Control.Applicative ((<|>)) import Data.Bifunctor (first) -import Data.ByteArray (constEq) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromMaybe, isJust) +import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import qualified Network.HTTP.Types as HTTP -import Network.Wai - ( Application, - Request, - RequestBodyLength (..), - Response, - ResponseReceived, - getRequestBodyChunk, - pathInfo, - requestBodyLength, - requestHeaders, - requestMethod, - responseLBS, - ) +import LandingPage (landingResponse) import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger (logStdout) -import NovaCache.NarInfo (NarInfo (..), parseNarInfo, renderNarInfo) -import NovaCache.Signing (SecretKey, normalizeKeyText, parseSecretKey, renderPublicKey, sign, toPublicKey) -import NovaCache.Store (CacheInfo (..), FileStore, getCacheInfo, listNarInfoHashes, newFileStore, readNar, readNarInfo, writeNar, writeNarInfo) -import NovaCache.StorePath (defaultStoreDir, parseStorePath, storePathHashString) -import NovaCache.Validate (validateNarInfo) +import NovaCache.Server (ServerConfig (..), cacheApp, onExceptionResponse) +import NovaCache.Signing (SecretKey, normalizeKeyText, parseSecretKey, renderPublicKey, toPublicKey) +import NovaCache.Store (newFileStore) import System.Environment (getArgs, lookupEnv) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -44,10 +27,29 @@ 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" +-- | 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 +62,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 +84,34 @@ 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 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 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 +125,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 +175,3 @@ hPutStrLn stderr ("WARNING: cannot derive the public key from the signing key: " ++ err) pure Nothing Right pk -> pure (Just (renderPublicKey pk)) - --- --------------------------------------------------------------------------- --- WAI application --- --------------------------------------------------------------------------- - --- | WAI application implementing the Nix binary cache HTTP protocol. -app :: Config -> Application -app cfg req respond = case (requestMethod req, pathInfo req) of - -- GET / - human-facing landing page (the protocol lives at the other routes) - ("GET", []) -> do - pathCount <- length <$> listNarInfoHashes (cfgStore cfg) - let info = getCacheInfo (cfgStore cfg) - signingEnabled = isJust (cfgSigningKey cfg) - body = TE.encodeUtf8 (landingHtml info signingEnabled (cfgPublicKey cfg) pathCount) - respond (responseLBS HTTP.status200 htmlHeaders (BL.fromStrict body)) - -- GET /nix-cache-info - ("GET", ["nix-cache-info"]) -> - respond (responseLBS HTTP.status200 textHeaders (BL.fromStrict (renderCacheInfo (cfgStore cfg)))) - -- GET /narinfo-hashes - ("GET", ["narinfo-hashes"]) -> do - hashes <- listNarInfoHashes (cfgStore cfg) - let body = TE.encodeUtf8 (T.unlines hashes) - respond (responseLBS HTTP.status200 textHeaders (BL.fromStrict body)) - -- GET /.narinfo - ("GET", [hashNarinfo]) - | Just hashKey <- T.stripSuffix ".narinfo" hashNarinfo -> do - result <- readNarInfo (cfgStore cfg) hashKey - case result of - Just content -> - respond (responseLBS HTTP.status200 narInfoHeaders (BL.fromStrict content)) - Nothing -> - respond notFound - -- GET /nar/ - ("GET", ["nar", fileName]) -> do - result <- readNar (cfgStore cfg) fileName - case result of - Just content -> - respond (responseLBS HTTP.status200 octetHeaders (BL.fromStrict content)) - Nothing -> - respond notFound - -- PUT /.narinfo (auth required, validated) - ("PUT", [hashNarinfo]) - | Just hashKey <- T.stripSuffix ".narinfo" hashNarinfo -> - requireAuth cfg req respond $ - withLimitedBody maxNarInfoBodySize req respond $ \body -> - case decodeAndValidate body of - Left err -> do - logWarn req ("INVALID: " <> T.unpack err) - respond (badRequest err) - Right ni - | not (narInfoHashMatches hashKey ni) -> do - logWarn req "HASHMISMATCH" - respond (badRequest "narinfo StorePath hash does not match request") - | otherwise -> do - signedResult <- signNarInfo (cfgSigningKey cfg) ni - case signedResult of - Left err -> do - logWarn req ("SIGNFAIL: " <> err) - respond (responseLBS HTTP.status500 textHeaders "signing failed") - Right signed -> do - ok <- writeNarInfo (cfgStore cfg) hashKey signed - if ok - then respond (responseLBS HTTP.status200 textHeaders "ok") - else do - logWarn req "BADPATH" - respond (badRequest "invalid path") - -- PUT /nar/ (auth required) - ("PUT", ["nar", fileName]) -> - requireAuth cfg req respond $ - withLimitedBody maxNarBodySize req respond $ \body -> do - ok <- writeNar (cfgStore cfg) fileName body - if ok - then respond (responseLBS HTTP.status200 textHeaders "ok") - else do - logWarn req "BADPATH" - respond (badRequest "invalid path") - -- Fallback - _ -> - respond notFound - --- --------------------------------------------------------------------------- --- Validation pipeline --- --------------------------------------------------------------------------- - --- | Decode a raw narinfo body and validate it in a single pure pipeline. --- --- Composes UTF-8 decoding, narinfo parsing, and field validation. Returns --- the validated 'NarInfo' on success, or a user-facing error message. -decodeAndValidate :: BS.ByteString -> Either Text NarInfo -decodeAndValidate body = do - decoded <- first (const "request body is not valid UTF-8") (TE.decodeUtf8' body) - ni <- first T.pack (parseNarInfo decoded) - first (T.unlines . map (T.pack . show)) (validateNarInfo ni) - --- | Whether the narinfo's declared StorePath actually carries the requested --- hash - so an authenticated writer cannot store a narinfo describing path X --- under path Y's key (a cache-poisoning / confused-deputy shape). -narInfoHashMatches :: Text -> NarInfo -> Bool -narInfoHashMatches hashKey ni = - case parseStorePath defaultStoreDir (niStorePath ni) of - Right sp -> storePathHashString sp == hashKey - Left _ -> False - --- --------------------------------------------------------------------------- --- Request body limiting --- --------------------------------------------------------------------------- - --- | Read the request body, rejecting payloads over the given limit. --- --- A declared @Content-Length@ over the limit is rejected up front; otherwise --- (including unsized/chunked transfers) the body is read in bounded chunks with --- a running size check that aborts before exceeding the limit, so memory stays --- bounded regardless of the declared length. -readBodyLimited :: Int -> Request -> IO (Maybe BS.ByteString) -readBodyLimited limit req = case requestBodyLength req of - KnownLength len - | len > fromIntegral limit -> pure Nothing - _ -> readChunks [] 0 - where - readChunks acc total = do - chunk <- getRequestBodyChunk req - if BS.null chunk - then pure (Just (BS.concat (reverse acc))) - else - let newTotal = total + BS.length chunk - in if newTotal > limit - then pure Nothing - else readChunks (chunk : acc) newTotal - --- | Run an action with the limited request body, responding 413 if too large. -withLimitedBody :: Int -> Request -> (Response -> IO ResponseReceived) -> (BS.ByteString -> IO ResponseReceived) -> IO ResponseReceived -withLimitedBody limit req respond action = do - bodyResult <- readBodyLimited limit req - case bodyResult of - Nothing -> do - logWarn req "OVERLIMIT" - respond (responseLBS HTTP.status413 textHeaders "request body too large") - Just body -> action body - --- --------------------------------------------------------------------------- --- Auth --- --------------------------------------------------------------------------- - --- | Gate a handler behind API key authentication. --- --- If no key is configured, all writes are permitted (open mode). --- Otherwise the request must carry @Authorization: Bearer \@. --- Uses constant-time comparison to prevent timing attacks. -requireAuth :: Config -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -> IO ResponseReceived -requireAuth cfg req respond action = case cfgApiKey cfg of - Nothing -> action - Just expected -> - let provided = lookup HTTP.hAuthorization (requestHeaders req) - expectedHeader = "Bearer " <> expected - in if maybe False (constEq expectedHeader) provided - then action - else do - logWarn req "REJECTED" - respond (responseLBS HTTP.status401 textHeaders "unauthorized") - --- --------------------------------------------------------------------------- --- Signing --- --------------------------------------------------------------------------- - --- | Sign a validated 'NarInfo' if a signing key is configured. --- --- With no key, returns the unsigned rendering (intentional - the operator --- configured none). With a key, FAILS CLOSED: a signing error returns 'Left' --- so the handler refuses the write rather than persisting an unsigned narinfo --- on a cache that is supposed to sign. -signNarInfo :: Maybe SecretKey -> NarInfo -> IO (Either String BS.ByteString) -signNarInfo Nothing ni = pure (Right (renderNarInfoBytes ni)) -signNarInfo (Just sk) ni = case sign sk ni of - Left err -> do - hPutStrLn stderr ("ERROR: signNarInfo: sign failed: " ++ err) - pure (Left err) - Right sig -> - let signed = ni {niSigs = niSigs ni ++ [sig]} - in pure (Right (renderNarInfoBytes signed)) - --- | Render a 'NarInfo' to its UTF-8 encoded wire format. -renderNarInfoBytes :: NarInfo -> BS.ByteString -renderNarInfoBytes = TE.encodeUtf8 . renderNarInfo - --- --------------------------------------------------------------------------- --- Logging --- --------------------------------------------------------------------------- - --- | Log a server-side warning to stderr with request context. -logWarn :: Request -> String -> IO () -logWarn req msg = - hPutStrLn stderr $ - msg - <> " " - <> BS8.unpack (requestMethod req) - <> " /" - <> T.unpack (T.intercalate "/" (pathInfo req)) - --- --------------------------------------------------------------------------- --- Response helpers --- --------------------------------------------------------------------------- - --- | Render the nix-cache-info response body. -renderCacheInfo :: FileStore -> BS.ByteString -renderCacheInfo store = - let info = getCacheInfo store - in TE.encodeUtf8 $ - T.unlines - [ "StoreDir: " <> ciStoreDir info, - "WantMassQuery: " <> boolText (ciWantMassQuery info), - "Priority: " <> T.pack (show (ciPriority info)) - ] - --- | Render a Bool as @1@ or @0@. -boolText :: Bool -> Text -boolText True = "1" -boolText False = "0" - --- | The landing page served at @GET /@. Static apart from four live --- values (store-path count, store dir, signing status, public key); styled --- to match novavero.ai. Nothing user-supplied is interpolated - the key --- line is operator configuration - so no escaping is needed. -landingHtml :: CacheInfo -> Bool -> Maybe Text -> Int -> Text -landingHtml info signingEnabled pubKey pathCount = - T.unlines - [ "", - "", - "", - "", - "", - "cache.novavero.ai - Nix binary cache", - "", - " novaveroLogoSvgEscaped <> "\" />", - "", - "", - "", - "
", - "
" <> novaveroLogoSvg <> "

cache.novavero.ai

", - "

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

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

Use it

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

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

", - "

What this is

", - "

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

", - "
Novavero AI · Waterloo, Canada
", - "
", - "", - "" - ] - where - trustAnchorLine = maybe "" ("\ntrusted-public-keys = " <>) pubKey - --- | The Novavero mark (the novavero.ai favicon), inlined so the page stays --- a single self-contained response with no external assets. -novaveroLogoSvg :: Text -novaveroLogoSvg = - "" - <> "" - <> "" - <> "" - --- | The same mark, URL-escaped for a data-URI favicon link. -novaveroLogoSvgEscaped :: Text -novaveroLogoSvgEscaped = - T.concatMap escapeForDataUri novaveroLogoSvg - where - escapeForDataUri c = case c of - '<' -> "%3C" - '>' -> "%3E" - '"' -> "%22" - '#' -> "%23" - other -> T.singleton other - --- | Content-Type and caching headers for the landing page. Stats change as --- paths are added, so it stays briefly cacheable but revalidates. -htmlHeaders :: HTTP.ResponseHeaders -htmlHeaders = - [ (HTTP.hContentType, "text/html; charset=utf-8"), - (HTTP.hCacheControl, "public, max-age=300, must-revalidate") - ] - --- | 404 Not Found response. -notFound :: Response -notFound = responseLBS HTTP.status404 textHeaders "not found" - --- | 400 Bad Request with a text error message. -badRequest :: Text -> Response -badRequest msg = responseLBS HTTP.status400 textHeaders (BL.fromStrict (TE.encodeUtf8 msg)) - --- | Map any uncaught handler exception to a generic 500, so internal error --- detail (filesystem paths, exception text) is never leaked to clients. -onExceptionResponse :: SomeException -> Response -onExceptionResponse _ = responseLBS HTTP.status500 textHeaders "internal server error" - --- | Content-Type: text/plain headers. -textHeaders :: HTTP.ResponseHeaders -textHeaders = [(HTTP.hContentType, "text/plain")] - --- | Content-Type and caching headers for a narinfo response. --- A narinfo body is NOT immutable for a fixed key - re-uploading the same store --- path to add or rotate a signature changes it - so it is cacheable but must --- stay revalidatable (no @immutable@). -narInfoHeaders :: HTTP.ResponseHeaders -narInfoHeaders = - [ (HTTP.hContentType, "text/x-nix-narinfo"), - (HTTP.hCacheControl, "public, max-age=3600, must-revalidate") - ] - --- | Content-Type: application/octet-stream headers. --- NAR files are content-addressed (keyed by content hash) and immutable --- once written, so they are safe to cache indefinitely at the CDN edge. -octetHeaders :: HTTP.ResponseHeaders -octetHeaders = - [ (HTTP.hContentType, "application/octet-stream"), - (HTTP.hCacheControl, "public, max-age=31536000, immutable") - ] diff --git a/nova-cache.cabal b/nova-cache.cabal --- a/nova-cache.cabal +++ b/nova-cache.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: nova-cache -version: 0.4.2.1 +version: 0.5.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,15 +35,12 @@ NovaCache.Hash NovaCache.NAR NovaCache.NarInfo + 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 @@ -56,9 +49,11 @@ , crypton >= 1.1 && < 2 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 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 +72,7 @@ buildable: False main-is: Main.hs + other-modules: LandingPage hs-source-dirs: exe default-language: Haskell2010 default-extensions: @@ -86,9 +82,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 +104,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 diff --git a/src/NovaCache/Compression.hs b/src/NovaCache/Compression.hs deleted file mode 100644 --- a/src/NovaCache/Compression.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | xz compression and decompression for NAR files. --- --- Thin wrappers around the @lzma@ package, converting between strict --- 'ByteString' and the underlying lazy interface. -module NovaCache.Compression - ( compressXz, - decompressXz, - ) -where - -import qualified Codec.Compression.Lzma as Lzma -import Control.Exception (SomeAsyncException, SomeException, evaluate, fromException, throwIO, try) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as BL - --- | Compress a strict 'ByteString' with xz. -compressXz :: ByteString -> ByteString -compressXz = BL.toStrict . Lzma.compress . BL.fromStrict - --- | Decompress an xz-compressed strict 'ByteString'. --- --- Returns 'Left' with an error message if the input is not valid xz data. -decompressXz :: ByteString -> IO (Either String ByteString) -decompressXz bs = do - result <- try (evaluate (BL.toStrict (Lzma.decompress (BL.fromStrict bs)))) - case result of - Right decompressed -> pure (Right decompressed) - -- Catch only SYNCHRONOUS failures; re-raise async exceptions (timeout, - -- ThreadKilled) so a caller's timeout/cancellation still works on this - -- untrusted-input decoder. - Left err - | Just (_ :: SomeAsyncException) <- fromException err -> throwIO err - | otherwise -> pure (Left ("xz decompression failed: " ++ show (err :: SomeException))) diff --git a/src/NovaCache/NAR.hs b/src/NovaCache/NAR.hs --- a/src/NovaCache/NAR.hs +++ b/src/NovaCache/NAR.hs @@ -254,7 +254,10 @@ -- path-traversal surface for any future NAR-extraction consumer. checkName prev name | T.null name = Left "empty NAR directory entry name" - | name == "." || name == ".." || T.any (\c -> c == '/' || c == '\0') name = + -- 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 '/'. + | name == "." || name == ".." || T.any (\c -> c == '/' || c == '\\' || c == '\0') name = Left ("unsafe NAR directory entry name: " ++ T.unpack name) | Just p <- prev, name <= p = @@ -287,12 +290,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 diff --git a/src/NovaCache/NarInfo.hs b/src/NovaCache/NarInfo.hs --- a/src/NovaCache/NarInfo.hs +++ b/src/NovaCache/NarInfo.hs @@ -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,23 +74,29 @@ -- 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) (lookupFirst 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 (lookupFirst keyCompression kvs), + niFileHash = lookupFirst keyFileHash kvs, niFileSize = fileSize, niNarHash = narHashVal, niNarSize = narSize, @@ -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) diff --git a/src/NovaCache/Server.hs b/src/NovaCache/Server.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/Server.hs @@ -0,0 +1,414 @@ +-- | The Nix binary cache HTTP protocol as a WAI 'Network.Wai.Application'. +-- +-- An IO-boundary module like "NovaCache.Store": routing, write +-- authentication, request-body limits, and the narinfo +-- validation\/signing pipeline of a cache server. Deployment identity +-- stays out of the library: the root page is supplied per deployment via +-- 'scRootResponse' ('defaultRootResponse' otherwise), so the published +-- package carries no operator branding. +-- +-- Protocol surface: +-- +-- @ +-- GET \/nix-cache-info cache metadata +-- GET \/\.narinfo narinfo by store-path hash +-- GET \/nar\/\ NAR payload (streamed from disk) +-- GET \/narinfo-hashes stored-hash listing (authenticated; push-tool plumbing) +-- PUT \/\.narinfo validated, signed, stored (authenticated) +-- PUT \/nar\/\ streamed to disk under a size cap (authenticated) +-- @ +-- +-- HEAD is answered wherever GET is: routing treats the two identically +-- and Warp elides the body while keeping the status and headers. +module NovaCache.Server + ( -- * Configuration + ServerConfig (..), + defaultRootResponse, + + -- * 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.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, + responseFile, + responseLBS, + ) +import NovaCache.NarInfo (NarInfo (..), parseNarInfo, renderNarInfo) +import NovaCache.Signing (SecretKey, sign) +import NovaCache.Store + ( CacheInfo (..), + FileStore, + NarWriteResult (..), + getCacheInfo, + listNarInfoHashes, + narFilePath, + readNarInfo, + writeNarInfo, + writeNarStreaming, + ) +import NovaCache.StorePath (defaultStoreDir, parseStorePath, storePathHashString) +import NovaCache.Validate (validateNarInfo) +import System.IO (hPutStrLn, stderr) + +-- --------------------------------------------------------------------------- +-- Constants +-- --------------------------------------------------------------------------- + +-- | Maximum narinfo request body - narinfo is small text, so a tight cap. +maxNarInfoBodySize :: Int +maxNarInfoBodySize = 4 * 1024 * 1024 -- 4 MB + +-- | Maximum NAR request body. A real store path's NAR can be very large +-- (toolchains, GHC, LLVM), so this is far higher than the narinfo cap. +-- Uploads stream to disk, so the cap bounds storage abuse, not memory. +maxNarBodySize :: Int +maxNarBodySize = 4 * 1024 * 1024 * 1024 -- 4 GB + +-- | Suffix of narinfo request paths (@\/\.narinfo@). +narInfoSuffix :: Text +narInfoSuffix = ".narinfo" + +-- --------------------------------------------------------------------------- +-- Configuration +-- --------------------------------------------------------------------------- + +-- | Server configuration: the store, the write credential, the signing +-- key, and the deployment's root page. +data ServerConfig = ServerConfig + { scStore :: !FileStore, + -- | Write API key. 'Nothing' permits unauthenticated writes (open + -- mode); arming it with an empty key is the embedder's bug to + -- prevent - an empty bearer token would then authenticate. + scApiKey :: !(Maybe ByteString), + -- | Narinfo signing key. 'Nothing' stores uploads unsigned. + scSigningKey :: !(Maybe SecretKey), + -- | Response for @GET \/@, recomputed per request so it can carry + -- live stats. Branding belongs to the embedding executable, never + -- this library. + scRootResponse :: !(IO Response) + } + +-- | Root response for embedders that do not supply a landing page: +-- enough for a human to identify the service, nothing else. +defaultRootResponse :: IO Response +defaultRootResponse = + pure (responseLBS HTTP.status200 textHeaders "nova-cache: a Nix binary cache\n") + +-- --------------------------------------------------------------------------- +-- WAI application +-- --------------------------------------------------------------------------- + +-- | WAI application implementing the Nix binary cache HTTP protocol. +cacheApp :: ServerConfig -> Application +cacheApp cfg req respond = case (routeMethod, pathInfo req) of + -- GET / - the deployment's page (protocol lives at the other routes) + ("GET", []) -> + respond =<< scRootResponse cfg + -- GET /nix-cache-info + ("GET", ["nix-cache-info"]) -> + respond (responseLBS HTTP.status200 textHeaders (BL.fromStrict (renderCacheInfo (scStore cfg)))) + -- GET /narinfo-hashes - push-tool plumbing: it enumerates the whole + -- store (something the public protocol deliberately never offers) and + -- lists a directory per hit, so it is gated behind the write key and + -- marked uncacheable. + ("GET", ["narinfo-hashes"]) -> + requireAuth cfg req respond $ do + hashes <- listNarInfoHashes (scStore cfg) + let body = TE.encodeUtf8 (T.unlines hashes) + respond (responseLBS HTTP.status200 hashListHeaders (BL.fromStrict body)) + -- GET /.narinfo + ("GET", [hashNarinfo]) + | Just hashKey <- T.stripSuffix narInfoSuffix hashNarinfo -> do + result <- readNarInfo (scStore cfg) hashKey + case result of + Just content -> + respond (responseLBS HTTP.status200 narInfoHeaders (BL.fromStrict content)) + Nothing -> + respond notFound + -- GET /nar/ - handed to the transport layer as a file so the + -- OS streams it; a multi-GB NAR never transits the Haskell heap. + ("GET", ["nar", fileName]) -> do + found <- narFilePath (scStore cfg) fileName + case found of + Just path -> + respond (responseFile HTTP.status200 octetHeaders path Nothing) + Nothing -> + respond notFound + -- PUT /.narinfo (auth required, validated) + ("PUT", [hashNarinfo]) + | Just hashKey <- T.stripSuffix narInfoSuffix hashNarinfo -> + requireAuth cfg req respond $ + withLimitedBody maxNarInfoBodySize req respond $ \body -> + case decodeAndValidate body of + Left err -> do + logWarn req ("INVALID: " <> T.unpack err) + respond (badRequest err) + Right ni + | not (narInfoHashMatches hashKey ni) -> do + logWarn req "HASHMISMATCH" + respond (badRequest "narinfo StorePath hash does not match request") + | otherwise -> do + signedResult <- signNarInfo (scSigningKey cfg) ni + case signedResult of + Left err -> do + logWarn req ("SIGNFAIL: " <> err) + respond (responseLBS HTTP.status500 textHeaders "signing failed") + Right signed -> do + ok <- writeNarInfo (scStore cfg) hashKey signed + if ok + then respond (responseLBS HTTP.status200 textHeaders "ok") + else do + logWarn req "BADPATH" + respond (badRequest "invalid path") + -- PUT /nar/ (auth required, streamed) + ("PUT", ["nar", fileName]) -> + requireAuth cfg req respond (putNar cfg req respond fileName) + -- Fallback + _ -> + respond notFound + where + -- HEAD is served as GET: the handlers build the same response and + -- Warp elides the body while keeping status, headers, and the + -- computed Content-Length. + routeMethod = + if requestMethod req == HTTP.methodHead + then HTTP.methodGet + else requestMethod req + +-- | Stream a NAR upload into the store. A declared @Content-Length@ over +-- the cap is refused before reading anything; chunked or lying transfers +-- are cut off by the store's running size check, so memory and storage +-- stay bounded either way. +putNar :: ServerConfig -> Request -> (Response -> IO ResponseReceived) -> Text -> IO ResponseReceived +putNar cfg req respond fileName = case requestBodyLength req of + KnownLength len + | len > fromIntegral maxNarBodySize -> overLimit + _ -> do + result <- writeNarStreaming (scStore cfg) fileName maxNarBodySize (getRequestBodyChunk req) + case result of + NarWriteOk -> respond (responseLBS HTTP.status200 textHeaders "ok") + NarWriteTooLarge -> overLimit + NarWriteBadPath -> do + logWarn req "BADPATH" + respond (badRequest "invalid path") + where + overLimit = do + logWarn req "OVERLIMIT" + respond (responseLBS HTTP.status413 textHeaders "request body too large") + +-- --------------------------------------------------------------------------- +-- Validation pipeline +-- --------------------------------------------------------------------------- + +-- | Decode a raw narinfo body and validate it in a single pure pipeline. +-- +-- Composes UTF-8 decoding, narinfo parsing, and field validation. Returns +-- the validated 'NarInfo' on success, or a user-facing error message. +decodeAndValidate :: ByteString -> Either Text NarInfo +decodeAndValidate body = do + decoded <- first (const "request body is not valid UTF-8") (TE.decodeUtf8' body) + ni <- first T.pack (parseNarInfo decoded) + first (T.unlines . map (T.pack . show)) (validateNarInfo ni) + +-- | Whether the narinfo's declared StorePath actually carries the requested +-- hash - so an authenticated writer cannot store a narinfo describing path X +-- under path Y's key (a cache-poisoning / confused-deputy shape). +narInfoHashMatches :: Text -> NarInfo -> Bool +narInfoHashMatches hashKey ni = + case parseStorePath defaultStoreDir (niStorePath ni) of + Right sp -> storePathHashString sp == hashKey + Left _ -> False + +-- --------------------------------------------------------------------------- +-- Request body limiting +-- --------------------------------------------------------------------------- + +-- | Read the request body, rejecting payloads over the given limit. +-- +-- A declared @Content-Length@ over the limit is rejected up front; otherwise +-- (including unsized/chunked transfers) the body is read in bounded chunks with +-- a running size check that aborts before exceeding the limit, so memory stays +-- bounded regardless of the declared length. +readBodyLimited :: Int -> Request -> IO (Maybe ByteString) +readBodyLimited limit req = case requestBodyLength req of + KnownLength len + | len > fromIntegral limit -> pure Nothing + _ -> readChunks [] 0 + where + readChunks acc total = do + chunk <- getRequestBodyChunk req + if BS.null chunk + then pure (Just (BS.concat (reverse acc))) + else + let newTotal = total + BS.length chunk + in if newTotal > limit + then pure Nothing + else readChunks (chunk : acc) newTotal + +-- | Run an action with the limited request body, responding 413 if too large. +withLimitedBody :: Int -> Request -> (Response -> IO ResponseReceived) -> (ByteString -> IO ResponseReceived) -> IO ResponseReceived +withLimitedBody limit req respond action = do + bodyResult <- readBodyLimited limit req + case bodyResult of + Nothing -> do + logWarn req "OVERLIMIT" + respond (responseLBS HTTP.status413 textHeaders "request body too large") + Just body -> action body + +-- --------------------------------------------------------------------------- +-- Auth +-- --------------------------------------------------------------------------- + +-- | Gate a handler behind API key authentication. +-- +-- If no key is configured, the action is permitted (open mode). +-- Otherwise the request must carry @Authorization: Bearer \@. +-- Uses constant-time comparison to prevent timing attacks. +requireAuth :: ServerConfig -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -> IO ResponseReceived +requireAuth cfg req respond action = case scApiKey cfg of + Nothing -> action + Just expected -> + let provided = lookup HTTP.hAuthorization (requestHeaders req) + expectedHeader = "Bearer " <> expected + in if maybe False (constEq expectedHeader) provided + then action + else do + logWarn req "REJECTED" + respond (responseLBS HTTP.status401 textHeaders "unauthorized") + +-- --------------------------------------------------------------------------- +-- Signing +-- --------------------------------------------------------------------------- + +-- | Sign a validated '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") + ] diff --git a/src/NovaCache/Signing.hs b/src/NovaCache/Signing.hs --- a/src/NovaCache/Signing.hs +++ b/src/NovaCache/Signing.hs @@ -24,6 +24,7 @@ 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 @@ -128,15 +129,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 +175,17 @@ niStorePath ni, niNarHash ni, T.pack (show (niNarSize ni)), - T.intercalate referenceSep (map (storeDir <>) (niReferences ni)) + T.intercalate referenceSep (map (storeDir <>) sortedReferences) ] where -- References in a narinfo are basenames, but the fingerprint signs them as -- full store paths (/nix/store/-), matching C++ Nix. The store -- directory is the leading path of the (already absolute) niStorePath. storeDir = T.dropWhileEnd (/= '/') (niStorePath ni) + -- C++ Nix fingerprints a StorePathSet - references sorted by basename, + -- deduplicated - so the narinfo's file order must not leak into the + -- signature: real Nix clients always verify against the sorted form. + sortedReferences = Set.toAscList (Set.fromList (niReferences ni)) -- --------------------------------------------------------------------------- -- Signing and verification diff --git a/src/NovaCache/Store.hs b/src/NovaCache/Store.hs --- a/src/NovaCache/Store.hs +++ b/src/NovaCache/Store.hs @@ -13,6 +13,9 @@ writeNarInfo, readNar, writeNar, + NarWriteResult (..), + writeNarStreaming, + narFilePath, listNarInfoHashes, CacheInfo (..), getCacheInfo, @@ -135,6 +138,56 @@ writeNar fs fileName body = case sanitizePath fileName of 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 diff --git a/src/NovaCache/StorePath.hs b/src/NovaCache/StorePath.hs --- a/src/NovaCache/StorePath.hs +++ b/src/NovaCache/StorePath.hs @@ -9,6 +9,8 @@ StorePathHash (..), StorePathName (..), parseStorePath, + parseStorePathBaseName, + parseAbsoluteStorePath, renderStorePath, storePathHashString, storePathBaseName, @@ -16,7 +18,7 @@ ) where -import Data.Char (isAlphaNum) +import Data.Char (isAlphaNum, isAscii) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -69,16 +71,22 @@ hashNameSeparator :: Char hashNameSeparator = '-' +-- | Maximum length of a store path name, as enforced by Nix. +maxNameLen :: Int +maxNameLen = 211 + -- --------------------------------------------------------------------------- -- Validation -- --------------------------------------------------------------------------- -- | Characters allowed in the name component of a store path. -- --- Alphanumeric plus @-._+?=@, matching the Nix specification. +-- ASCII alphanumeric plus @-._+?=@, matching the Nix specification. The +-- ASCII restriction matters: Nix rejects non-ASCII letters and digits, so +-- accepting them here would sign and store paths no Nix client can parse. validNameChar :: Char -> Bool validNameChar c = - isAlphaNum c + (isAscii c && isAlphaNum c) || c == '-' || c == '_' || c == '.' @@ -93,10 +101,31 @@ -- | Parse a store path from a full path or bare basename. -- -- Accepts @\/nix\/store\/\-\@ or just @\-\@. +-- Wire-format fields have a REQUIRED spelling; use 'parseStorePathBaseName' +-- (narinfo References, Deriver) or 'parseAbsoluteStorePath' (narinfo +-- StorePath) to enforce it. parseStorePath :: StoreDir -> Text -> Either String StorePath parseStorePath (StoreDir dir) txt = parseBaseName (stripDirPrefix dir txt) +-- | Parse a bare @\-\@ basename, rejecting any path separator. +-- Narinfo References and Deriver are basenames on the wire; upstream Nix +-- rejects tokens containing @\/@ outright. +parseStorePathBaseName :: Text -> Either String StorePath +parseStorePathBaseName txt + | T.any (== '/') txt = + Left ("expected a store path basename, got a path: " ++ T.unpack txt) + | otherwise = parseBaseName txt + +-- | Parse a full @\\/\-\@ path, rejecting a bare +-- basename. The narinfo StorePath field is absolute on the wire. +parseAbsoluteStorePath :: StoreDir -> Text -> Either String StorePath +parseAbsoluteStorePath (StoreDir dir) txt = + case T.stripPrefix (T.pack dir <> "/") txt of + Just basename -> parseBaseName basename + Nothing -> + Left ("expected an absolute store path under " ++ dir ++ ": " ++ T.unpack txt) + -- | Strip the store directory prefix if present. stripDirPrefix :: FilePath -> Text -> Text stripDirPrefix dir txt = @@ -115,6 +144,8 @@ 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) | not (T.all validNameChar name) = Left ("invalid characters in store path name: " ++ T.unpack name) | otherwise = diff --git a/src/NovaCache/Validate.hs b/src/NovaCache/Validate.hs --- a/src/NovaCache/Validate.hs +++ b/src/NovaCache/Validate.hs @@ -19,7 +19,7 @@ import NovaCache.Hash (formatNixHash, hashBytes, parseNixHash) import NovaCache.NarInfo (NarInfo (..)) import NovaCache.Signing (PublicKey, verify) -import NovaCache.StorePath (defaultStoreDir, parseStorePath) +import NovaCache.StorePath (defaultStoreDir, parseAbsoluteStorePath, parseStorePathBaseName) -- --------------------------------------------------------------------------- -- Types @@ -65,19 +65,26 @@ errs -> Left errs where sizeErrors = - [NegativeFileSize (niFileSize ni) | niFileSize ni < 0] + [NegativeFileSize declared | Just declared <- [niFileSize ni], declared < 0] ++ [NegativeNarSize (niNarSize ni) | niNarSize ni < 0] drvErrors = [DerivationStorePath (niStorePath ni) | ".drv" `T.isSuffixOf` niStorePath ni] - storePathErrors = case parseStorePath defaultStoreDir (niStorePath ni) of + -- The wire format fixes each field's spelling: StorePath is absolute, + -- References and Deriver are basenames. Accepting the other spelling + -- would sign narinfos (bare StorePath, absolute references) that every + -- real Nix client rejects at parse time - and a bare StorePath also + -- derives an empty store dir in the signed fingerprint. + storePathErrors = case parseAbsoluteStorePath defaultStoreDir (niStorePath ni) of Left err -> [InvalidStorePath (niStorePath ni) err] Right _ -> [] - fileHashErrors = case parseNixHash (niFileHash ni) of - Left err -> [InvalidFileHash (niFileHash ni) err] - Right _ -> [] + fileHashErrors = case niFileHash ni of + Nothing -> [] + Just declared -> case parseNixHash declared of + Left err -> [InvalidFileHash declared err] + Right _ -> [] narHashErrors = case parseNixHash (niNarHash ni) of Left err -> [InvalidNarHash (niNarHash ni) err] @@ -85,7 +92,7 @@ refErrors = concatMap checkRef (niReferences ni) - checkRef ref = case parseStorePath defaultStoreDir ref of + checkRef ref = case parseStorePathBaseName ref of Left err -> [InvalidReference ref err] Right _ -> [] @@ -97,8 +104,11 @@ -- the declared 'niNarHash'. validateNarHash :: NarInfo -> ByteString -> Either ValidationError () validateNarHash ni narBytes = - -- Compare DECODED hash bytes, not re-formatted strings, so any valid encoding - -- of the declared NarHash (SRI, hex, base32) validates against the same digest. + -- Compare DECODED hash bytes, not re-formatted strings. Only the + -- canonical sha256: spelling parses - deliberately strict, + -- since the fingerprint signs the NarHash TEXT verbatim; accepting other + -- encodings on the read side arrives with the foreign-cache substitution + -- feature that needs them. case parseNixHash (niNarHash ni) of Left err -> Left (InvalidNarHash (niNarHash ni) err) Right declared @@ -106,14 +116,17 @@ | otherwise -> Left (NarHashMismatch (niNarHash ni) (formatNixHash (hashBytes narBytes))) -- | Validate that the SHA-256 hash of compressed file bytes matches --- the declared 'niFileHash'. +-- the declared 'niFileHash'. An absent FileHash declares nothing to +-- check (upstream treats the field as optional); integrity then rests on +-- the always-required NarHash. validateFileHash :: NarInfo -> ByteString -> Either ValidationError () -validateFileHash ni fileBytes = - case parseNixHash (niFileHash ni) of - Left err -> Left (InvalidFileHash (niFileHash ni) err) +validateFileHash ni fileBytes = case niFileHash ni of + Nothing -> Right () + Just declaredText -> case parseNixHash declaredText of + Left err -> Left (InvalidFileHash declaredText err) Right declared | declared == hashBytes fileBytes -> Right () - | otherwise -> Left (FileHashMismatch (niFileHash ni) (formatNixHash (hashBytes fileBytes))) + | otherwise -> Left (FileHashMismatch declaredText (formatNixHash (hashBytes fileBytes))) -- --------------------------------------------------------------------------- -- Signature validation diff --git a/test/CompressionTest.hs b/test/CompressionTest.hs deleted file mode 100644 --- a/test/CompressionTest.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Main (main) where - -import qualified Data.ByteString as BS -import qualified NovaCache.Compression as Compression -import System.Exit (exitFailure, exitSuccess) -import System.IO (hFlush, stdout) - --- | Run a named test, short-circuit on first failure. -test :: String -> IO Bool -> IO Bool -test name action = do - putStr (" " ++ name ++ "... ") - hFlush stdout - result <- action - if result - then do - putStrLn "OK" - pure True - else do - putStrLn "FAILED" - pure False - --- | Assert equality. -assertEqual :: (Eq a, Show a) => String -> a -> a -> IO Bool -assertEqual label expected actual - | expected == actual = pure True - | otherwise = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected: " ++ show expected) - putStrLn (" actual: " ++ show actual) - pure False - --- | Assert a Bool is True. -assertTrue :: String -> Bool -> IO Bool -assertTrue _ True = pure True -assertTrue label False = do - putStrLn "" - putStrLn (" " ++ label ++ ": expected True") - pure False - --- | Assert a Right value matches. -assertRight :: (Eq a, Show a) => String -> a -> Either String a -> IO Bool -assertRight label expected (Right actual) = assertEqual label expected actual -assertRight label _ (Left err) = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected Right, got Left: " ++ err) - pure False - --- | Assert a Left (error case). -assertLeft :: (Show a) => String -> Either String a -> IO Bool -assertLeft _ (Left _) = pure True -assertLeft label (Right val) = do - putStrLn "" - putStrLn (" " ++ label) - putStrLn (" expected Left, got Right: " ++ show val) - pure False - -main :: IO () -main = do - putStrLn "nova-cache compression tests" - putStrLn "==============================" - putStrLn "" - putStrLn "Compression:" - ok1 <- - test "compress/decompress roundtrip" $ do - let input = BS.pack [72, 101, 108, 108, 111, 32, 87, 111, 114, 108, 100] - compressed = Compression.compressXz input - result <- Compression.decompressXz compressed - assertRight "roundtrip" input result - ok2 <- - test "compress/decompress roundtrip (empty)" $ do - let compressed = Compression.compressXz BS.empty - result <- Compression.decompressXz compressed - assertRight "roundtrip empty" BS.empty result - ok3 <- - test "compressed is smaller for repetitive data" $ - let input = BS.replicate 10000 0x42 - compressed = Compression.compressXz input - in assertTrue "smaller" (BS.length compressed < BS.length input) - ok4 <- - test "decompress invalid data returns Left" $ do - result <- Compression.decompressXz (BS.pack [0, 1, 2, 3]) - assertLeft "invalid xz" result - putStrLn "" - if ok1 && ok2 && ok3 && ok4 - then putStrLn "All compression tests passed." >> exitSuccess - else putStrLn "Some compression tests failed." >> exitFailure diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,23 +1,35 @@ +{-# 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) @@ -123,7 +135,8 @@ testNarInfo, testSigning, testFileStore, - testValidate + testValidate, + testServer ] -- --------------------------------------------------------------------------- @@ -162,10 +175,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")) ] -- --------------------------------------------------------------------------- @@ -311,9 +331,76 @@ 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) ] +-- | 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 +434,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 +475,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), @@ -427,6 +552,22 @@ 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)" + ( T.isSuffixOf + "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-glibc-2.40,/nix/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-zlib-1.3" + fp + ), test "parseSecretKey valid" $ let keyBytes = BS.pack ([1 .. 32] ++ [33 .. 64]) keyB64 = TE.decodeUtf8 (B64.encode keyBytes) @@ -449,6 +590,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 +690,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"], @@ -638,8 +813,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 +833,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 +862,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 +888,7 @@ test "validateNarInfo multiple errors collected" $ let ni = mkValidNarInfo - { NarInfo.niFileSize = -1, + { NarInfo.niFileSize = Just (-1), NarInfo.niNarSize = -1, NarInfo.niStorePath = "bad" } @@ -788,7 +963,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 +972,303 @@ ] -- --------------------------------------------------------------------------- +-- 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), + 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