never executed always true always false
1 {-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}
2
3
4 -- | Management for the installed package store.
5 --
6 module 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
24 import Prelude ()
25 import Distribution.Client.Compat.Prelude
26
27 import Distribution.Client.DistDirLayout
28 import Distribution.Client.RebuildMonad
29
30 import Distribution.Package (UnitId, mkUnitId)
31 import Distribution.Compiler (CompilerId)
32
33 import Distribution.Simple.Utils
34 ( withTempDirectory, debug, info )
35 import Distribution.Verbosity
36 ( silent )
37
38 import qualified Data.Set as Set
39 import Control.Exception
40 import System.FilePath
41 import System.Directory
42
43 #ifdef MIN_VERSION_lukko
44 import Lukko
45 #else
46 import System.IO (openFile, IOMode(ReadWriteMode), hClose)
47 import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))
48 #if MIN_VERSION_base(4,11,0)
49 import 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 --
131 doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool
132 doesStoreEntryExist 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 --
139 getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)
140 getStoreEntries 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 --
157 data 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 --
176 newStoreEntry :: 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
183 newStoreEntry 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
228 withTempIncomingDir :: StoreDirLayout -> CompilerId
229 -> (FilePath -> IO a) -> IO a
230 withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do
231 createDirectoryIfMissing True incomingDir
232 withTempDirectory silent incomingDir "new" action
233 where
234 incomingDir = storeIncomingDirectory compid
235
236
237 withIncomingUnitIdLock :: Verbosity -> StoreDirLayout
238 -> CompilerId -> UnitId
239 -> IO a -> IO a
240 withIncomingUnitIdLock 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