0ed508524bf9448d21ada0ee393366a65ebe4c50
[ghc.git] / libraries / bin-package-db / GHC / PackageDb.hs
1 {-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}
2 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
3 #if __GLASGOW_HASKELL__ >= 701
4 {-# LANGUAGE Trustworthy #-}
5 #endif
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : GHC.PackageDb
9 -- Copyright : (c) The University of Glasgow 2009, Duncan Coutts 2014
10 --
11 -- Maintainer : ghc-devs@haskell.org
12 -- Portability : portable
13 --
14 -- This module provides the view of GHC's database of registered packages that
15 -- is shared between GHC the compiler\/library, and the ghc-pkg program. It
16 -- defines the database format that is shared between GHC and ghc-pkg.
17 --
18 -- The database format, and this library are constructed so that GHC does not
19 -- have to depend on the Cabal library. The ghc-pkg program acts as the
20 -- gateway between the external package format (which is defined by Cabal) and
21 -- the internal package format which is specialised just for GHC.
22 --
23 -- GHC the compiler only needs some of the information which is kept about
24 -- registerd packages, such as module names, various paths etc. On the other
25 -- hand ghc-pkg has to keep all the information from Cabal packages and be able
26 -- to regurgitate it for users and other tools.
27 --
28 -- The first trick is that we duplicate some of the information in the package
29 -- database. We essentially keep two versions of the datbase in one file, one
30 -- version used only by ghc-pkg which keeps the full information (using the
31 -- serialised form of the 'InstalledPackageInfo' type defined by the Cabal
32 -- library); and a second version written by ghc-pkg and read by GHC which has
33 -- just the subset of information that GHC needs.
34 --
35 -- The second trick is that this module only defines in detail the format of
36 -- the second version -- the bit GHC uses -- and the part managed by ghc-pkg
37 -- is kept in the file but here we treat it as an opaque blob of data. That way
38 -- this library avoids depending on Cabal.
39 --
40 module GHC.PackageDb (
41 GhcPackageInfo(..),
42 readPackageDbForGhc,
43 readPackageDbForGhcPkg,
44 writePackageDb
45 ) where
46
47 import qualified Data.ByteString as BS
48 import qualified Data.ByteString.Char8 as BS.Char8
49 import qualified Data.ByteString.Lazy as BS.Lazy
50 import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)
51 import Data.Binary as Bin
52 import Data.Binary.Put as Bin
53 import Data.Binary.Get as Bin
54 import Control.Exception as Exception
55 import Control.Monad (when)
56 import System.FilePath
57 import System.IO
58 import System.IO.Error
59 import GHC.IO.Exception (IOErrorType(InappropriateType))
60 import System.Directory
61
62
63 -- | This is a subset of Cabal's 'InstalledPackageInfo', with just the bits
64 -- that GHC is interested in.
65 --
66 data GhcPackageInfo = GhcPackageInfo {
67 --TODO
68 }
69 deriving (Eq, Show)
70
71
72 -- | Read the part of the package DB that GHC is interested in.
73 --
74 readPackageDbForGhc :: FilePath -> IO [GhcPackageInfo]
75 readPackageDbForGhc file =
76 decodeFromFile file getDbForGhc
77 where
78 getDbForGhc = do
79 _version <- getHeader
80 _ghcPartLen <- get :: Get Word32
81 ghcPart <- get :: Get [GhcPackageInfo]
82 -- the next part is for ghc-pkg, but we stop here.
83 return ghcPart
84
85 -- | Read the part of the package DB that ghc-pkg is interested in
86 --
87 readPackageDbForGhcPkg :: Binary pkgs => FilePath -> IO pkgs
88 readPackageDbForGhcPkg file =
89 decodeFromFile file getDbForGhcPkg
90 where
91 getDbForGhcPkg = do
92 _version <- getHeader
93 -- skip over the ghc part
94 ghcPartLen <- get :: Get Word32
95 _ghcPart <- skip (fromIntegral ghcPartLen)
96 -- the next part is for ghc-pkg
97 ghcPkgPart <- get
98 return ghcPkgPart
99
100 -- | Write the whole of the package DB, both parts.
101 --
102 writePackageDb :: Binary pkgs => FilePath -> [GhcPackageInfo] -> pkgs -> IO ()
103 writePackageDb file ghcPkgs ghcPkgPart =
104 writeFileAtomic file (runPut putDbForGhcPkg)
105 where
106 putDbForGhcPkg = do
107 putHeader
108 put ghcPartLen
109 putLazyByteString ghcPart
110 put ghcPkgPart
111 where
112 ghcPartLen :: Word32
113 ghcPartLen = fromIntegral (BS.Lazy.length ghcPart)
114 ghcPart = encode ghcPkgs
115
116 getHeader :: Get (Word32, Word32)
117 getHeader = do
118 magic <- getByteString (BS.length headerMagic)
119 when (magic /= headerMagic) $
120 fail "not a ghc-pkg db file, wrong file magic number"
121
122 majorVersion <- get :: Get Word32
123 -- The major version is for incompatible changes
124
125 minorVersion <- get :: Get Word32
126 -- The minor version is for compatible extensions
127
128 when (majorVersion /= 1) $
129 fail "unsupported ghc-pkg db format version"
130 -- If we ever support multiple major versions then we'll have to change
131 -- this code
132
133 -- The header can be extended without incrementing the major version,
134 -- we ignore fields we don't know about (currently all).
135 headerExtraLen <- get :: Get Word32
136 skip (fromIntegral headerExtraLen)
137
138 return (majorVersion, minorVersion)
139
140 putHeader :: Put
141 putHeader = do
142 putByteString headerMagic
143 put majorVersion
144 put minorVersion
145 put headerExtraLen
146 where
147 majorVersion = 1 :: Word32
148 minorVersion = 0 :: Word32
149 headerExtraLen = 0 :: Word32
150
151 headerMagic :: BS.ByteString
152 headerMagic = BS.Char8.pack "\0ghcpkg\0"
153
154
155 -- | Feed a 'Get' decoder with data chunks from a file.
156 --
157 decodeFromFile :: FilePath -> Get a -> IO a
158 decodeFromFile file decoder =
159 withBinaryFile file ReadMode $ \hnd ->
160 feed hnd (runGetIncremental decoder)
161 where
162 feed hnd (Partial k) = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
163 if BS.null chunk
164 then feed hnd (k Nothing)
165 else feed hnd (k (Just chunk))
166 feed _ (Done _ _ result) = return result
167 feed _ (Fail _ _ msg) = ioError err
168 where
169 err = mkIOError InappropriateType loc Nothing (Just file)
170 `ioeSetErrorString` msg
171 loc = "GHC.PackageDb.readPackageDb"
172
173 writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
174 writeFileAtomic targetPath content = do
175 let (targetDir, targetName) = splitFileName targetPath
176 Exception.bracketOnError
177 (openBinaryTempFileWithDefaultPermissions targetDir $ targetName <.> "tmp")
178 (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
179 (\(tmpPath, handle) -> do
180 BS.Lazy.hPut handle content
181 hClose handle
182 #if mingw32_HOST_OS || mingw32_TARGET_OS
183 renameFile tmpPath targetPath
184 -- If the targetPath exists then renameFile will fail
185 `catchIO` \err -> do
186 exists <- doesFileExist targetPath
187 if exists
188 then do removeFile targetPath
189 -- Big fat hairy race condition
190 renameFile newFile targetPath
191 -- If the removeFile succeeds and the renameFile fails
192 -- then we've lost the atomic property.
193 else throwIOIO err
194 #else
195 renameFile tmpPath targetPath
196 #endif
197 )
198
199
200 instance Binary GhcPackageInfo where
201 put (GhcPackageInfo {-TODO-}) = do
202 return ()
203
204 get = do
205 return (GhcPackageInfo {-TODO-})
206