Store.hs

-- | Filesystem storage backend for a Nix binary cache.
--
-- Stores narinfo and NAR files in a directory tree:
--
-- @
-- \<root\>\/narinfo\/\<hash\>   -- narinfo files by store path hash
-- \<root\>\/nar\/\<filename\>   -- compressed NAR files
-- @
module NovaCache.Store
  ( FileStore (..),
    newFileStore,
    fileStoreAt,
    readNarInfo,
    writeNarInfo,
    readNar,
    writeNar,
    NarWriteResult (..),
    writeNarStreaming,
    narFilePath,
    NarRemoveResult (..),
    removeNar,
    listNarInfoHashes,
    listNarInfoFiles,
    NarFile (..),
    listNarFiles,
    CacheInfo (..),
    getCacheInfo,
    sanitizePath,
  )
where

import Control.Exception (IOException, SomeException, catch, onException, try)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.List (isPrefixOf)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (UTCTime)
import NovaCache.SafeName (hasTrailingDotOrSpace, isReservedDeviceName)
import System.Directory
  ( createDirectoryIfMissing,
    doesFileExist,
    getFileSize,
    getModificationTime,
    listDirectory,
    removeFile,
    renameFile,
  )
import System.FilePath (takeDirectory, (</>))
import System.IO (hClose, openBinaryTempFile)

-- ---------------------------------------------------------------------------
-- Types
-- ---------------------------------------------------------------------------

-- | Filesystem-backed cache store configuration.
data FileStore = FileStore
  { fsRoot :: !FilePath,
    fsStoreDir :: !Text,
    fsPriority :: !Int
  }
  deriving (Show)

-- ---------------------------------------------------------------------------
-- Constants
-- ---------------------------------------------------------------------------

-- | Subdirectory for narinfo files.
narinfoSubdir :: String
narinfoSubdir = "narinfo"

-- | Subdirectory for NAR files.
narSubdir :: String
narSubdir = "nar"

-- | Default cache priority (lower = preferred by Nix).
-- Community caches should use a higher number than cache.nixos.org (40)
-- so the official cache is preferred and we serve as a fallback.
defaultPriority :: Int
defaultPriority = 50

-- | Default Nix store directory.
defaultStoreDir :: Text
defaultStoreDir = "/nix/store"

-- | Prefix for temporary files used during atomic writes.
tempFilePrefix :: String
tempFilePrefix = ".nova.tmp"

-- ---------------------------------------------------------------------------
-- Initialization
-- ---------------------------------------------------------------------------

-- | Create a 't:FileStore' rooted at the given directory.
--
-- Ensures the @narinfo@ and @nar@ subdirectories exist.
newFileStore :: FilePath -> IO FileStore
newFileStore root = do
  createDirectoryIfMissing True (root </> narinfoSubdir)
  createDirectoryIfMissing True (root </> narSubdir)
  pure (fileStoreAt root)

-- | A 't:FileStore' over a directory tree as it stands, creating
-- nothing.  For a host tool that reads the store and acts on what it
-- finds: a mistyped root, or a store missing its @narinfo@ directory,
-- must fail the listing, not be scanned as an empty store whose every
-- NAR looks unreferenced.
fileStoreAt :: FilePath -> FileStore
fileStoreAt root =
  FileStore
    { fsRoot = root,
      fsStoreDir = defaultStoreDir,
      fsPriority = defaultPriority
    }

-- ---------------------------------------------------------------------------
-- NarInfo operations
-- ---------------------------------------------------------------------------

-- | Read a narinfo by its store path hash. Returns 'Nothing' if absent.
--
-- Returns 'Nothing' for path components containing traversal sequences.
readNarInfo :: FileStore -> Text -> IO (Maybe ByteString)
readNarInfo fs hashKey = case sanitizePath hashKey of
  Nothing -> pure Nothing
  Just safe -> readIfExists (fsRoot fs </> narinfoSubdir </> safe)

