Lock.hs

-- | Per-store-path locking: mutual exclusion across delete, materialize,
-- and register.
--
-- == Why store paths lock
--
-- Two processes sharing a store can interleave substitution of one path:
-- process A removes the stale destination, process B materializes and
-- registers, then A materializes over B's tree - a valid database row
-- pointing at deleted or torn bytes.  Upstream C++ Nix
-- (@src\/libstore\/pathlocks.cc@, and the substitution path in
-- @local-store.cc@) prevents this with an exclusive lock on a
-- @\<store-path\>.lock@ file held across the whole
-- delete-materialize-register sequence, re-checking validity under the
-- lock so a waiter adopts the winner's finished work instead of redoing
-- it.
--
-- == Why filelock, not base's file locks
--
-- The lock is taken on a raw descriptor through the @filelock@
-- library (@flock@ on POSIX, @LockFileEx@ on Windows; CC0-licensed,
-- so nothing encumbers this package's Apache-2.0 distribution).
-- Base's 'GHC.IO.Handle.Lock' cannot express this lock: GHC's handle
-- registry forbids a second in-process writable handle on one file,
-- while Linux's open-file-description locks refuse an exclusive lock
-- on a read-only descriptor, so any 'System.IO.Handle' design must
-- pick between spurious in-process open failures and @EBADF@ at lock
-- time.  @filelock@'s descriptor lives outside the registry, opened
-- write-access and created atomically; the @flock@ lock attaches to
-- the open description, so it excludes other holders in this process
-- and any other, and releases when the description closes, which also
-- covers a crashed holder.  @flock@'s guarantee is for local
-- filesystems - the store's single-machine model.
--
-- == Lock files persist
--
-- Upstream deletes a lock file once its holder finishes, which opens the
-- deleted-lock-file hazard: a waiter blocked on the old file can acquire
-- it just after deletion and then hold a lock no later process can see;
-- upstream closes the hazard by writing a marker byte before deleting
-- and having every acquirer re-check the file it locked.  Here a holder
-- never deletes its lock file: the file a waiter blocked on is always
-- the file the next holder locks, the marker dance disappears, and
-- Windows - where deleting a file another process holds open fails
-- anyway - needs no separate path.  The cost is one empty
-- @\<store-path\>.lock@ per substituted or built path left beside it in
-- the store directory; the files are inert debris, invisible to path
-- queries (only exact store-path basenames resolve).  The one deleter
-- is the collector ("Nix.Store.GC"), which removes a lock file once the
-- path it guards is no longer live, and may: it runs under the
-- exclusive store-wide lock, when no process has the store open, and
-- every per-path lock in this tool is taken by a process holding a
-- store handle, so no holder or waiter exists for the deleted file to
-- strand.
module Nix.Store.Lock
  ( -- * Held locks
    PathLock,
    acquirePathLock,
    tryAcquirePathLock,
    releasePathLock,
    withPathLock,
    withLockFile,

    -- * Directly named lock files
    LockMode (..),
    acquireLockFileWith,
    withLockFileWith,
    waitingForLockMessage,

    -- * Naming
    pathLockFilePath,
    lockFileSuffix,
    lockedPathOf,
  )
where

import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar)
import Control.Exception (bracket)
import Data.Text (Text)
import qualified Data.Text as T
import Nix.Store.Path (StoreDir, StorePath, parseStorePathBaseName, storePathToFilePath)
import System.FileLock (FileLock, SharedExclusive (..), lockFile, tryLockFile, unlockFile)
import System.IO (hPutStrLn, stderr)

-- | An exclusive lock held on one store path: the lock file's path and
-- the descriptor whose OS lock is the exclusion.  The descriptor sits
-- behind an 'MVar' so release is idempotent and thread-safe: a bracket
-- and an explicit release can both fire on one lock without a
-- double-close.
data PathLock = PathLock !FilePath !(MVar (Maybe FileLock))

-- | Identity is the lock file; the descriptor is process-local plumbing.
instance Eq PathLock where
  PathLock leftFile _ == PathLock rightFile _ = leftFile == rightFile

instance Show PathLock where
  show (PathLock lockedFile _) = "PathLock " <> show lockedFile

-- | Upstream's lock-file naming convention: the lock for a store path
-- lives beside it, under the path's own name plus this suffix.
lockFileSuffix :: FilePath
lockFileSuffix = ".lock"

-- | The lock file guarding one store path.
pathLockFilePath :: StoreDir -> StorePath -> FilePath
pathLockFilePath dir sp = storePathToFilePath dir sp <> lockFileSuffix

