{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- | Management for the installed package store.
module Distribution.Client.Store
  ( -- * The store layout
    StoreDirLayout (..)
  , defaultStoreDirLayout

    -- * Reading store entries
  , getStoreEntries
  , doesStoreEntryExist

    -- * Creating store entries
  , newStoreEntry
  , NewStoreEntryOutcome (..)

    -- * Concurrency strategy
    -- $concurrency
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.DistDirLayout
import Distribution.Client.RebuildMonad

import Distribution.Package (UnitId, mkUnitId)
import Distribution.Simple.Compiler (Compiler (..))

import Distribution.Simple.Utils
  ( debug
  , info
  , withTempDirectory
  )
import Distribution.Verbosity
  ( silent
  )

import Control.Exception
import qualified Data.Set as Set
import System.Directory
import System.FilePath

#ifdef MIN_VERSION_lukko
import Lukko
#else
import System.IO (openFile, IOMode(ReadWriteMode), hClose)
import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock)
#endif

-- $concurrency
--
-- We access and update the store concurrently. Our strategy to do that safely
-- is as follows.
--
-- The store entries once created are immutable. This alone simplifies matters
-- considerably.
--
-- Additionally, the way 'UnitId' hashes are constructed means that if a store
-- entry exists already then we can assume its content is ok to reuse, rather
-- than having to re-recreate. This is the nix-style input hashing concept.
--
-- A consequence of this is that with a little care it is /safe/ to race
-- updates against each other. Consider two independent concurrent builds that
-- both want to build a particular 'UnitId', where that entry does not yet
-- exist in the store. It is safe for both to build and try to install this
-- entry into the store provided that:
--
-- * only one succeeds
-- * the looser discovers that they lost, they abandon their own build and
--   re-use the store entry installed by the winner.
--
-- Note that because builds are not reproducible in general (nor even
-- necessarily ABI compatible) then it is essential that the loser abandon
-- their build and use the one installed by the winner, so that subsequent
-- packages are built against the exact package from the store rather than some
-- morally equivalent package that may not be ABI compatible.
--
-- Our overriding goal is that store reads be simple, cheap and not require
-- locking. We will derive our write-side protocol to make this possible.
--
-- The read-side protocol is simply:
--
-- * check for the existence of a directory entry named after the 'UnitId' in
--   question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then
--   the store entry can be assumed to be complete and immutable.
--
-- Given our read-side protocol, the final step on the write side must be to
-- atomically rename a fully-formed store entry directory into its final
-- location. While this will indeed be the final step, the preparatory steps
-- are more complicated. The tricky aspect is that the store also contains a
-- number of shared package databases (one per compiler version). Our read
-- strategy means that by the time we install the store dir entry the package
-- db must already have been updated. We cannot do the package db update
-- as part of atomically renaming the store entry directory however. Furthermore
-- it is not safe to allow either package db update because the db entry
-- contains the ABI hash and this is not guaranteed to be deterministic. So we
-- must register the new package prior to the atomic dir rename. Since this
-- combination of steps are not atomic then we need locking.
--
-- The write-side protocol is:
--
-- * Create a unique temp dir and write all store entry files into it.
--
-- * Take a lock named after the 'UnitId' in question.
--
-- * Once holding the lock, check again for the existence of the final store
--   entry directory. If the entry exists then the process lost the race and it
--   must abandon, unlock and re-use the existing store entry. If the entry
--   does not exist then the process won the race and it can proceed.
--
-- * Register the package into the package db. Note that the files are not in
--   their final location at this stage so registration file checks may need
--   to be disabled.
--
-- * Atomically rename the temp dir to the final store entry location.
--
-- * Release the previously-acquired lock.
--
-- Obviously this means it is possible to fail after registering but before
-- installing the store entry, leaving a dangling package db entry. This is not
-- much of a problem because this entry does not determine package existence
-- for cabal. It does mean however that the package db update should be insert
-- or replace, i.e. not failing if the db entry already exists.

-- | Check if a particular 'UnitId' exists in the store.
doesStoreEntryExist :: StoreDirLayout -> Compiler -> UnitId -> IO Bool
doesStoreEntryExist :: StoreDirLayout -> Compiler -> UnitId -> IO Bool
doesStoreEntryExist StoreDirLayout{Compiler -> UnitId -> FilePath
storePackageDirectory :: Compiler -> UnitId -> FilePath
storePackageDirectory :: StoreDirLayout -> Compiler -> UnitId -> FilePath
storePackageDirectory} Compiler
compiler UnitId
unitid =
  FilePath -> IO Bool
doesDirectoryExist (Compiler -> UnitId -> FilePath
storePackageDirectory Compiler
compiler UnitId
unitid)

-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
getStoreEntries :: StoreDirLayout -> Compiler -> Rebuild (Set UnitId)
getStoreEntries :: StoreDirLayout -> Compiler -> Rebuild (Set UnitId)
getStoreEntries StoreDirLayout{Compiler -> FilePath
storeDirectory :: Compiler -> FilePath
storeDirectory :: StoreDirLayout -> Compiler -> FilePath
storeDirectory} Compiler
compiler = do
  [FilePath]
paths <- FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored (Compiler -> FilePath
storeDirectory Compiler
compiler)
  Set UnitId -> Rebuild (Set UnitId)
forall a. a -> Rebuild a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set UnitId -> Rebuild (Set UnitId))
-> Set UnitId -> Rebuild (Set UnitId)
forall a b. (a -> b) -> a -> b
$! [FilePath] -> Set UnitId
mkEntries [FilePath]
paths
  where
    mkEntries :: [FilePath] -> Set UnitId
