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