-- | Write a narinfo by its store path hash.
--
-- Uses atomic write-to-temp-then-rename so concurrent readers never
-- see partial content.
-- Returns 'False' for path components containing traversal sequences.
writeNarInfo :: FileStore -> Text -> ByteString -> IO Bool
writeNarInfo fs hashKey body = case sanitizePath hashKey of
  Nothing -> pure False
  Just safe -> atomicWriteFile (fsRoot fs </> narinfoSubdir </> safe) body >> pure True

-- ---------------------------------------------------------------------------
-- NAR operations
-- ---------------------------------------------------------------------------

-- | Read a NAR file by its filename. Returns 'Nothing' if absent.
--
-- Returns 'Nothing' for path components containing traversal sequences.
readNar :: FileStore -> Text -> IO (Maybe ByteString)
readNar fs fileName = case sanitizePath fileName of
  Nothing -> pure Nothing
  Just safe -> readIfExists (fsRoot fs </> narSubdir </> safe)

-- | Write a NAR file by its filename.
--
-- Uses atomic write-to-temp-then-rename so concurrent readers never
-- see partial content.
-- Returns 'False' for path components containing traversal sequences.
writeNar :: FileStore -> Text -> ByteString -> IO Bool
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)

-- | Outcome of removing a stored NAR.
data NarRemoveResult
  = -- | The file is gone.
    NarRemoved
  | -- | The filesystem refused; nothing was removed.
    NarRemoveFailed !IOException
  | -- | The filename failed 'sanitizePath'; nothing was touched.
    NarRemoveBadPath
  deriving (Eq, Show)

-- | Remove a stored NAR by its filename.  Nothing in the HTTP protocol
-- calls this: deletion is for a tool the host operator runs against
-- the store directory.
removeNar :: FileStore -> Text -> IO NarRemoveResult
removeNar fs fileName = case sanitizePath fileName of
  Nothing -> pure NarRemoveBadPath
  Just safe ->
    either NarRemoveFailed (const NarRemoved)
      <$> tryIO (removeFile (fsRoot fs </> narSubdir </> safe))

-- ---------------------------------------------------------------------------
-- Listing
-- ---------------------------------------------------------------------------

-- | List all narinfo hashes currently stored.
--
-- Returns the filenames in the @narinfo/@ subdirectory as 'Text' values.
-- Filters out temporary files from in-progress atomic writes.
listNarInfoHashes :: FileStore -> IO [Text]
listNarInfoHashes fs =
  map T.pack . filter (not . isHiddenEntry)
    <$> listDirectory (fsRoot fs </> narinfoSubdir)

-- | The path of every stored narinfo: the files 'listNarInfoHashes'
-- names.
listNarInfoFiles :: FileStore -> IO [FilePath]
listNarInfoFiles fs =
  map (dir </>) . filter (not . isHiddenEntry) <$> listDirectory dir
  where
    dir = fsRoot fs </> narinfoSubdir

-- | A stored NAR as listed.
data NarFile = NarFile
  { -- | The filename under @nar\/@, as @PUT \/nar\/\<file\>@ named it.
    nfName :: !Text,
    nfPath :: !FilePath,
    nfSize :: !Integer,
    nfModified :: !UTCTime
  }
  deriving (Eq, Show)

-- | Every stored NAR: the regular files under @nar\/@ whose names
-- 'sanitizePath' admits, which are exactly the names an upload can
-- create.  An upload is written to a dotfile and renamed into place
-- only once complete, and 'sanitizePath' admits no dotfile, so a
-- partial write is never listed.  The rename keeps the temp file's
-- modification time, so 'nfModified' is when the upload's last bytes
-- were written.
listNarFiles :: FileStore -> IO [NarFile]
listNarFiles fs = catMaybes <$> (traverse describe =<< listDirectory dir)
  where
    dir = fsRoot fs </> narSubdir
    describe entry = case sanitizePath (T.pack entry) of
      Nothing -> pure Nothing
      Just safe -> do
        let path = dir </> safe
        isFile <- doesFileExist path
        if isFile
          then do
            size <- getFileSize path
            modified <- getModificationTime path
            pure
              ( Just
                  NarFile
                    { nfName = T.pack safe,
                      nfPath = path,
                      nfSize = size,
                      nfModified = modified
                    }
              )
          else pure Nothing

