ghc-pkg: Try opening lockfiles in read-write mode first
[ghc.git] / libraries / ghc-boot / GHC / PackageDb.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE DeriveFoldable #-}
5 {-# LANGUAGE DeriveFunctor #-}
6 {-# LANGUAGE DeriveTraversable #-}
7 {-# LANGUAGE FunctionalDependencies #-}
8 {-# LANGUAGE LambdaCase #-}
9 {-# LANGUAGE GADTs #-}
10 {-# LANGUAGE KindSignatures #-}
11 {-# LANGUAGE MultiParamTypeClasses #-}
12 {-# LANGUAGE StandaloneDeriving #-}
13 {-# LANGUAGE TupleSections #-}
14 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
15 -----------------------------------------------------------------------------
16 -- |
17 -- Module : GHC.PackageDb
18 -- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014
19 --
20 -- Maintainer : ghc-devs@haskell.org
21 -- Portability : portable
22 --
23 -- This module provides the view of GHC's database of registered packages that
24 -- is shared between GHC the compiler\/library, and the ghc-pkg program. It
25 -- defines the database format that is shared between GHC and ghc-pkg.
26 --
27 -- The database format, and this library are constructed so that GHC does not
28 -- have to depend on the Cabal library. The ghc-pkg program acts as the
29 -- gateway between the external package format (which is defined by Cabal) and
30 -- the internal package format which is specialised just for GHC.
31 --
32 -- GHC the compiler only needs some of the information which is kept about
33 -- registerd packages, such as module names, various paths etc. On the other
34 -- hand ghc-pkg has to keep all the information from Cabal packages and be able
35 -- to regurgitate it for users and other tools.
36 --
37 -- The first trick is that we duplicate some of the information in the package
38 -- database. We essentially keep two versions of the datbase in one file, one
39 -- version used only by ghc-pkg which keeps the full information (using the
40 -- serialised form of the 'InstalledPackageInfo' type defined by the Cabal
41 -- library); and a second version written by ghc-pkg and read by GHC which has
42 -- just the subset of information that GHC needs.
43 --
44 -- The second trick is that this module only defines in detail the format of
45 -- the second version -- the bit GHC uses -- and the part managed by ghc-pkg
46 -- is kept in the file but here we treat it as an opaque blob of data. That way
47 -- this library avoids depending on Cabal.
48 --
49 module GHC.PackageDb (
50 InstalledPackageInfo(..),
51 DbModule(..),
52 DbUnitId(..),
53 BinaryStringRep(..),
54 DbUnitIdModuleRep(..),
55 emptyInstalledPackageInfo,
56 PackageDbLock,
57 lockPackageDb,
58 unlockPackageDb,
59 DbMode(..),
60 DbOpenMode(..),
61 isDbOpenReadMode,
62 readPackageDbForGhc,
63 readPackageDbForGhcPkg,
64 writePackageDb
65 ) where
66
67 import Data.Version (Version(..))
68 import qualified Data.ByteString as BS
69 import qualified Data.ByteString.Char8 as BS.Char8
70 import qualified Data.ByteString.Lazy as BS.Lazy
71 import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)
72 import qualified Data.Foldable as F
73 import qualified Data.Traversable as F
74 import Data.Binary as Bin
75 import Data.Binary.Put as Bin
76 import Data.Binary.Get as Bin
77 import Control.Exception as Exception
78 import Control.Monad (when)
79 import System.FilePath
80 import System.IO
81 import System.IO.Error
82 import GHC.IO.Exception (IOErrorType(InappropriateType))
83 #if MIN_VERSION_base(4,10,0)
84 import GHC.IO.Handle.Lock
85 #endif
86 import System.Directory
87
88
89 -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
90 -- that GHC is interested in. See Cabal's documentation for a more detailed
91 -- description of all of the fields.
92 --
93 data InstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod
94 = InstalledPackageInfo {
95 unitId :: instunitid,
96 componentId :: compid,
97 instantiatedWith :: [(modulename, mod)],
98 sourcePackageId :: srcpkgid,
99 packageName :: srcpkgname,
100 packageVersion :: Version,
101 sourceLibName :: Maybe srcpkgname,
102 abiHash :: String,
103 depends :: [instunitid],
104 -- | Like 'depends', but each dependency is annotated with the
105 -- ABI hash we expect the dependency to respect.
106 abiDepends :: [(instunitid, String)],
107 importDirs :: [FilePath],
108 hsLibraries :: [String],
109 extraLibraries :: [String],
110 extraGHCiLibraries :: [String],
111 libraryDirs :: [FilePath],
112 libraryDynDirs :: [FilePath],
113 frameworks :: [String],
114 frameworkDirs :: [FilePath],
115 ldOptions :: [String],
116 ccOptions :: [String],
117 includes :: [String],
118 includeDirs :: [FilePath],
119 haddockInterfaces :: [FilePath],
120 haddockHTMLs :: [FilePath],
121 exposedModules :: [(modulename, Maybe mod)],
122 hiddenModules :: [modulename],
123 indefinite :: Bool,
124 exposed :: Bool,
125 trusted :: Bool
126 }
127 deriving (Eq, Show)
128
129 -- | A convenience constraint synonym for common constraints over parameters
130 -- to 'InstalledPackageInfo'.
131 type RepInstalledPackageInfo compid srcpkgid srcpkgname instunitid unitid modulename mod =
132 (BinaryStringRep srcpkgid, BinaryStringRep srcpkgname,
133 BinaryStringRep modulename, BinaryStringRep compid,
134 BinaryStringRep instunitid,
135 DbUnitIdModuleRep instunitid compid unitid modulename mod)
136
137 -- | A type-class for the types which can be converted into 'DbModule'/'DbUnitId'.
138 -- There is only one type class because these types are mutually recursive.
139 -- NB: The functional dependency helps out type inference in cases
140 -- where types would be ambiguous.
141 class DbUnitIdModuleRep instunitid compid unitid modulename mod
142 | mod -> unitid, unitid -> mod, mod -> modulename, unitid -> compid, unitid -> instunitid
143 where
144 fromDbModule :: DbModule instunitid compid unitid modulename mod -> mod
145 toDbModule :: mod -> DbModule instunitid compid unitid modulename mod
146 fromDbUnitId :: DbUnitId instunitid compid unitid modulename mod -> unitid
147 toDbUnitId :: unitid -> DbUnitId instunitid compid unitid modulename mod
148
149 -- | @ghc-boot@'s copy of 'Module', i.e. what is serialized to the database.
150 -- Use 'DbUnitIdModuleRep' to convert it into an actual 'Module'.
151 -- It has phantom type parameters as this is the most convenient way
152 -- to avoid undecidable instances.
153 data DbModule instunitid compid unitid modulename mod
154 = DbModule {
155 dbModuleUnitId :: unitid,
156 dbModuleName :: modulename
157 }
158 | DbModuleVar {
159 dbModuleVarName :: modulename
160 }
161 deriving (Eq, Show)
162
163 -- | @ghc-boot@'s copy of 'UnitId', i.e. what is serialized to the database.
164 -- Use 'DbUnitIdModuleRep' to convert it into an actual 'UnitId'.
165 -- It has phantom type parameters as this is the most convenient way
166 -- to avoid undecidable instances.
167 data DbUnitId instunitid compid unitid modulename mod
168 = DbUnitId compid [(modulename, mod)]
169 | DbInstalledUnitId instunitid
170 deriving (Eq, Show)
171
172 class BinaryStringRep a where
173 fromStringRep :: BS.ByteString -> a
174 toStringRep :: a -> BS.ByteString
175
176 emptyInstalledPackageInfo :: RepInstalledPackageInfo a b c d e f g
177 => InstalledPackageInfo a b c d e f g
178 emptyInstalledPackageInfo =
179 InstalledPackageInfo {
180 unitId = fromStringRep BS.empty,
181 componentId = fromStringRep BS.empty,
182 instantiatedWith = [],
183 sourcePackageId = fromStringRep BS.empty,
184 packageName = fromStringRep BS.empty,
185 packageVersion = Version [] [],
186 sourceLibName = Nothing,
187 abiHash = "",
188 depends = [],
189 abiDepends = [],
190 importDirs = [],
191 hsLibraries = [],
192 extraLibraries = [],
193 extraGHCiLibraries = [],
194 libraryDirs = [],
195 libraryDynDirs = [],
196 frameworks = [],
197 frameworkDirs = [],
198 ldOptions = [],
199 ccOptions = [],
200 includes = [],
201 includeDirs = [],
202 haddockInterfaces = [],
203 haddockHTMLs = [],
204 exposedModules = [],
205 hiddenModules = [],
206 indefinite = False,
207 exposed = False,
208 trusted = False
209 }
210
211 -- | Represents a lock of a package db.
212 newtype PackageDbLock = PackageDbLock
213 #if MIN_VERSION_base(4,10,0)
214 Handle
215 #else
216 () -- no locking primitives available in base < 4.10
217 #endif
218
219 -- | Acquire an exclusive lock related to package DB under given location.
220 lockPackageDb :: FilePath -> IO PackageDbLock
221
222 -- | Release the lock related to package DB.
223 unlockPackageDb :: PackageDbLock -> IO ()
224
225 #if MIN_VERSION_base(4,10,0)
226
227 -- | Acquire a lock of given type related to package DB under given location.
228 lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
229 lockPackageDbWith mode file = do
230 -- We are trying to open the lock file and then lock it. Thus the lock file
231 -- needs to either exist or we need to be able to create it. Ideally we
232 -- would not assume that the lock file always exists in advance. When we are
233 -- dealing with a package DB where we have write access then if the lock
234 -- file does not exist then we can create it by opening the file in
235 -- read/write mode. On the other hand if we are dealing with a package DB
236 -- where we do not have write access (e.g. a global DB) then we can only
237 -- open in read mode, and the lock file had better exist already or we're in
238 -- trouble. So for global read-only DBs on platforms where we must lock the
239 -- DB for reading then we will require that the installer/packaging has
240 -- included the lock file.
241 --
242 -- Thus the logic here is to first try opening in read-write mode
243 -- and if that fails we try read-only (to handle global read-only DBs).
244 -- If either succeed then lock the file. IO exceptions (other than the first
245 -- open attempt failing due to the file not existing) simply propagate.
246 --
247 -- Note that there is a complexity here which was discovered in #13945: some
248 -- filesystems (e.g. NFS) will only allow exclusive locking if the fd was
249 -- opened for write access. We would previously try opening the lockfile for
250 -- read-only access first, however this failed when run on such filesystems.
251 -- Consequently, we now try read-write access first, falling back to read-only
252 -- if are denied permission (e.g. in the case of a global database).
253 catchJust
254 (\e -> if isPermissionError e then Just () else Nothing)
255 (lockFileOpenIn ReadWriteMode)
256 (const $ lockFileOpenIn ReadMode)
257 where
258 lock = file <.> "lock"
259
260 lockFileOpenIn io_mode = bracketOnError
261 (openBinaryFile lock io_mode)
262 hClose
263 -- If file locking support is not available, ignore the error and proceed
264 -- normally. Without it the only thing we lose on non-Windows platforms is
265 -- the ability to safely issue concurrent updates to the same package db.
266 $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return ()
267 return $ PackageDbLock hnd
268
269 lockPackageDb = lockPackageDbWith ExclusiveLock
270 unlockPackageDb (PackageDbLock hnd) = hClose hnd
271
272 -- MIN_VERSION_base(4,10,0)
273 #else
274
275 lockPackageDb _file = return $ PackageDbLock ()
276 unlockPackageDb _lock = return ()
277
278 -- MIN_VERSION_base(4,10,0)
279 #endif
280
281 -- | Mode to open a package db in.
282 data DbMode = DbReadOnly | DbReadWrite
283
284 -- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So
285 -- it is like 'Maybe' but with a type argument for the mode to enforce that the
286 -- mode is used consistently.
287 data DbOpenMode (mode :: DbMode) t where
288 DbOpenReadOnly :: DbOpenMode 'DbReadOnly t
289 DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t
290
291 deriving instance Functor (DbOpenMode mode)
292 deriving instance F.Foldable (DbOpenMode mode)
293 deriving instance F.Traversable (DbOpenMode mode)
294
295 isDbOpenReadMode :: DbOpenMode mode t -> Bool
296 isDbOpenReadMode = \case
297 DbOpenReadOnly -> True
298 DbOpenReadWrite{} -> False
299
300 -- | Read the part of the package DB that GHC is interested in.
301 --
302 readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g =>
303 FilePath -> IO [InstalledPackageInfo a b c d e f g]
304 readPackageDbForGhc file =
305 decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
306 (pkgs, DbOpenReadOnly) -> return pkgs
307 where
308 getDbForGhc = do
309 _version <- getHeader
310 _ghcPartLen <- get :: Get Word32
311 ghcPart <- get
312 -- the next part is for ghc-pkg, but we stop here.
313 return ghcPart
314
315 -- | Read the part of the package DB that ghc-pkg is interested in
316 --
317 -- Note that the Binary instance for ghc-pkg's representation of packages
318 -- is not defined in this package. This is because ghc-pkg uses Cabal types
319 -- (and Binary instances for these) which this package does not depend on.
320 --
321 -- If we open the package db in read only mode, we get its contents. Otherwise
322 -- we additionally receive a PackageDbLock that represents a lock on the
323 -- database, so that we can safely update it later.
324 --
325 readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
326 IO (pkgs, DbOpenMode mode PackageDbLock)
327 readPackageDbForGhcPkg file mode =
328 decodeFromFile file mode getDbForGhcPkg
329 where
330 getDbForGhcPkg = do
331 _version <- getHeader
332 -- skip over the ghc part
333 ghcPartLen <- get :: Get Word32
334 _ghcPart <- skip (fromIntegral ghcPartLen)
335 -- the next part is for ghc-pkg
336 ghcPkgPart <- get
337 return ghcPkgPart
338
339 -- | Write the whole of the package DB, both parts.
340 --
341 writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) =>
342 FilePath -> [InstalledPackageInfo a b c d e f g] ->
343 pkgs -> IO ()
344 writePackageDb file ghcPkgs ghcPkgPart =
345 writeFileAtomic file (runPut putDbForGhcPkg)
346 where
347 putDbForGhcPkg = do
348 putHeader
349 put ghcPartLen
350 putLazyByteString ghcPart
351 put ghcPkgPart
352 where
353 ghcPartLen :: Word32
354 ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)
355 ghcPart = encode ghcPkgs
356
357 getHeader :: Get (Word32, Word32)
358 getHeader = do
359 magic <- getByteString (BS.length headerMagic)
360 when (magic /= headerMagic) $
361 fail "not a ghc-pkg db file, wrong file magic number"
362
363 majorVersion <- get :: Get Word32
364 -- The major version is for incompatible changes
365
366 minorVersion <- get :: Get Word32
367 -- The minor version is for compatible extensions
368
369 when (majorVersion /= 1) $
370 fail "unsupported ghc-pkg db format version"
371 -- If we ever support multiple major versions then we'll have to change
372 -- this code
373
374 -- The header can be extended without incrementing the major version,
375 -- we ignore fields we don't know about (currently all).
376 headerExtraLen <- get :: Get Word32
377 skip (fromIntegral headerExtraLen)
378
379 return (majorVersion, minorVersion)
380
381 putHeader :: Put
382 putHeader = do
383 putByteString headerMagic
384 put majorVersion
385 put minorVersion
386 put headerExtraLen
387 where
388 majorVersion = 1 :: Word32
389 minorVersion = 0 :: Word32
390 headerExtraLen = 0 :: Word32
391
392 headerMagic :: BS.ByteString
393 headerMagic = BS.Char8.pack "\0ghcpkg\0"
394
395
396 -- TODO: we may be able to replace the following with utils from the binary
397 -- package in future.
398
399 -- | Feed a 'Get' decoder with data chunks from a file.
400 --
401 decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
402 IO (pkgs, DbOpenMode mode PackageDbLock)
403 decodeFromFile file mode decoder = case mode of
404 DbOpenReadOnly -> do
405 -- When we open the package db in read only mode, there is no need to acquire
406 -- shared lock on non-Windows platform because we update the database with an
407 -- atomic rename, so readers will always see the database in a consistent
408 -- state.
409 #if MIN_VERSION_base(4,10,0) && defined(mingw32_HOST_OS)
410 bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
411 #endif
412 (, DbOpenReadOnly) <$> decodeFileContents
413 DbOpenReadWrite{} -> do
414 -- When we open the package db in read/write mode, acquire an exclusive lock
415 -- on the database and return it so we can keep it for the duration of the
416 -- update.
417 bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
418 (, DbOpenReadWrite lock) <$> decodeFileContents
419 where
420 decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
421 feed hnd (runGetIncremental decoder)
422
423 feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
424 if BS.null chunk
425 then feed hnd (k Nothing)
426 else feed hnd (k (Just chunk))
427 feed _ (Done _ _ res) = return res
428 feed _ (Fail _ _ msg) = ioError err
429 where
430 err = mkIOError InappropriateType loc Nothing (Just file)
431 `ioeSetErrorString` msg
432 loc = "GHC.PackageDb.readPackageDb"
433
434 -- Copied from Cabal's Distribution.Simple.Utils.
435 writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
436 writeFileAtomic targetPath content = do
437 let (targetDir, targetFile) = splitFileName targetPath
438 Exception.bracketOnError
439 (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
440 (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
441 (\(tmpPath, handle) -> do
442 BS.Lazy.hPut handle content
443 hClose handle
444 renameFile tmpPath targetPath)
445
446 instance (RepInstalledPackageInfo a b c d e f g) =>
447 Binary (InstalledPackageInfo a b c d e f g) where
448 put (InstalledPackageInfo
449 unitId componentId instantiatedWith sourcePackageId
450 packageName packageVersion
451 sourceLibName
452 abiHash depends abiDepends importDirs
453 hsLibraries extraLibraries extraGHCiLibraries
454 libraryDirs libraryDynDirs
455 frameworks frameworkDirs
456 ldOptions ccOptions
457 includes includeDirs
458 haddockInterfaces haddockHTMLs
459 exposedModules hiddenModules
460 indefinite exposed trusted) = do
461 put (toStringRep sourcePackageId)
462 put (toStringRep packageName)
463 put packageVersion
464 put (fmap toStringRep sourceLibName)
465 put (toStringRep unitId)
466 put (toStringRep componentId)
467 put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
468 instantiatedWith)
469 put abiHash
470 put (map toStringRep depends)
471 put (map (\(k,v) -> (toStringRep k, v)) abiDepends)
472 put importDirs
473 put hsLibraries
474 put extraLibraries
475 put extraGHCiLibraries
476 put libraryDirs
477 put libraryDynDirs
478 put frameworks
479 put frameworkDirs
480 put ldOptions
481 put ccOptions
482 put includes
483 put includeDirs
484 put haddockInterfaces
485 put haddockHTMLs
486 put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))
487 exposedModules)
488 put (map toStringRep hiddenModules)
489 put indefinite
490 put exposed
491 put trusted
492
493 get = do
494 sourcePackageId <- get
495 packageName <- get
496 packageVersion <- get
497 sourceLibName <- get
498 unitId <- get
499 componentId <- get
500 instantiatedWith <- get
501 abiHash <- get
502 depends <- get
503 abiDepends <- get
504 importDirs <- get
505 hsLibraries <- get
506 extraLibraries <- get
507 extraGHCiLibraries <- get
508 libraryDirs <- get
509 libraryDynDirs <- get
510 frameworks <- get
511 frameworkDirs <- get
512 ldOptions <- get
513 ccOptions <- get
514 includes <- get
515 includeDirs <- get
516 haddockInterfaces <- get
517 haddockHTMLs <- get
518 exposedModules <- get
519 hiddenModules <- get
520 indefinite <- get
521 exposed <- get
522 trusted <- get
523 return (InstalledPackageInfo
524 (fromStringRep unitId)
525 (fromStringRep componentId)
526 (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
527 instantiatedWith)
528 (fromStringRep sourcePackageId)
529 (fromStringRep packageName) packageVersion
530 (fmap fromStringRep sourceLibName)
531 abiHash
532 (map fromStringRep depends)
533 (map (\(k,v) -> (fromStringRep k, v)) abiDepends)
534 importDirs
535 hsLibraries extraLibraries extraGHCiLibraries
536 libraryDirs libraryDynDirs
537 frameworks frameworkDirs
538 ldOptions ccOptions
539 includes includeDirs
540 haddockInterfaces haddockHTMLs
541 (map (\(mod_name, mb_mod) ->
542 (fromStringRep mod_name, fmap fromDbModule mb_mod))
543 exposedModules)
544 (map fromStringRep hiddenModules)
545 indefinite exposed trusted)
546
547 instance (BinaryStringRep modulename, BinaryStringRep compid,
548 BinaryStringRep instunitid,
549 DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
550 Binary (DbModule instunitid compid unitid modulename mod) where
551 put (DbModule dbModuleUnitId dbModuleName) = do
552 putWord8 0
553 put (toDbUnitId dbModuleUnitId)
554 put (toStringRep dbModuleName)
555 put (DbModuleVar dbModuleVarName) = do
556 putWord8 1
557 put (toStringRep dbModuleVarName)
558 get = do
559 b <- getWord8
560 case b of
561 0 -> do dbModuleUnitId <- get
562 dbModuleName <- get
563 return (DbModule (fromDbUnitId dbModuleUnitId)
564 (fromStringRep dbModuleName))
565 _ -> do dbModuleVarName <- get
566 return (DbModuleVar (fromStringRep dbModuleVarName))
567
568 instance (BinaryStringRep modulename, BinaryStringRep compid,
569 BinaryStringRep instunitid,
570 DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
571 Binary (DbUnitId instunitid compid unitid modulename mod) where
572 put (DbInstalledUnitId instunitid) = do
573 putWord8 0
574 put (toStringRep instunitid)
575 put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
576 putWord8 1
577 put (toStringRep dbUnitIdComponentId)
578 put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts)
579 get = do
580 b <- getWord8
581 case b of
582 0 -> do
583 instunitid <- get
584 return (DbInstalledUnitId (fromStringRep instunitid))
585 _ -> do
586 dbUnitIdComponentId <- get
587 dbUnitIdInsts <- get
588 return (DbUnitId
589 (fromStringRep dbUnitIdComponentId)
590 (map (\(mod_name, mod) -> ( fromStringRep mod_name
591 , fromDbModule mod))
592 dbUnitIdInsts))