nova-cache 0.5.0.0 → 0.6.0.0

raw patch · 12 files changed

+430/−61 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• exe/LandingPage.hs +8/−4
• exe/Main.hs +13/−3
• nova-cache.cabal +2/−1
• src/NovaCache/NAR.hs +106/−17
• src/NovaCache/NarInfo.hs +32/−14
• src/NovaCache/SafeName.hs +34/−0
• src/NovaCache/Server.hs +27/−0
• src/NovaCache/Signing.hs +15/−2
• src/NovaCache/Store.hs +8/−16
• src/NovaCache/StorePath.hs +9/−0
• test/Main.hs +164/−4

@@ -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~<N>` suffix. `serialiseFromPath` now strips the suffix on those platforms - entries are emitted under their NAR names, ordered by them - so a hacked tree reproduces its original NAR bytes; two on-disk names stripping to the same entry fail loudly. New `serialiseFromPathWith` takes the mode explicitly (`CaseHack`, `defaultCaseHack`, `caseHackSuffix` exported); on other platforms a file legitimately named with the suffix still serialises verbatim. The platform-dependent default of `serialiseFromPath` is the behavior change behind the major bump.+- **NAR entry names are checked against Windows resolution hazards.** `checkName` now also rejects a colon anywhere (drive prefix `C:evil`, alternate data stream `a:b`), Windows reserved device names (`nul`, `con`, `com1`..., matched on the portion before the first dot), and names ending in a dot or space (NTFS strips both, so the on-disk name would silently diverge from the NAR name). An extractor relying on `checkName` can no longer be steered outside its target directory or into a device by an archive entry name.+- **`sanitizePath` rejects a trailing dot.** The store-key allowlist already excluded spaces and leading dots; a trailing dot slipped through and NTFS would strip it, landing the file under a different name than the one validated. The Windows-unsafe categories now live in one shared module, `NovaCache.SafeName`, used by both the store-key and NAR entry-name guards.+- **Store-path names reject dot segments.** `parseBaseName` accepted `.`, `..`, and their `.-x` / `..-y` prefixed forms, so paths no Nix client parses could be stored and signed. The rule is upstream's: the first dash-separated component may not be `.` or `..`, while other dot-leading names (`.config-1.0`) stay valid.+- **Size fields are length-bounded before parsing.** `NarSize`/`FileSize` parsed into an unbounded `Integer` digit by digit - quadratic in the field length. Sizes are uint64 on the wire (at most 20 digits); longer fields are rejected before the parse, making its cost constant.+- **Duplicate scalar narinfo keys resolve last-wins**, matching upstream's assign-as-read parser. `Sig` remains the intentionally repeatable key.+- **The NAR executable marker must be empty.** The parser accepted any marker value where the format fixes it as the empty string; a nonempty value is now rejected, as upstream does.+- **`SecretKey` no longer derives `Show` or `Eq`.** The derived `Show` rendered the raw Ed25519 key bytes through any enclosing `Show` (config records, debug traces), and the derived `Eq` compared secret material in input-dependent time. `Show` now renders the key name and a redaction marker; `Eq` compares the bytes in constant time.+- **New `NovaCache.Server.newTTLCache`**, and the bundled server's landing page uses it: the unauthenticated root route paid a full narinfo-store scan per request to render the path-count stat; the count now refreshes at most once per minute, keeping per-request work bounded regardless of store size.+ ## 0.5.0.0 - 2026-07-12  - **Signing: fingerprints sort and deduplicate references.** C++ Nix computes and verifies narinfo fingerprints over a sorted, deduplicated store-path set; signing in the narinfo's file order produced signatures real Nix clients reject while nova-cache's own `verify` (recomputing from the same order) passed and masked the divergence. References are now sorted by basename and deduplicated before signing.

@@ -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)) 

@@ -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"

@@ -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

@@ -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~<N>@ 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

@@ -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

@@ -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

@@ -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

@@ -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 ++ " <redacted>"++-- | The name compares normally (it is public); the key bytes compare in+-- constant time - equality over secret material must not be+-- timing-dependent.+instance Eq SecretKey where+  SecretKey nameA bytesA == SecretKey nameB bytesB =+    nameA == nameB && constEq bytesA bytesB  -- | An Ed25519 public key with its key name. data PublicKey = PublicKey

@@ -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

@@ -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

@@ -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\" <redacted>" (show sk),+      test "SecretKey equality compares name and bytes" $+        let bytesA = BS.pack ([1 .. 32] ++ [33 .. 64])+            skA = Signing.SecretKey "k" bytesA+            skB = Signing.SecretKey "k" bytesA+            skC = Signing.SecretKey "k" (BS.pack (0 : [2 .. 64]))+         in do+              ok1 <- assertTrue "equal keys" (skA == skB)+              ok2 <- assertTrue "different bytes differ" (skA /= skC)+              pure (ok1 && ok2),       test "parseSecretKey valid" $         let keyBytes = BS.pack ([1 .. 32] ++ [33 .. 64])             keyB64 = TE.decodeUtf8 (B64.encode keyBytes)@@ -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"] [] ""