-- | The store path basename a lock-shaped name would guard: the name
-- with 'lockFileSuffix' stripped, provided the remainder is a
-- well-formed store basename.  Whether the file actually IS a lock file
-- still depends on the registration rows, since @flake.lock@ is a legal
-- store-path name; the delete and the collector make that call.
lockedPathOf :: Text -> Maybe Text
lockedPathOf basename = do
  stripped <- T.stripSuffix (T.pack lockFileSuffix) basename
  _ <- parseStorePathBaseName stripped
  pure stripped

-- | Take the exclusive lock on a store path, blocking until granted.
-- Blocking is upstream's behavior on a busy path lock, announced the
-- same way ('waitingForLockMessage') so a stalled substitution names
-- what it is waiting for.  The non-blocking probe runs first, so the
-- contended case announces itself before the wait begins; the lock
-- file is created if absent, atomically at the open.
acquirePathLock :: StoreDir -> StorePath -> IO PathLock
acquirePathLock dir sp = acquireLockFile (pathLockFilePath dir sp)

-- | Take the exclusive lock on a lock file named directly, blocking
-- until granted.  The raw form exists for the delete path: deletion
-- accepts basenames the current store-path name rules reject, so their
-- lock files cannot be named through 'StorePath' - yet they must be the
-- very files substituters of the same path contend on.
acquireLockFile :: FilePath -> IO PathLock
acquireLockFile lockPath = acquireLockFileWith LockExclusive (waitingForLockMessage lockPath) lockPath

-- | How a lock file is held.  Every per-path lock is exclusive; the
-- store-wide garbage-collector lock is the one shared holder, taken
-- 'LockShared' by every open store handle and 'LockExclusive' by a
-- collector (see "Nix.Store.GC").
data LockMode = LockShared | LockExclusive
  deriving (Eq, Show)

-- | Take a directly named lock file in the given mode, blocking until
-- granted.  The message is printed once, to stderr, when the lock is
-- busy and the wait begins: the collector announces itself in
-- upstream's words and a path lock in its own, so the caller supplies
-- the line.
acquireLockFileWith :: LockMode -> String -> FilePath -> IO PathLock
acquireLockFileWith mode busyMessage lockPath = do
  probe <- tryLockFile lockPath (toSharedExclusive mode)
  held <- case probe of
    Just granted -> pure granted
    Nothing -> do
      hPutStrLn stderr busyMessage
      lockFile lockPath (toSharedExclusive mode)
  heldRef <- newMVar (Just held)
  pure (PathLock lockPath heldRef)

-- | The filelock spelling of a 'LockMode'.
toSharedExclusive :: LockMode -> SharedExclusive
toSharedExclusive LockShared = Shared
toSharedExclusive LockExclusive = Exclusive

-- | Upstream's log line for a busy path lock.
waitingForLockMessage :: FilePath -> String
waitingForLockMessage lockPath = "waiting for lock on '" <> lockPath <> "'..."

-- | Take the exclusive lock only if it is free: 'Nothing' when another
-- holder - this process's or another's - already has it.
tryAcquirePathLock :: StoreDir -> StorePath -> IO (Maybe PathLock)
tryAcquirePathLock dir sp = do
  let lockPath = pathLockFilePath dir sp
  probe <- tryLockFile lockPath Exclusive
  case probe of
    Nothing -> pure Nothing
    Just granted -> do
      heldRef <- newMVar (Just granted)
      pure (Just (PathLock lockPath heldRef))

-- | Release a held lock.  Closing the descriptor releases the OS lock
-- under every backend; the lock file stays - never deleted, see the
-- module header.  Idempotent: a second release finds the descriptor
-- already surrendered and does nothing.
releasePathLock :: PathLock -> IO ()
releasePathLock (PathLock _ heldRef) = modifyMVar_ heldRef surrender
  where
    surrender Nothing = pure Nothing
    surrender (Just held) = do
      unlockFile held
      pure Nothing

-- | Run an action holding a path's lock, released on every exit.
withPathLock :: StoreDir -> StorePath -> (PathLock -> IO a) -> IO a
withPathLock dir sp = bracket (acquirePathLock dir sp) releasePathLock

-- | Run an action holding a directly named lock file's lock, released
-- on every exit.  See 'acquireLockFile' for why the raw form exists.
withLockFile :: FilePath -> (PathLock -> IO a) -> IO a
withLockFile lockPath = bracket (acquireLockFile lockPath) releasePathLock

-- | 'withLockFile' in a chosen mode with a chosen busy message.
withLockFileWith :: LockMode -> String -> FilePath -> (PathLock -> IO a) -> IO a
withLockFileWith mode busyMessage lockPath =
  bracket (acquireLockFileWith mode busyMessage lockPath) releasePathLock