cabal-install/src/Distribution/Client/Store.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4
   5 -- | Management for the installed package store.
   6 module Distribution.Client.Store
   7   ( -- * The store layout
   8     StoreDirLayout (..)
   9   , defaultStoreDirLayout
  10
  11     -- * Reading store entries
  12   , getStoreEntries
  13   , doesStoreEntryExist
  14
  15     -- * Creating store entries
  16   , newStoreEntry
  17   , NewStoreEntryOutcome (..)
  18
  19     -- * Concurrency strategy
  20     -- $concurrency
  21   ) where
  22
  23 import Distribution.Client.Compat.Prelude
  24 import Prelude ()
  25
  26 import Distribution.Client.DistDirLayout
  27 import Distribution.Client.RebuildMonad
  28
  29 import Distribution.Compiler (CompilerId)
  30 import Distribution.Package (UnitId, mkUnitId)
  31
  32 import Distribution.Simple.Utils
  33   ( debug
  34   , info
  35   , withTempDirectory
  36   )
  37 import Distribution.Verbosity
  38   ( silent
  39   )
  40
  41 import Control.Exception
  42 import qualified Data.Set as Set
  43 import System.Directory
  44 import System.FilePath
  45
  46 #ifdef MIN_VERSION_lukko
  47 import Lukko
  48 #else
  49 import System.IO (openFile, IOMode(ReadWriteMode), hClose)
  50 import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))
  51 #if MIN_VERSION_base(4,11,0)
  52 import GHC.IO.Handle.Lock (hUnlock)
  53 #endif
  54 #endif
  55
  56 -- $concurrency
  57 --
  58 -- We access and update the store concurrently. Our strategy to do that safely
  59 -- is as follows.
  60 --
  61 -- The store entries once created are immutable. This alone simplifies matters
  62 -- considerably.
  63 --
  64 -- Additionally, the way 'UnitId' hashes are constructed means that if a store
  65 -- entry exists already then we can assume its content is ok to reuse, rather
  66 -- than having to re-recreate. This is the nix-style input hashing concept.
  67 --
  68 -- A consequence of this is that with a little care it is /safe/ to race
  69 -- updates against each other. Consider two independent concurrent builds that
  70 -- both want to build a particular 'UnitId', where that entry does not yet
  71 -- exist in the store. It is safe for both to build and try to install this
  72 -- entry into the store provided that:
  73 --
  74 -- * only one succeeds
  75 -- * the looser discovers that they lost, they abandon their own build and
  76 --   re-use the store entry installed by the winner.
  77 --
  78 -- Note that because builds are not reproducible in general (nor even
  79 -- necessarily ABI compatible) then it is essential that the loser abandon
  80 -- their build and use the one installed by the winner, so that subsequent
  81 -- packages are built against the exact package from the store rather than some
  82 -- morally equivalent package that may not be ABI compatible.
  83 --
  84 -- Our overriding goal is that store reads be simple, cheap and not require
  85 -- locking. We will derive our write-side protocol to make this possible.
  86 --
  87 -- The read-side protocol is simply:
  88 --
  89 -- * check for the existence of a directory entry named after the 'UnitId' in
  90 --   question. That is, if the dir entry @$root/foo-1.0-fe56a...@ exists then
  91 --   the store entry can be assumed to be complete and immutable.
  92 --
  93 -- Given our read-side protocol, the final step on the write side must be to
  94 -- atomically rename a fully-formed store entry directory into its final
  95 -- location. While this will indeed be the final step, the preparatory steps
  96 -- are more complicated. The tricky aspect is that the store also contains a
  97 -- number of shared package databases (one per compiler version). Our read
  98 -- strategy means that by the time we install the store dir entry the package
  99 -- db must already have been updated. We cannot do the package db update
 100 -- as part of atomically renaming the store entry directory however. Furthermore
 101 -- it is not safe to allow either package db update because the db entry
 102 -- contains the ABI hash and this is not guaranteed to be deterministic. So we
 103 -- must register the new package prior to the atomic dir rename. Since this
 104 -- combination of steps are not atomic then we need locking.
 105 --
 106 -- The write-side protocol is:
 107 --
 108 -- * Create a unique temp dir and write all store entry files into it.
 109 --
 110 -- * Take a lock named after the 'UnitId' in question.
 111 --
 112 -- * Once holding the lock, check again for the existence of the final store
 113 --   entry directory. If the entry exists then the process lost the race and it
 114 --   must abandon, unlock and re-use the existing store entry. If the entry
 115 --   does not exist then the process won the race and it can proceed.
 116 --
 117 -- * Register the package into the package db. Note that the files are not in
 118 --   their final location at this stage so registration file checks may need
 119 --   to be disabled.
 120 --
 121 -- * Atomically rename the temp dir to the final store entry location.
 122 --
 123 -- * Release the previously-acquired lock.
 124 --
 125 -- Obviously this means it is possible to fail after registering but before
 126 -- installing the store entry, leaving a dangling package db entry. This is not
 127 -- much of a problem because this entry does not determine package existence
 128 -- for cabal. It does mean however that the package db update should be insert
 129 -- or replace, i.e. not failing if the db entry already exists.
 130
 131 -- | Check if a particular 'UnitId' exists in the store.
 132 doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool
 133 doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid =
 134   doesDirectoryExist (storePackageDirectory compid unitid)
 135
 136 -- | Return the 'UnitId's of all packages\/components already installed in the
 137 -- store.
 138 getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)
 139 getStoreEntries StoreDirLayout{storeDirectory} compid = do
 140   paths <- getDirectoryContentsMonitored (storeDirectory compid)
 141   return $! mkEntries paths
 142   where
 143     mkEntries =
 144       Set.delete (mkUnitId "package.db")
 145         . Set.delete (mkUnitId "incoming")
 146         . Set.fromList
 147         . map mkUnitId
 148         . filter valid
 149     valid ('.' : _) = False
 150     valid _ = True
 151
 152 -- | The outcome of 'newStoreEntry': either the store entry was newly created
 153 -- or it existed already. The latter case happens if there was a race between
 154 -- two builds of the same store entry.
 155 data NewStoreEntryOutcome
 156   = UseNewStoreEntry
 157   | UseExistingStoreEntry
 158   deriving (Eq, Show)
 159
 160 -- | Place a new entry into the store. See the concurrency strategy description
 161 -- for full details.
 162 --
 163 -- In particular, it takes two actions: one to place files into a temporary
 164 -- location, and a second to perform any necessary registration. The first
 165 -- action is executed without any locks held (the temp dir is unique). The
 166 -- second action holds a lock that guarantees that only one cabal process is
 167 -- able to install this store entry. This means it is safe to register into
 168 -- the compiler package DB or do other similar actions.
 169 --
 170 -- Note that if you need to use the registration information later then you
 171 -- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry'
 172 -- then you must read the existing registration information (unless your
 173 -- registration information is constructed fully deterministically).
 174 newStoreEntry
 175   :: Verbosity
 176   -> StoreDirLayout
 177   -> CompilerId
 178   -> UnitId
 179   -> (FilePath -> IO (FilePath, [FilePath]))
 180   -- ^ Action to place files.
 181   -> IO ()
 182   -- ^ Register action, if necessary.
 183   -> IO NewStoreEntryOutcome
 184 newStoreEntry
 185   verbosity
 186   storeDirLayout@StoreDirLayout{..}
 187   compid
 188   unitid
 189   copyFiles
 190   register =
 191     -- See $concurrency above for an explanation of the concurrency protocol
 192
 193     withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do
 194       -- Write all store entry files within the temp dir and return the prefix.
 195       (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir
 196
 197       -- Take a lock named after the 'UnitId' in question.
 198       withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do
 199         -- Check for the existence of the final store entry directory.
 200         exists <- doesStoreEntryExist storeDirLayout compid unitid
 201
 202         if exists
 203           then -- If the entry exists then we lost the race and we must abandon,
 204           -- unlock and re-use the existing store entry.
 205           do
 206             info verbosity $
 207               "Concurrent build race: abandoning build in favour of existing "
 208                 ++ "store entry "
 209                 ++ prettyShow compid
 210                 </> prettyShow unitid
 211             return UseExistingStoreEntry
 212           else -- If the entry does not exist then we won the race and can proceed.
 213           do
 214             -- Register the package into the package db (if appropriate).
 215             register
 216
 217             -- Atomically rename the temp dir to the final store entry location.
 218             renameDirectory incomingEntryDir finalEntryDir
 219             for_ otherFiles $ \file -> do
 220               let finalStoreFile = storeDirectory compid </> makeRelative (incomingTmpDir </> (dropDrive (storeDirectory compid))) file
 221               createDirectoryIfMissing True (takeDirectory finalStoreFile)
 222               renameFile file finalStoreFile
 223
 224             debug verbosity $
 225               "Installed store entry " ++ prettyShow compid </> prettyShow unitid
 226             return UseNewStoreEntry
 227     where
 228       finalEntryDir = storePackageDirectory compid unitid
 229
 230 withTempIncomingDir
 231   :: StoreDirLayout
 232   -> CompilerId
 233   -> (FilePath -> IO a)
 234   -> IO a
 235 withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do
 236   createDirectoryIfMissing True incomingDir
 237   withTempDirectory silent incomingDir "new" action
 238   where
 239     incomingDir = storeIncomingDirectory compid
 240
 241 withIncomingUnitIdLock
 242   :: Verbosity
 243   -> StoreDirLayout
 244   -> CompilerId
 245   -> UnitId
 246   -> IO a
 247   -> IO a
 248 withIncomingUnitIdLock
 249   verbosity
 250   StoreDirLayout{storeIncomingLock}
 251   compid
 252   unitid
 253   action =
 254     bracket takeLock releaseLock (\_hnd -> action)
 255     where
 256 #ifdef MIN_VERSION_lukko
 257     takeLock
 258         | fileLockingSupported = do
 259             fd <- fdOpen (storeIncomingLock compid unitid)
 260             gotLock <- fdTryLock fd ExclusiveLock
 261             unless gotLock  $ do
 262                 info verbosity $ "Waiting for file lock on store entry "
 263                               ++ prettyShow compid </> prettyShow unitid
 264                 fdLock fd ExclusiveLock
 265             return fd
 266
 267         -- if there's no locking, do nothing. Be careful on AIX.
 268         | otherwise = return undefined -- :(
 269
 270     releaseLock fd
 271         | fileLockingSupported = do
 272             fdUnlock fd
 273             fdClose fd
 274         | otherwise = return ()
 275 #else
 276     takeLock = do
 277       h <- openFile (storeIncomingLock compid unitid) ReadWriteMode
 278       -- First try non-blocking, but if we would have to wait then
 279       -- log an explanation and do it again in blocking mode.
 280       gotlock <- hTryLock h ExclusiveLock
 281       unless gotlock $ do
 282         info verbosity $ "Waiting for file lock on store entry "
 283                       ++ prettyShow compid </> prettyShow unitid
 284         hLock h ExclusiveLock
 285       return h
 286
 287     releaseLock h = hUnlock h >> hClose h
 288 #endif