diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Changelog +## 0.6.0.0 - 2026-07-20 + +- **NAR serialisation understands upstream's case-hack.** A case-folding store filesystem (Windows NTFS, default macOS APFS) cannot hold two sibling names differing only by case, so an extractor there materializes the collision with upstream's reversible `~nix~case~hack~` suffix. `serialiseFromPath` now strips the suffix on those platforms - entries are emitted under their NAR names, ordered by them - so a hacked tree reproduces its original NAR bytes; two on-disk names stripping to the same entry fail loudly. New `serialiseFromPathWith` takes the mode explicitly (`CaseHack`, `defaultCaseHack`, `caseHackSuffix` exported); on other platforms a file legitimately named with the suffix still serialises verbatim. The platform-dependent default of `serialiseFromPath` is the behavior change behind the major bump. +- **NAR entry names are checked against Windows resolution hazards.** `checkName` now also rejects a colon anywhere (drive prefix `C:evil`, alternate data stream `a:b`), Windows reserved device names (`nul`, `con`, `com1`..., matched on the portion before the first dot), and names ending in a dot or space (NTFS strips both, so the on-disk name would silently diverge from the NAR name). An extractor relying on `checkName` can no longer be steered outside its target directory or into a device by an archive entry name. +- **`sanitizePath` rejects a trailing dot.** The store-key allowlist already excluded spaces and leading dots; a trailing dot slipped through and NTFS would strip it, landing the file under a different name than the one validated. The Windows-unsafe categories now live in one shared module, `NovaCache.SafeName`, used by both the store-key and NAR entry-name guards. +- **Store-path names reject dot segments.** `parseBaseName` accepted `.`, `..`, and their `.-x` / `..-y` prefixed forms, so paths no Nix client parses could be stored and signed. The rule is upstream's: the first dash-separated component may not be `.` or `..`, while other dot-leading names (`.config-1.0`) stay valid. +- **Size fields are length-bounded before parsing.** `NarSize`/`FileSize` parsed into an unbounded `Integer` digit by digit - quadratic in the field length. Sizes are uint64 on the wire (at most 20 digits); longer fields are rejected before the parse, making its cost constant. +- **Duplicate scalar narinfo keys resolve last-wins**, matching upstream's assign-as-read parser. `Sig` remains the intentionally repeatable key. +- **The NAR executable marker must be empty.** The parser accepted any marker value where the format fixes it as the empty string; a nonempty value is now rejected, as upstream does. +- **`SecretKey` no longer derives `Show` or `Eq`.** The derived `Show` rendered the raw Ed25519 key bytes through any enclosing `Show` (config records, debug traces), and the derived `Eq` compared secret material in input-dependent time. `Show` now renders the key name and a redaction marker; `Eq` compares the bytes in constant time. +- **New `NovaCache.Server.newTTLCache`**, and the bundled server's landing page uses it: the unauthenticated root route paid a full narinfo-store scan per request to render the path-count stat; the count now refreshes at most once per minute, keeping per-request work bounded regardless of store size. + ## 0.5.0.0 - 2026-07-12 - **Signing: fingerprints sort and deduplicate references.** C++ Nix computes and verifies narinfo fingerprints over a sorted, deduplicated store-path set; signing in the narinfo's file order produced signatures real Nix clients reject while nova-cache's own `verify` (recomputing from the same order) passed and masked the divergence. References are now sorted by basename and deduplicated before signing. diff --git a/exe/LandingPage.hs b/exe/LandingPage.hs --- a/exe/LandingPage.hs +++ b/exe/LandingPage.hs @@ -12,13 +12,17 @@ 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) +import NovaCache.Store (CacheInfo (..), FileStore, getCacheInfo) -- | Build the @GET \/@ response: the branded page around live values -- (store-path count, store dir, signing status, public key). -landingResponse :: FileStore -> Bool -> Maybe Text -> IO Response -landingResponse store signingEnabled pubKey = do - pathCount <- length <$> listNarInfoHashes store +-- +-- The count comes from the injected action, not a store scan here: this +-- route is unauthenticated, so its per-request work must stay bounded - +-- the caller supplies a TTL-cached counter ('NovaCache.Server.newTTLCache'). +landingResponse :: IO Int -> FileStore -> Bool -> Maybe Text -> IO Response +landingResponse countPaths store signingEnabled pubKey = do + pathCount <- countPaths let body = TE.encodeUtf8 (landingHtml (getCacheInfo store) signingEnabled pubKey pathCount) pure (responseLBS HTTP.status200 htmlHeaders (BL.fromStrict body)) diff --git a/exe/Main.hs b/exe/Main.hs --- a/exe/Main.hs +++ b/exe/Main.hs @@ -11,9 +11,9 @@ import LandingPage (landingResponse) import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.RequestLogger (logStdout) -import NovaCache.Server (ServerConfig (..), cacheApp, onExceptionResponse) +import NovaCache.Server (ServerConfig (..), cacheApp, newTTLCache, onExceptionResponse) import NovaCache.Signing (SecretKey, normalizeKeyText, parseSecretKey, renderPublicKey, toPublicKey) -import NovaCache.Store (newFileStore) +import NovaCache.Store (listNarInfoHashes, newFileStore) import System.Environment (getArgs, lookupEnv) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -38,6 +38,13 @@ defaultStoreRoot :: FilePath defaultStoreRoot = "./nix-cache" +-- | How long the landing page's store-path count may serve stale, in +-- seconds. The count is a display stat; a minute of staleness is +-- invisible, and the bound keeps the unauthenticated root route at +-- constant cost regardless of request rate or store size. +pathCountTTLSeconds :: Double +pathCountTTLSeconds = 60 + -- | Environment variable for the server port. portEnvVar :: String portEnvVar = "PORT" @@ -92,13 +99,16 @@ apiKey <- loadApiKey apiKeyEnv sigKey <- loadSigningKey sigKeyPath pubKey <- derivePublicKeyLine sigKey + -- The landing page's store-path count rescans at most once per TTL; + -- the unauthenticated root route must not pay a full store scan per hit. + countPaths <- newTTLCache pathCountTTLSeconds (length <$> listNarInfoHashes store) let cfg = ServerConfig { scStore = store, scApiKey = apiKey, scSigningKey = sigKey, - scRootResponse = landingResponse store (isJust sigKey) pubKey + scRootResponse = landingResponse countPaths store (isJust sigKey) pubKey } let logRequests = logRequestsEnv /= Just "0" 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.5.0.0 +version: 0.6.0.0 synopsis: Pure-first Nix binary cache protocol library description: A pure-first library implementing the Nix binary cache protocol - @@ -35,6 +35,7 @@ NovaCache.Hash NovaCache.NAR NovaCache.NarInfo + NovaCache.SafeName NovaCache.Server NovaCache.Signing NovaCache.Store diff --git a/src/NovaCache/NAR.hs b/src/NovaCache/NAR.hs --- a/src/NovaCache/NAR.hs +++ b/src/NovaCache/NAR.hs @@ -17,6 +17,10 @@ deserialise, narHash, serialiseFromPath, + serialiseFromPathWith, + CaseHack (..), + defaultCaseHack, + caseHackSuffix, ) where @@ -32,6 +36,7 @@ import qualified Data.Text.Encoding as TE import Data.Word (Word64) import qualified NovaCache.Hash as Hash +import NovaCache.SafeName (hasTrailingDotOrSpace, isReservedDeviceName) import System.Directory ( doesDirectoryExist, doesFileExist, @@ -42,6 +47,7 @@ pathIsSymbolicLink, ) import System.FilePath (()) +import qualified System.Info -- --------------------------------------------------------------------------- -- Types @@ -197,7 +203,12 @@ where regular tok rest | tok == tokExecutable = do - (_, afterEmpty) <- readStr rest + (marker, afterEmpty) <- readStr rest + -- The format fixes the executable marker's value as the empty + -- string; upstream rejects a nonempty value. + if BS.null marker + then Right () + else Left ("executable marker must be empty, got: " ++ show marker) (cTok, afterCTok) <- readStr afterEmpty expect tokContents cTok (contents, afterContents) <- readStr afterCTok @@ -256,9 +267,19 @@ | T.null name = Left "empty NAR directory entry name" -- Backslash is a directory separator on Windows - this library's -- primary consumer - so a name like "..\out.exe" is as much a - -- traversal vector as one with '/'. - | name == "." || name == ".." || T.any (\c -> c == '/' || c == '\\' || c == '\0') name = + -- traversal vector as one with '/'. A colon is a drive prefix + -- ("C:evil") or an NTFS alternate data stream ("a:b"), either of + -- which resolves the write somewhere other than a file of this name. + | name == "." || name == ".." || T.any (\c -> c == '/' || c == '\\' || c == '\0' || c == ':') name = Left ("unsafe NAR directory entry name: " ++ T.unpack name) + -- Windows-unsafe categories, shared with the store-key allowlist + -- (NovaCache.SafeName): a device name resolves to the device, and + -- NTFS strips a trailing dot or space so the on-disk name would + -- silently diverge from the NAR name. + | isReservedDeviceName name = + Left ("Windows reserved device name as NAR directory entry: " ++ T.unpack name) + | hasTrailingDotOrSpace name = + Left ("NAR directory entry name ends with a dot or space: " ++ T.unpack name) | Just p <- prev, name <= p = Left ("NAR directory entries not strictly increasing: " ++ T.unpack name) @@ -344,32 +365,100 @@ -- Filesystem to NarEntry (IO boundary) -- --------------------------------------------------------------------------- --- | Walk a filesystem path and build a 'NarEntry'. +-- | Whether the serialiser strips upstream's case-hack suffix from +-- on-disk names. A case-folding store filesystem cannot hold two +-- sibling names differing only by case, so an extractor there +-- materializes the second with a reversible suffix; serialisation must +-- strip it for the tree to reproduce its original NAR bytes. +data CaseHack = CaseHackEnabled | CaseHackDisabled + deriving (Eq, Show) + +-- | The platform default 'serialiseFromPath' uses: enabled where the +-- store filesystem folds case (Windows NTFS, default macOS APFS), +-- disabled elsewhere - a Linux file legitimately named with the suffix +-- must serialise verbatim. Matches upstream's use-case-hack defaults. +defaultCaseHack :: CaseHack +defaultCaseHack = case System.Info.os of + "mingw32" -> CaseHackEnabled + "darwin" -> CaseHackEnabled + _ -> CaseHackDisabled + +-- | Upstream's reversible collision suffix (its @caseHackSuffix@): an +-- extractor appends @~nix~case~hack~@ to a sibling whose name +-- case-folds onto an earlier one, and serialisation strips from the +-- suffix onward to recover the NAR name. +caseHackSuffix :: Text +caseHackSuffix = "~nix~case~hack~" + +-- | Walk a filesystem path and build a 'NarEntry' under +-- 'defaultCaseHack'. -- --- This is the sole IO function in the module. It classifies each path --- as symlink, directory, or regular file, then delegates to pure --- constructors. +-- This is the module's IO boundary. It classifies each path as symlink, +-- directory, or regular file, then delegates to pure constructors. serialiseFromPath :: FilePath -> IO NarEntry -serialiseFromPath path = do +serialiseFromPath = serialiseFromPathWith defaultCaseHack + +-- | 'serialiseFromPath' with the case-hack mode explicit, for callers +-- and tests that need behavior independent of the host platform. +serialiseFromPathWith :: CaseHack -> FilePath -> IO NarEntry +serialiseFromPathWith mode path = do isSym <- pathIsSymbolicLink path if isSym then NarSymlink . T.pack <$> getSymbolicLinkTarget path else do isDir <- doesDirectoryExist path if isDir - then buildDirectory path + then buildDirectory mode path else buildRegularFile path --- | Build a directory entry by recursively walking children. -buildDirectory :: FilePath -> IO NarEntry -buildDirectory path = do +-- | Build a directory entry by recursively walking children. Under +-- 'CaseHackEnabled', each on-disk name is stripped of the case-hack +-- suffix and entries are ordered by the STRIPPED name (the NAR name); +-- two on-disk names stripping to the same entry name fail loudly, as +-- upstream's serialiser does - continuing would emit an archive with +-- duplicate entries no parser accepts. +buildDirectory :: CaseHack -> FilePath -> IO NarEntry +buildDirectory mode path = do names <- sort <$> listDirectory path - entries <- traverse walkChild names - pure (NarDirectory entries) + case unhackedDirNames mode names of + Left (first, second) -> + fail + ( "serialiseFromPath: file name collision between '" + ++ (path first) + ++ "' and '" + ++ (path second) + ++ "' after case-hack stripping" + ) + Right resolved -> do + entries <- traverse walkChild resolved + pure (NarDirectory entries) where - walkChild name = do - entry <- serialiseFromPath (path name) - pure (T.pack name, entry) + walkChild (entryName, diskName) = do + entry <- serialiseFromPathWith mode (path diskName) + pure (entryName, entry) + +-- | Resolve on-disk child names to (NAR entry name, on-disk name) pairs, +-- ordered by entry name. Under 'CaseHackDisabled' names pass through +-- verbatim (already sorted by the caller). Under 'CaseHackEnabled' the +-- case-hack suffix is stripped; @Left@ carries the first pair of disk +-- names whose stripped entry names coincide. +unhackedDirNames :: CaseHack -> [FilePath] -> Either (FilePath, FilePath) [(Text, FilePath)] +unhackedDirNames CaseHackDisabled names = Right [(T.pack name, name) | name <- names] +unhackedDirNames CaseHackEnabled names = + detectCollision (sortBy (comparing fst) (map resolve names)) + where + resolve diskName = + let (unhacked, rest) = T.breakOn caseHackSuffix (T.pack diskName) + in if T.null rest + then (T.pack diskName, diskName) + else (unhacked, diskName) + detectCollision resolved = + case [ (diskA, diskB) + | ((entryA, diskA), (entryB, diskB)) <- zip resolved (drop 1 resolved), + entryA == entryB + ] of + ((diskA, diskB) : _) -> Left (diskA, diskB) + [] -> Right resolved -- | Build a regular file entry, checking the executable bit. buildRegularFile :: FilePath -> IO NarEntry diff --git a/src/NovaCache/NarInfo.hs b/src/NovaCache/NarInfo.hs --- a/src/NovaCache/NarInfo.hs +++ b/src/NovaCache/NarInfo.hs @@ -10,7 +10,7 @@ ) where -import Data.List (find) +import Data.List (foldl') import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -88,22 +88,22 @@ let kvs = mapMaybe parseLine (T.lines txt) storePath <- require keyStorePath kvs url <- require keyUrl kvs - fileSize <- traverse (parseInteger keyFileSize) (lookupFirst keyFileSize kvs) + fileSize <- traverse (parseInteger keyFileSize) (lookupLast keyFileSize kvs) narHashVal <- require keyNarHash kvs narSize <- require keyNarSize kvs >>= parseInteger keyNarSize pure NarInfo { niStorePath = storePath, niUrl = url, - niCompression = fromMaybe defaultCompression (lookupFirst keyCompression kvs), - niFileHash = lookupFirst keyFileHash kvs, + niCompression = fromMaybe defaultCompression (lookupLast keyCompression kvs), + niFileHash = lookupLast keyFileHash kvs, niFileSize = fileSize, niNarHash = narHashVal, niNarSize = narSize, - niReferences = parseRefs (lookupFirst keyReferences kvs), - niDeriver = lookupFirst keyDeriver kvs, + niReferences = parseRefs (lookupLast keyReferences kvs), + niDeriver = lookupLast keyDeriver kvs, niSigs = lookupAll keySig kvs, - niCA = lookupFirst keyCA kvs + niCA = lookupLast keyCA kvs } -- | Parse a space-separated references field. @@ -163,8 +163,14 @@ optionalKV key (Just val) = [kv key val] -- | Look up the first occurrence of a key. -lookupFirst :: Text -> [(Text, Text)] -> Maybe Text -lookupFirst key kvs = snd <$> find ((== key) . fst) kvs +-- | Look up the LAST occurrence of a scalar key: upstream's parser +-- assigns each field as it reads, so a duplicated key resolves to the +-- final value. (@Sig@ is the one intentionally repeatable key - +-- 'lookupAll'.) +lookupLast :: Text -> [(Text, Text)] -> Maybe Text +lookupLast key = foldl' pick Nothing + where + pick acc (k, v) = if k == key then Just v else acc -- | Look up all occurrences of a key. lookupAll :: Text -> [(Text, Text)] -> [Text] @@ -172,18 +178,30 @@ -- | Require a key to be present. require :: Text -> [(Text, Text)] -> Either String Text -require key kvs = case lookupFirst key kvs of +require key kvs = case lookupLast key kvs of Nothing -> Left ("missing required key: " ++ T.unpack key) Just val -> Right val +-- | Sizes on the wire are uint64 in Nix: at most 20 digits. A longer +-- field is rejected before the bignum parse, because 'TR.decimal' +-- accumulates digit by digit - quadratic in the field length - so an +-- unbounded field costs quadratic CPU and a proportional allocation +-- before any consumer looks at the value. +maxSizeFieldDigits :: Int +maxSizeFieldDigits = 20 + -- | Parse a non-negative base-10 integer, matching C++ Nix's narinfo parser. -- Uses 'TR.decimal' (not 'reads', which also accepts hex/octal/leading space) -- and requires the whole field to be consumed, so a non-canonical value cannot --- slip through and then be re-signed under the cache's key. +-- slip through and then be re-signed under the cache's key. The length is +-- bounded first ('maxSizeFieldDigits'), so the parse cost is constant. parseInteger :: Text -> Text -> Either String Integer -parseInteger key txt = case TR.decimal txt of - Right (n, rest) | T.null rest -> Right n - _ -> Left ("invalid integer for " ++ T.unpack key ++ ": " ++ T.unpack txt) +parseInteger key txt + | T.length txt > maxSizeFieldDigits = + Left ("integer field for " ++ T.unpack key ++ " is " ++ show (T.length txt) ++ " characters, above the " ++ show maxSizeFieldDigits ++ " maximum") + | otherwise = case TR.decimal txt of + Right (n, rest) | T.null rest -> Right n + _ -> Left ("invalid integer for " ++ T.unpack key ++ ": " ++ T.unpack txt) -- | Show a value as 'Text'. showT :: (Show a) => a -> Text diff --git a/src/NovaCache/SafeName.hs b/src/NovaCache/SafeName.hs new file mode 100644 --- /dev/null +++ b/src/NovaCache/SafeName.hs @@ -0,0 +1,34 @@ +-- | Windows-unsafe name categories, shared by the store-key allowlist +-- ('NovaCache.Store.sanitizePath') and the NAR entry-name guard in +-- "NovaCache.NAR": names Windows resolves to something other than an +-- ordinary file of that exact spelling. Both guards reject the same +-- categories from one definition, so they cannot drift apart. +module NovaCache.SafeName + ( isReservedDeviceName, + hasTrailingDotOrSpace, + ) +where + +import Data.Text (Text) +import qualified Data.Text as T + +-- | Is the name a Windows reserved device (@con@, @prn@, @aux@, @nul@, +-- @com1@-@com9@, @lpt1@-@lpt9@)? Matched case-insensitively on the portion +-- before the first dot, since @nul.txt@ also opens the device. Enforced on +-- every platform so a Windows-hosted consumer is safe too. +isReservedDeviceName :: Text -> Bool +isReservedDeviceName txt = T.toLower (T.takeWhile (/= '.') txt) `elem` reservedNames + where + reservedNames = + ["con", "prn", "aux", "nul"] + ++ ["com" <> n | n <- digits] + ++ ["lpt" <> n | n <- digits] + digits = [T.pack (show n) | n <- [1 .. 9 :: Int]] + +-- | Does the name end with a dot or a space? NTFS strips both at +-- create time, so the on-disk name silently diverges from the requested +-- one and the materialized tree no longer matches what named it. +hasTrailingDotOrSpace :: Text -> Bool +hasTrailingDotOrSpace name = case T.unsnoc name of + Just (_, end) -> end == '.' || end == ' ' + Nothing -> False diff --git a/src/NovaCache/Server.hs b/src/NovaCache/Server.hs --- a/src/NovaCache/Server.hs +++ b/src/NovaCache/Server.hs @@ -24,6 +24,7 @@ ( -- * Configuration ServerConfig (..), defaultRootResponse, + newTTLCache, -- * Application cacheApp, @@ -50,9 +51,11 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BL +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import GHC.Clock (getMonotonicTime) import qualified Network.HTTP.Types as HTTP import Network.Wai ( Application, @@ -128,6 +131,30 @@ defaultRootResponse :: IO Response defaultRootResponse = pure (responseLBS HTTP.status200 textHeaders "nova-cache: a Nix binary cache\n") + +-- | Memoize an action's result for a time-to-live, in seconds +-- (monotonic clock, so wall-time jumps cannot starve the refresh). +-- +-- An unauthenticated route must do bounded work per request: a root +-- response that counts the store, for example, must not scan the whole +-- narinfo directory per hit. Wrap the expensive read once at startup +-- and hand the returned action to 'scRootResponse'. +-- +-- Concurrent requests near expiry may run the action more than once; +-- the last write wins. Acceptable for idempotent reads, which is the +-- intended use. +newTTLCache :: Double -> IO a -> IO (IO a) +newTTLCache ttlSeconds action = do + ref <- newIORef Nothing + pure $ do + now <- getMonotonicTime + cached <- readIORef ref + case cached of + Just (refreshedAt, held) | now - refreshedAt < ttlSeconds -> pure held + _ -> do + fresh <- action + writeIORef ref (Just (now, fresh)) + pure fresh -- --------------------------------------------------------------------------- -- WAI application diff --git a/src/NovaCache/Signing.hs b/src/NovaCache/Signing.hs --- a/src/NovaCache/Signing.hs +++ b/src/NovaCache/Signing.hs @@ -20,7 +20,7 @@ import Crypto.Error (CryptoFailable (..)) import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.ByteArray (convert) +import Data.ByteArray (constEq, convert) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 @@ -39,7 +39,20 @@ { skName :: !Text, skBytes :: !ByteString } - deriving (Eq, Show) + +-- | Renders the key NAME only. The secret bytes must never be +-- reachable through 'Show': any enclosing type deriving 'Show' (a +-- config record, a debug trace, an error formatter) would otherwise +-- render them. Deliberately not read-back-able. +instance Show SecretKey where + show (SecretKey keyName _) = "SecretKey " ++ show keyName ++ " " + +-- | The name compares normally (it is public); the key bytes compare in +-- constant time - equality over secret material must not be +-- timing-dependent. +instance Eq SecretKey where + SecretKey nameA bytesA == SecretKey nameB bytesB = + nameA == nameB && constEq bytesA bytesB -- | An Ed25519 public key with its key name. data PublicKey = PublicKey diff --git a/src/NovaCache/Store.hs b/src/NovaCache/Store.hs --- a/src/NovaCache/Store.hs +++ b/src/NovaCache/Store.hs @@ -29,6 +29,7 @@ import Data.Char (isAsciiLower, isAsciiUpper, isDigit) import Data.Text (Text) import qualified Data.Text as T +import NovaCache.SafeName (hasTrailingDotOrSpace, isReservedDeviceName) import System.Directory ( createDirectoryIfMissing, doesFileExist, @@ -234,34 +235,25 @@ -- | Validate a path component for safe filesystem use via a positive allowlist. -- -- Accepts only non-empty names of @[A-Za-z0-9._+-]@ that do not start with a --- dot and are not a Windows reserved device name. This rejects directory +-- dot, do not end with a dot (NTFS strips it, silently renaming the file), +-- and are not a Windows reserved device name. This rejects directory -- separators, @.@\/@..@ traversal, dotfiles (including the temp-write prefix), -- NUL bytes, alternate-data-stream (@name:stream@) syntax, and device names -- like @nul@ - so a client-supplied hash or NAR filename can never escape the --- store directory or resolve to a device, on any platform. +-- store directory, resolve to a device, or land under a different name, on +-- any platform. The Windows-specific categories are shared with the NAR +-- entry-name guard via "NovaCache.SafeName". sanitizePath :: Text -> Maybe FilePath sanitizePath txt | T.null txt = Nothing | T.isPrefixOf "." txt = Nothing | T.any (not . isSafeChar) txt = Nothing - | isReservedName txt = Nothing + | isReservedDeviceName txt = Nothing + | hasTrailingDotOrSpace txt = Nothing | otherwise = Just (T.unpack txt) where isSafeChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-+" :: [Char]) - --- | Is the name a Windows reserved device (@con@, @prn@, @aux@, @nul@, --- @com1@-@com9@, @lpt1@-@lpt9@)? Matched case-insensitively on the portion --- before the first dot, since @nul.txt@ also opens the device. Enforced on --- every platform so a Windows-hosted cache is safe too. -isReservedName :: Text -> Bool -isReservedName txt = T.toLower (T.takeWhile (/= '.') txt) `elem` reservedNames - where - reservedNames = - ["con", "prn", "aux", "nul"] - ++ ["com" <> n | n <- digits] - ++ ["lpt" <> n | n <- digits] - digits = [T.pack (show n) | n <- [1 .. 9 :: Int]] -- --------------------------------------------------------------------------- -- Internal diff --git a/src/NovaCache/StorePath.hs b/src/NovaCache/StorePath.hs --- a/src/NovaCache/StorePath.hs +++ b/src/NovaCache/StorePath.hs @@ -146,6 +146,14 @@ Left ("empty name in store path: " ++ T.unpack basename) | T.length name > maxNameLen = Left ("store path name longer than " ++ show maxNameLen ++ " characters: " ++ T.unpack name) + -- Upstream's checkName dot rule: the FIRST dash-separated component may + -- not be "." or "..", rejecting the traversal names and their ".-x" / + -- "..-y" prefixed forms alike, while other dot-leading names + -- (".config-1.0") stay valid. Same rule nova-nix enforces at its + -- construction and parse boundaries; a dot name accepted here would be + -- stored and signed although no Nix client parses it. + | firstDashComponent == "." || firstDashComponent == ".." = + Left ("store path name may not begin with a dot segment: " ++ T.unpack name) | not (T.all validNameChar name) = Left ("invalid characters in store path name: " ++ T.unpack name) | otherwise = @@ -153,6 +161,7 @@ where hashPart = T.take storePathHashLen basename name = T.drop minBaseNameLen basename + firstDashComponent = T.takeWhile (/= '-') name -- --------------------------------------------------------------------------- -- Rendering diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -262,7 +262,24 @@ test "reject invalid name chars" $ let storeDir = StorePath.defaultStoreDir input = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-hello world" - in assertLeft "invalid chars" (StorePath.parseStorePath storeDir input) + in assertLeft "invalid chars" (StorePath.parseStorePath storeDir input), + -- Upstream's dot rule: the first dash-separated component may not + -- be "." or ".."; other dot-leading names stay valid. + test "reject dot-segment names" $ + let hash = T.replicate 32 "a" + rejected name = assertLeft (T.unpack name) (StorePath.parseStorePathBaseName (hash <> "-" <> name)) + in do + ok1 <- rejected "." + ok2 <- rejected ".." + ok3 <- rejected ".-x" + ok4 <- rejected "..-y" + pure (ok1 && ok2 && ok3 && ok4), + test "dotfile-style names stay valid" $ + let hash = T.replicate 32 "a" + in do + ok1 <- assertTrue "dotfile" (either (const False) (const True) (StorePath.parseStorePathBaseName (hash <> "-.config-1.0"))) + ok2 <- assertTrue "interior dots" (either (const False) (const True) (StorePath.parseStorePathBaseName (hash <> "-x.y.z"))) + pure (ok1 && ok2) ] -- --------------------------------------------------------------------------- @@ -363,9 +380,73 @@ 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) + assertLeft "nonzero padding" (NAR.deserialise badPaddingNar), + -- The format fixes the executable marker's value as empty; upstream + -- rejects a nonempty value, and NAR.serialise cannot produce one. + test "nonempty executable marker rejected" $ + let marked = + BS.concat + ( map + (narWireStr 0) + ["nix-archive-1", "(", "type", "regular", "executable", "X", "contents", "hi", ")"] + ) + in assertLeft "nonempty marker" (NAR.deserialise marked), + -- Windows resolves these names to something other than a file of + -- this spelling (drive/stream colon, device, NTFS dot/space strip). + test "Windows-hazard entry names rejected" $ + let evil name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")]) + names = ["C:evil", "a:b", "nul", "NUL", "com1", "nul.txt", "foo.", "foo "] + rejected bytes = either (const True) (const False) (NAR.deserialise bytes) + in assertTrue "all hazard names rejected" (all (rejected . evil) names), + test "near-miss names still parse" $ + let plain name = NAR.serialise (NAR.NarDirectory [(name, NAR.NarRegular False "x")]) + names = ["nul2", "com10", "conx", "foo.bar", "a.b.c", "lpt0"] + accepted bytes = either (const False) (const True) (NAR.deserialise bytes) + in assertTrue "all near-miss names accepted" (all (accepted . plain) names), + -- The case-hack strip: a tree materialized with upstream's + -- collision suffix serialises back under its NAR names. + test "serialiseFromPathWith strips the case-hack suffix" $ do + dir <- caseHackFixture "nova-cache-test-casehack" + BS.writeFile (dir <> "/Foo") "upper" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "lower" + entry <- NAR.serialiseFromPathWith NAR.CaseHackEnabled dir + removeDirectoryRecursive dir + let expected = + NAR.NarDirectory + [ ("Foo", NAR.NarRegular False "upper"), + ("foo", NAR.NarRegular False "lower") + ] + roundTrip <- assertRight "stripped tree reparses" expected (NAR.deserialise (NAR.serialise entry)) + pure (entry == expected && roundTrip), + test "serialiseFromPathWith keeps the suffix verbatim when disabled" $ do + dir <- caseHackFixture "nova-cache-test-casehack-off" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "kept" + entry <- NAR.serialiseFromPathWith NAR.CaseHackDisabled dir + removeDirectoryRecursive dir + assertEqual + "verbatim name" + (NAR.NarDirectory [("foo~nix~case~hack~1", NAR.NarRegular False "kept")]) + entry, + test "serialiseFromPathWith fails loudly on an unhack collision" $ do + dir <- caseHackFixture "nova-cache-test-casehack-clash" + BS.writeFile (dir <> "/foo") "plain" + BS.writeFile (dir <> "/foo~nix~case~hack~1") "hacked" + outcome <- try (NAR.serialiseFromPathWith NAR.CaseHackEnabled dir) + removeDirectoryRecursive dir + pure $ case (outcome :: Either SomeException NAR.NarEntry) of + Left _ -> True + Right _ -> False ] +-- | A fresh, empty fixture directory under the system temp dir. +caseHackFixture :: String -> IO FilePath +caseHackFixture name = do + tmpBase <- getTemporaryDirectory + let dir = tmpBase <> "/" <> name + _ <- try (removeDirectoryRecursive dir) :: IO (Either SomeException ()) + createDirectory dir + pure dir + -- | Encode one NAR wire string with a chosen padding byte. The spec -- demands zero padding, so a nonzero byte builds archives the parser -- must reject - and 'NAR.serialise' (rightly) cannot produce them. @@ -528,7 +609,52 @@ "NarSize: 200", "References: " ] - in assertLeft "bad integer" (NarInfo.parseNarInfo bad) + in assertLeft "bad integer" (NarInfo.parseNarInfo bad), + -- Sizes are uint64 on the wire: at most 20 digits. A longer field + -- rejects before the quadratic bignum accumulation. + test "parse rejects an overlong size field" $ + let long = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "NarHash: sha256:def", + "NarSize: 123456789012345678901" + ] + in assertLeft "overlong size" (NarInfo.parseNarInfo long), + test "a 20-digit size field still parses" $ + let capped = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/test.nar.xz", + "NarHash: sha256:def", + "NarSize: 18446744073709551615" + ] + in case NarInfo.parseNarInfo capped of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> assertEqual "uint64 max" 18446744073709551615 (NarInfo.niNarSize ni), + -- Upstream assigns fields as it reads, so a duplicated scalar key + -- resolves to the LAST value (Sig stays the repeatable exception). + test "duplicate scalar keys resolve last-wins" $ + let dup = + T.unlines + [ "StorePath: /nix/store/aaaa-test", + "URL: nar/first.nar", + "URL: nar/last.nar", + "Compression: xz", + "Compression: zstd", + "NarHash: sha256:def", + "NarSize: 200" + ] + in case NarInfo.parseNarInfo dup of + Left err -> do + putStrLn (" parse failed: " ++ err) + pure False + Right ni -> do + ok1 <- assertEqual "url last" "nar/last.nar" (NarInfo.niUrl ni) + ok2 <- assertEqual "compression last" "zstd" (NarInfo.niCompression ni) + pure (ok1 && ok2) ] -- --------------------------------------------------------------------------- @@ -564,10 +690,26 @@ fp = Signing.fingerprint ni in assertTrue "references sorted by basename and deduplicated (C++ Nix parity)" + -- The leading field separator pins the WHOLE references + -- field: without it, the pre-fix "zlib,glibc,zlib" + -- rendering also ends in "...glibc...,...zlib..." and the + -- assertion cannot fail on a regression to unsorted output. ( T.isSuffixOf - "/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-glibc-2.40,/nix/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-zlib-1.3" + ";/nix/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-glibc-2.40,/nix/store/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-zlib-1.3" fp ), + test "SecretKey Show redacts the key bytes" $ + let sk = Signing.SecretKey {Signing.skName = "test-key", Signing.skBytes = BS.pack ([1 .. 32] ++ [33 .. 64])} + in assertEqual "redacted" "SecretKey \"test-key\" " (show sk), + test "SecretKey equality compares name and bytes" $ + let bytesA = BS.pack ([1 .. 32] ++ [33 .. 64]) + skA = Signing.SecretKey "k" bytesA + skB = Signing.SecretKey "k" bytesA + skC = Signing.SecretKey "k" (BS.pack (0 : [2 .. 64])) + in do + ok1 <- assertTrue "equal keys" (skA == skB) + ok2 <- assertTrue "different bytes differ" (skA /= skC) + pure (ok1 && ok2), test "parseSecretKey valid" $ let keyBytes = BS.pack ([1 .. 32] ++ [33 .. 64]) keyB64 = TE.decodeUtf8 (B64.encode keyBytes) @@ -759,6 +901,10 @@ assertEqual "device nul" Nothing (Store.sanitizePath "nul"), test "sanitizePath rejects dotfile" $ assertEqual "dotfile" Nothing (Store.sanitizePath ".hidden"), + test "sanitizePath rejects a trailing dot" $ + assertEqual "trailing dot" Nothing (Store.sanitizePath "foo."), + test "sanitizePath keeps interior dots valid" $ + assertEqual "interior dots" (Just "foo.nar.xz") (Store.sanitizePath "foo.nar.xz"), test "read rejects traversal" $ do tmpDir <- createTestDir store <- Store.newFileStore tmpDir @@ -1085,6 +1231,20 @@ ok1 <- assertEqual "status" HTTP.status200 (WT.simpleStatus resp) ok2 <- assertEqual "body" "nova-cache: a Nix binary cache\n" (WT.simpleBody resp) pure (ok1 && ok2), + -- newTTLCache: within the TTL the action runs once; a zero TTL + -- never satisfies the freshness check, so every call re-runs. + test "newTTLCache memoizes within the TTL and re-runs past it" $ do + counter <- newIORef (0 :: Int) + let bump = atomicModifyIORef' counter (\n -> (n + 1, n + 1)) + cachedHour <- Server.newTTLCache 3600 bump + firstRead <- cachedHour + secondRead <- cachedHour + cachedNever <- Server.newTTLCache 0 bump + thirdRead <- cachedNever + fourthRead <- cachedNever + ok1 <- assertEqual "memoized" (1, 1) (firstRead, secondRead) + ok2 <- assertEqual "re-run each call" (2, 3) (thirdRead, fourthRead) + pure (ok1 && ok2), test "GET /nix-cache-info renders cache metadata" $ withServer Nothing Nothing $ \cfg -> do resp <- serverRequest cfg "GET" ["nix-cache-info"] [] ""