mkEntries =
      UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.delete (FilePath -> UnitId
mkUnitId FilePath
"package.db")
        (Set UnitId -> Set UnitId)
-> ([FilePath] -> Set UnitId) -> [FilePath] -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.delete (FilePath -> UnitId
mkUnitId FilePath
"incoming")
        (Set UnitId -> Set UnitId)
-> ([FilePath] -> Set UnitId) -> [FilePath] -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList
        ([UnitId] -> Set UnitId)
-> ([FilePath] -> [UnitId]) -> [FilePath] -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> UnitId) -> [FilePath] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> UnitId
mkUnitId
        ([FilePath] -> [UnitId])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
valid
    valid :: FilePath -> Bool
valid (Char
'.' : FilePath
_) = Bool
False
    valid FilePath
_ = Bool
True

-- | The outcome of 'newStoreEntry': either the store entry was newly created
-- or it existed already. The latter case happens if there was a race between
-- two builds of the same store entry.
data NewStoreEntryOutcome
  = UseNewStoreEntry
  | UseExistingStoreEntry
  deriving (NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
(NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool)
-> (NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool)
-> Eq NewStoreEntryOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
== :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
$c/= :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
/= :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
Eq, Int -> NewStoreEntryOutcome -> ShowS
[NewStoreEntryOutcome] -> ShowS
NewStoreEntryOutcome -> FilePath
(Int -> NewStoreEntryOutcome -> ShowS)
-> (NewStoreEntryOutcome -> FilePath)
-> ([NewStoreEntryOutcome] -> ShowS)
-> Show NewStoreEntryOutcome
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NewStoreEntryOutcome -> ShowS
showsPrec :: Int -> NewStoreEntryOutcome -> ShowS
$cshow :: NewStoreEntryOutcome -> FilePath
show :: NewStoreEntryOutcome -> FilePath
$cshowList :: [NewStoreEntryOutcome] -> ShowS
showList :: [NewStoreEntryOutcome] -> ShowS
Show)

-- | Place a new entry into the store. See the concurrency strategy description
-- for full details.
--
-- In particular, it takes two actions: one to place files into a temporary
-- location, and a second to perform any necessary registration. The first
-- action is executed without any locks held (the temp dir is unique). The
-- second action holds a lock that guarantees that only one cabal process is
-- able to install this store entry. This means it is safe to register into
-- the compiler package DB or do other similar actions.
--
-- Note that if you need to use the registration information later then you
-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry'
-- then you must read the existing registration information (unless your
-- registration information is constructed fully deterministically).
newStoreEntry
  :: Verbosity
  -> StoreDirLayout
  -> Compiler
  -> UnitId
  -> (FilePath -> IO (FilePath, [FilePath]))
  -- ^ Action to place files.
  -> IO ()
  -- ^ Register action, if necessary.
  -> IO NewStoreEntryOutcome
