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