-- ---------------------------------------------------------------------------
-- Cache metadata
-- ---------------------------------------------------------------------------

-- | Cache metadata for the @nix-cache-info@ response.
data CacheInfo = CacheInfo
  { ciStoreDir :: !Text,
    ciWantMassQuery :: !Bool,
    ciPriority :: !Int
  }
  deriving (Eq, Show)

-- | This file-backed cache answers mass-query (path-existence) requests.
defaultWantMassQuery :: Bool
defaultWantMassQuery = True

-- | Read the cache's metadata.
getCacheInfo :: FileStore -> CacheInfo
getCacheInfo fs =
  CacheInfo
    { ciStoreDir = fsStoreDir fs,
      ciWantMassQuery = defaultWantMassQuery,
      ciPriority = fsPriority fs
    }

-- ---------------------------------------------------------------------------
-- Path sanitization
-- ---------------------------------------------------------------------------

-- | 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, 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, 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
  | isReservedDeviceName keyBytes = Nothing
  | hasTrailingDotOrSpace keyBytes = Nothing
  | otherwise = Just (T.unpack txt)
  where
    -- The shared hazard predicates take the byte form NAR entry names
    -- have; a store key is ASCII by the allowlist above, so its UTF-8
    -- encoding is the same spelling.
    keyBytes = TE.encodeUtf8 txt
    isSafeChar c =
      isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-+" :: [Char])

-- ---------------------------------------------------------------------------
-- Internal
-- ---------------------------------------------------------------------------

-- | Write a file atomically via write-to-temp-then-rename.
--
-- Writes to a temporary file in the same directory, then renames to
-- the target path. On POSIX, @rename@ is atomic - readers see either
-- the old content or the new content, never a partial write.
-- Cleans up the temporary file on failure.
atomicWriteFile :: FilePath -> ByteString -> IO ()
atomicWriteFile target content = do
  let dir = takeDirectory target
  (tmpPath, h) <- openBinaryTempFile dir tempFilePrefix
  let cleanup = do
        ignoringExceptions (hClose h)
        ignoringExceptions (removeFile tmpPath)
  ( do
      BS.hPut h content
      hClose h
      renameFile tmpPath target
    )
    `onException` cleanup

-- | A dotfile: every temp file the atomic writes create (the
-- template's leading dot survives 'openBinaryTempFile'), and never a
-- key 'sanitizePath' admits.
isHiddenEntry :: FilePath -> Bool
isHiddenEntry = isPrefixOf "."

-- | 'try' at 'IOException', the failure a filesystem call is expected
-- to raise; anything else (an interrupt among them) propagates.
tryIO :: IO a -> IO (Either IOException a)
tryIO = try

-- | Swallow all exceptions from a cleanup action.
ignoringExceptions :: IO () -> IO ()
ignoringExceptions action = action `catch` silenceException
  where
    silenceException :: SomeException -> IO ()
    silenceException _ = pure ()

-- | Read a file if it exists, returning 'Nothing' otherwise.
--
-- Any I/O error (bad permissions, a race with deletion, a name that slips
-- through validation) is treated as absence rather than propagating and
-- crashing the request handler.
readIfExists :: FilePath -> IO (Maybe ByteString)
readIfExists path = readExisting `catch` ignoreIOError
  where
    readExisting = do
      exists <- doesFileExist path
      if exists
        then Just <$> BS.readFile path
        else pure Nothing
    ignoreIOError :: IOException -> IO (Maybe ByteString)
    ignoreIOError _ = pure Nothing