newStoreEntry :: Verbosity
-> StoreDirLayout
-> Compiler
-> UnitId
-> (FilePath -> IO (FilePath, [FilePath]))
-> IO ()
-> IO NewStoreEntryOutcome
newStoreEntry
  Verbosity
verbosity
  storeDirLayout :: StoreDirLayout
storeDirLayout@StoreDirLayout{Compiler -> FilePath
Compiler -> PackageDBCWD
Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD
Compiler -> UnitId -> FilePath
storePackageDirectory :: StoreDirLayout -> Compiler -> UnitId -> FilePath
storeDirectory :: StoreDirLayout -> Compiler -> FilePath
storeDirectory :: Compiler -> FilePath
storePackageDirectory :: Compiler -> UnitId -> FilePath
storePackageDBPath :: Compiler -> FilePath
storePackageDB :: Compiler -> PackageDBCWD
storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD
storeIncomingDirectory :: Compiler -> FilePath
storeIncomingLock :: Compiler -> UnitId -> FilePath
storePackageDBPath :: StoreDirLayout -> Compiler -> FilePath
storePackageDB :: StoreDirLayout -> Compiler -> PackageDBCWD
storePackageDBStack :: StoreDirLayout
-> Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD
storeIncomingDirectory :: StoreDirLayout -> Compiler -> FilePath
storeIncomingLock :: StoreDirLayout -> Compiler -> UnitId -> FilePath
..}
  Compiler
compiler
  UnitId
unitid
  FilePath -> IO (FilePath, [FilePath])
copyFiles
  IO ()
register =
    -- See $concurrency above for an explanation of the concurrency protocol

    StoreDirLayout
-> Compiler
-> (FilePath -> IO NewStoreEntryOutcome)
-> IO NewStoreEntryOutcome
forall a. StoreDirLayout -> Compiler -> (FilePath -> IO a) -> IO a
withTempIncomingDir StoreDirLayout
storeDirLayout Compiler
compiler ((FilePath -> IO NewStoreEntryOutcome) -> IO NewStoreEntryOutcome)
-> (FilePath -> IO NewStoreEntryOutcome) -> IO NewStoreEntryOutcome
forall a b. (a -> b) -> a -> b
$ \FilePath
incomingTmpDir -> do
      -- Write all store entry files within the temp dir and return the prefix.
      (FilePath
incomingEntryDir, [FilePath]
otherFiles) <- FilePath -> IO (FilePath, [FilePath])
copyFiles FilePath
incomingTmpDir

      -- Take a lock named after the 'UnitId' in question.
      Verbosity
-> StoreDirLayout
-> Compiler
-> UnitId
-> IO NewStoreEntryOutcome
-> IO NewStoreEntryOutcome
forall a.
Verbosity -> StoreDirLayout -> Compiler -> UnitId -> IO a -> IO a
withIncomingUnitIdLock Verbosity
verbosity StoreDirLayout
storeDirLayout Compiler
compiler UnitId
unitid (IO NewStoreEntryOutcome -> IO NewStoreEntryOutcome)
-> IO NewStoreEntryOutcome -> IO NewStoreEntryOutcome
forall a b. (a -> b) -> a -> b
$ do
        -- Check for the existence of the final store entry directory.
        Bool
exists <- StoreDirLayout -> Compiler -> UnitId -> IO Bool
doesStoreEntryExist StoreDirLayout
storeDirLayout Compiler
compiler UnitId
unitid

        if Bool
exists
          then -- If the entry exists then we lost the race and we must abandon,
          -- unlock and re-use the existing store entry.
          do
            Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"Concurrent build race: abandoning build in favour of existing "
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"store entry "
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ CompilerId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compid
                FilePath -> ShowS
</> UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnitId
unitid
            NewStoreEntryOutcome -> IO NewStoreEntryOutcome
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NewStoreEntryOutcome
UseExistingStoreEntry
          else -- If the entry does not exist then we won the race and can proceed.
          do
            -- Register the package into the package db (if appropriate).
            IO ()
register

            -- Atomically rename the temp dir to the final store entry location.
            FilePath -> FilePath -> IO ()
