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