PackageDb: Explicitly unlock package database before closing
[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) = do
271 #if MIN_VERSION_base(4,11,0)
272 hUnlock hnd
273 #endif
274 hClose hnd
275
276 -- MIN_VERSION_base(4,10,0)
277 #else
278
279 lockPackageDb _file = return $ PackageDbLock ()
280 unlockPackageDb _lock = return ()
281
282 -- MIN_VERSION_base(4,10,0)
283 #endif
284
285 -- | Mode to open a package db in.
286 data DbMode = DbReadOnly | DbReadWrite
287
288 -- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode. So
289 -- it is like 'Maybe' but with a type argument for the mode to enforce that the
290 -- mode is used consistently.
291 data DbOpenMode (mode :: DbMode) t where
292 DbOpenReadOnly :: DbOpenMode 'DbReadOnly t
293 DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t
294
295 deriving instance Functor (DbOpenMode mode)
296 deriving instance F.Foldable (DbOpenMode mode)
297 deriving instance F.Traversable (DbOpenMode mode)
298
299 isDbOpenReadMode :: DbOpenMode mode t -> Bool
300 isDbOpenReadMode = \case
301 DbOpenReadOnly -> True
302 DbOpenReadWrite{} -> False
303
304 -- | Read the part of the package DB that GHC is interested in.
305 --
306 readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g =>
307 FilePath -> IO [InstalledPackageInfo a b c d e f g]
308 readPackageDbForGhc file =
309 decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
310 (pkgs, DbOpenReadOnly) -> return pkgs
311 where
312 getDbForGhc = do
313 _version <- getHeader
314 _ghcPartLen <- get :: Get Word32
315 ghcPart <- get
316 -- the next part is for ghc-pkg, but we stop here.
317 return ghcPart
318
319 -- | Read the part of the package DB that ghc-pkg is interested in
320 --
321 -- Note that the Binary instance for ghc-pkg's representation of packages
322 -- is not defined in this package. This is because ghc-pkg uses Cabal types
323 -- (and Binary instances for these) which this package does not depend on.
324 --
325 -- If we open the package db in read only mode, we get its contents. Otherwise
326 -- we additionally receive a PackageDbLock that represents a lock on the
327 -- database, so that we can safely update it later.
328 --
329 readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
330 IO (pkgs, DbOpenMode mode PackageDbLock)
331 readPackageDbForGhcPkg file mode =
332 decodeFromFile file mode getDbForGhcPkg
333 where
334 getDbForGhcPkg = do
335 _version <- getHeader
336 -- skip over the ghc part
337 ghcPartLen <- get :: Get Word32
338 _ghcPart <- skip (fromIntegral ghcPartLen)
339 -- the next part is for ghc-pkg
340 ghcPkgPart <- get
341 return ghcPkgPart
342
343 -- | Write the whole of the package DB, both parts.
344 --
345 writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) =>
346 FilePath -> [InstalledPackageInfo a b c d e f g] ->
347 pkgs -> IO ()
348 writePackageDb file ghcPkgs ghcPkgPart =
349 writeFileAtomic file (runPut putDbForGhcPkg)
350 where
351 putDbForGhcPkg = do
352 putHeader
353 put ghcPartLen
354 putLazyByteString ghcPart
355 put ghcPkgPart
356 where
357 ghcPartLen :: Word32
358 ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)
359 ghcPart = encode ghcPkgs
360
361 getHeader :: Get (Word32, Word32)
362 getHeader = do
363 magic <- getByteString (BS.length headerMagic)
364 when (magic /= headerMagic) $
365 fail "not a ghc-pkg db file, wrong file magic number"
366
367 majorVersion <- get :: Get Word32
368 -- The major version is for incompatible changes
369
370 minorVersion <- get :: Get Word32
371 -- The minor version is for compatible extensions
372
373 when (majorVersion /= 1) $
374 fail "unsupported ghc-pkg db format version"
375 -- If we ever support multiple major versions then we'll have to change
376 -- this code
377
378 -- The header can be extended without incrementing the major version,
379 -- we ignore fields we don't know about (currently all).
380 headerExtraLen <- get :: Get Word32
381 skip (fromIntegral headerExtraLen)
382
383 return (majorVersion, minorVersion)
384
385 putHeader :: Put
386 putHeader = do
387 putByteString headerMagic
388 put majorVersion
389 put minorVersion
390 put headerExtraLen
391 where
392 majorVersion = 1 :: Word32
393 minorVersion = 0 :: Word32
394 headerExtraLen = 0 :: Word32
395
396 headerMagic :: BS.ByteString
397 headerMagic = BS.Char8.pack "\0ghcpkg\0"
398
399
400 -- TODO: we may be able to replace the following with utils from the binary
401 -- package in future.
402
403 -- | Feed a 'Get' decoder with data chunks from a file.
404 --
405 decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
406 IO (pkgs, DbOpenMode mode PackageDbLock)
407 decodeFromFile file mode decoder = case mode of
408 DbOpenReadOnly -> do
409 -- When we open the package db in read only mode, there is no need to acquire
410 -- shared lock on non-Windows platform because we update the database with an
411 -- atomic rename, so readers will always see the database in a consistent
412 -- state.
413 #if MIN_VERSION_base(4,10,0) && defined(mingw32_HOST_OS)
414 bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
415 #endif
416 (, DbOpenReadOnly) <$> decodeFileContents
417 DbOpenReadWrite{} -> do
418 -- When we open the package db in read/write mode, acquire an exclusive lock
419 -- on the database and return it so we can keep it for the duration of the
420 -- update.
421 bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
422 (, DbOpenReadWrite lock) <$> decodeFileContents
423 where
424 decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
425 feed hnd (runGetIncremental decoder)
426
427 feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
428 if BS.null chunk
429 then feed hnd (k Nothing)
430 else feed hnd (k (Just chunk))
431 feed _ (Done _ _ res) = return res
432 feed _ (Fail _ _ msg) = ioError err
433 where
434 err = mkIOError InappropriateType loc Nothing (Just file)
435 `ioeSetErrorString` msg
436 loc = "GHC.PackageDb.readPackageDb"
437
438 -- Copied from Cabal's Distribution.Simple.Utils.
439 writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
440 writeFileAtomic targetPath content = do
441 let (targetDir, targetFile) = splitFileName targetPath
442 Exception.bracketOnError
443 (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
444 (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
445 (\(tmpPath, handle) -> do
446 BS.Lazy.hPut handle content
447 hClose handle
448 renameFile tmpPath targetPath)
449
450 instance (RepInstalledPackageInfo a b c d e f g) =>
451 Binary (InstalledPackageInfo a b c d e f g) where
452 put (InstalledPackageInfo
453 unitId componentId instantiatedWith sourcePackageId
454 packageName packageVersion
455 sourceLibName
456 abiHash depends abiDepends importDirs
457 hsLibraries extraLibraries extraGHCiLibraries
458 libraryDirs libraryDynDirs
459 frameworks frameworkDirs
460 ldOptions ccOptions
461 includes includeDirs
462 haddockInterfaces haddockHTMLs
463 exposedModules hiddenModules
464 indefinite exposed trusted) = do
465 put (toStringRep sourcePackageId)
466 put (toStringRep packageName)
467 put packageVersion
468 put (fmap toStringRep sourceLibName)
469 put (toStringRep unitId)
470 put (toStringRep componentId)
471 put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod))
472 instantiatedWith)
473 put abiHash
474 put (map toStringRep depends)
475 put (map (\(k,v) -> (toStringRep k, v)) abiDepends)
476 put importDirs
477 put hsLibraries
478 put extraLibraries
479 put extraGHCiLibraries
480 put libraryDirs
481 put libraryDynDirs
482 put frameworks
483 put frameworkDirs
484 put ldOptions
485 put ccOptions
486 put includes
487 put includeDirs
488 put haddockInterfaces
489 put haddockHTMLs
490 put (map (\(mod_name, mb_mod) -> (toStringRep mod_name, fmap toDbModule mb_mod))
491 exposedModules)
492 put (map toStringRep hiddenModules)
493 put indefinite
494 put exposed
495 put trusted
496
497 get = do
498 sourcePackageId <- get
499 packageName <- get
500 packageVersion <- get
501 sourceLibName <- get
502 unitId <- get
503 componentId <- get
504 instantiatedWith <- get
505 abiHash <- get
506 depends <- get
507 abiDepends <- get
508 importDirs <- get
509 hsLibraries <- get
510 extraLibraries <- get
511 extraGHCiLibraries <- get
512 libraryDirs <- get
513 libraryDynDirs <- get
514 frameworks <- get
515 frameworkDirs <- get
516 ldOptions <- get
517 ccOptions <- get
518 includes <- get
519 includeDirs <- get
520 haddockInterfaces <- get
521 haddockHTMLs <- get
522 exposedModules <- get
523 hiddenModules <- get
524 indefinite <- get
525 exposed <- get
526 trusted <- get
527 return (InstalledPackageInfo
528 (fromStringRep unitId)
529 (fromStringRep componentId)
530 (map (\(mod_name, mod) -> (fromStringRep mod_name, fromDbModule mod))
531 instantiatedWith)
532 (fromStringRep sourcePackageId)
533 (fromStringRep packageName) packageVersion
534 (fmap fromStringRep sourceLibName)
535 abiHash
536 (map fromStringRep depends)
537 (map (\(k,v) -> (fromStringRep k, v)) abiDepends)
538 importDirs
539 hsLibraries extraLibraries extraGHCiLibraries
540 libraryDirs libraryDynDirs
541 frameworks frameworkDirs
542 ldOptions ccOptions
543 includes includeDirs
544 haddockInterfaces haddockHTMLs
545 (map (\(mod_name, mb_mod) ->
546 (fromStringRep mod_name, fmap fromDbModule mb_mod))
547 exposedModules)
548 (map fromStringRep hiddenModules)
549 indefinite exposed trusted)
550
551 instance (BinaryStringRep modulename, BinaryStringRep compid,
552 BinaryStringRep instunitid,
553 DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
554 Binary (DbModule instunitid compid unitid modulename mod) where
555 put (DbModule dbModuleUnitId dbModuleName) = do
556 putWord8 0
557 put (toDbUnitId dbModuleUnitId)
558 put (toStringRep dbModuleName)
559 put (DbModuleVar dbModuleVarName) = do
560 putWord8 1
561 put (toStringRep dbModuleVarName)
562 get = do
563 b <- getWord8
564 case b of
565 0 -> do dbModuleUnitId <- get
566 dbModuleName <- get
567 return (DbModule (fromDbUnitId dbModuleUnitId)
568 (fromStringRep dbModuleName))
569 _ -> do dbModuleVarName <- get
570 return (DbModuleVar (fromStringRep dbModuleVarName))
571
572 instance (BinaryStringRep modulename, BinaryStringRep compid,
573 BinaryStringRep instunitid,
574 DbUnitIdModuleRep instunitid compid unitid modulename mod) =>
575 Binary (DbUnitId instunitid compid unitid modulename mod) where
576 put (DbInstalledUnitId instunitid) = do
577 putWord8 0
578 put (toStringRep instunitid)
579 put (DbUnitId dbUnitIdComponentId dbUnitIdInsts) = do
580 putWord8 1
581 put (toStringRep dbUnitIdComponentId)
582 put (map (\(mod_name, mod) -> (toStringRep mod_name, toDbModule mod)) dbUnitIdInsts)
583 get = do
584 b <- getWord8
585 case b of
586 0 -> do
587 instunitid <- get
588 return (DbInstalledUnitId (fromStringRep instunitid))
589 _ -> do
590 dbUnitIdComponentId <- get
591 dbUnitIdInsts <- get
592 return (DbUnitId
593 (fromStringRep dbUnitIdComponentId)
594 (map (\(mod_name, mod) -> ( fromStringRep mod_name
595 , fromDbModule mod))
596 dbUnitIdInsts))