renameDirectory FilePath
incomingEntryDir FilePath
finalEntryDir
            [FilePath] -> (FilePath -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
otherFiles ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
              let finalStoreFile :: FilePath
finalStoreFile = Compiler -> FilePath
storeDirectory Compiler
compiler FilePath -> ShowS
</> FilePath -> ShowS
makeRelative (ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FilePath
incomingTmpDir FilePath -> ShowS
</> (ShowS
dropDrive (Compiler -> FilePath
storeDirectory Compiler
compiler))) FilePath
file
              Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
finalStoreFile)
              FilePath -> FilePath -> IO ()
renameFile FilePath
file FilePath
finalStoreFile

            Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"Installed store entry " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ CompilerId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compid FilePath -> ShowS
</> UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnitId
unitid
            NewStoreEntryOutcome -> IO NewStoreEntryOutcome
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NewStoreEntryOutcome
UseNewStoreEntry
    where
      compid :: CompilerId
compid = Compiler -> CompilerId
compilerId Compiler
compiler

      finalEntryDir :: FilePath
finalEntryDir = Compiler -> UnitId -> FilePath
storePackageDirectory Compiler
compiler UnitId
unitid

withTempIncomingDir
  :: StoreDirLayout
  -> Compiler
  -> (FilePath -> IO a)
  -> IO a
withTempIncomingDir :: forall a. StoreDirLayout -> Compiler -> (FilePath -> IO a) -> IO a
withTempIncomingDir StoreDirLayout{Compiler -> FilePath
storeIncomingDirectory :: StoreDirLayout -> Compiler -> FilePath
storeIncomingDirectory :: Compiler -> FilePath
storeIncomingDirectory} Compiler
compiler FilePath -> IO a
action = do
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
incomingDir
  Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
silent FilePath
incomingDir FilePath
"new" FilePath -> IO a
action
  where
    incomingDir :: FilePath
incomingDir = Compiler -> FilePath
storeIncomingDirectory Compiler
compiler

withIncomingUnitIdLock
  :: Verbosity
  -> StoreDirLayout
  -> Compiler
  -> UnitId
  -> IO a
  -> IO a
withIncomingUnitIdLock :: forall a.
Verbosity -> StoreDirLayout -> Compiler -> UnitId -> IO a -> IO a
withIncomingUnitIdLock
  Verbosity
verbosity
  StoreDirLayout{Compiler -> UnitId -> FilePath
storeIncomingLock :: StoreDirLayout -> Compiler -> UnitId -> FilePath
storeIncomingLock :: Compiler -> UnitId -> FilePath
storeIncomingLock}
  Compiler
compiler
  UnitId
unitid
  IO a
action =
    IO FD -> (FD -> IO ()) -> (FD -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FD
takeLock FD -> IO ()
releaseLock (\FD
_hnd -> IO a
action)
    where
      compid :: CompilerId
compid = Compiler -> CompilerId
compilerId Compiler
compiler
#ifdef MIN_VERSION_lukko
      takeLock :: IO FD
takeLock
          | Bool
fileLockingSupported = do
              FD
fd <- FilePath -> IO FD
fdOpen (Compiler -> UnitId -> FilePath
storeIncomingLock Compiler
compiler UnitId
unitid)
              Bool
gotLock <- FD -> LockMode -> IO Bool
fdTryLock FD
fd LockMode
ExclusiveLock
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gotLock  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Waiting for file lock on store entry "
                                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ CompilerId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compid FilePath -> ShowS
</> UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnitId
unitid
                  FD -> LockMode -> IO ()
fdLock FD
fd LockMode
ExclusiveLock
              FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd

          -- if there's no locking, do nothing. Be careful on AIX.
          | Bool
otherwise = FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
forall a. HasCallStack => a
undefined -- :(

      releaseLock :: FD -> IO ()
releaseLock FD
fd
          | Bool
fileLockingSupported = do
              FD -> IO ()
fdUnlock FD
fd
              FD -> IO ()
fdClose FD
fd
          | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
      takeLock = do
        h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode
        -- First try non-blocking, but if we would have to wait then
        -- log an explanation and do it again in blocking mode.
        gotlock <- hTryLock h ExclusiveLock
        unless gotlock $ do
          info verbosity $ "Waiting for file lock on store entry "
                        ++ prettyShow compid </> prettyShow unitid
          hLock h ExclusiveLock
        return h

      releaseLock h = hUnlock h >> hClose h
#endif