IndexUtils.hs 25.9 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
{-# LANGUAGE RecordWildCards #-}
3
{-# LANGUAGE BangPatterns #-}
Edsko de Vries's avatar
Edsko de Vries committed
4
{-# LANGUAGE GADTs #-}
5
6
-----------------------------------------------------------------------------
-- |
7
-- Module      :  Distribution.Client.IndexUtils
8
9
10
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
Duncan Coutts's avatar
Duncan Coutts committed
11
-- Maintainer  :  duncan@community.haskell.org
12
13
14
15
16
-- Stability   :  provisional
-- Portability :  portable
--
-- Extra utils related to the package indexes.
-----------------------------------------------------------------------------
17
module Distribution.Client.IndexUtils (
18
  getIndexFileAge,
19
  getInstalledPackages,
20
  Configure.getInstalledPackagesMonitorFiles,
21
  getSourcePackages,
22
  getSourcePackagesMonitorFiles,
23

24
  Index(..),
25
  PackageEntry(..),
26
27
  parsePackageIndex,
  updateRepoIndexCache,
28
  updatePackageIndexCacheFile,
29
  readCacheStrict,
30
31

  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
32
33
  ) where

34
35
36
import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
Duncan Coutts's avatar
Duncan Coutts committed
37
import qualified Distribution.Client.Tar as Tar
38
import Distribution.Client.Types
39

40
import Distribution.Package
41
         ( PackageId, PackageIdentifier(..), PackageName(..)
42
         , Package(..), packageVersion, packageName
43
         , Dependency(Dependency) )
44
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
45
import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse
46
47
import Distribution.PackageDescription
         ( GenericPackageDescription )
48
import Distribution.PackageDescription.Parse
49
         ( parsePackageDescription )
50
51
52
import Distribution.Simple.Compiler
         ( Compiler, PackageDBStack )
import Distribution.Simple.Program
53
         ( ProgramDb )
54
import qualified Distribution.Simple.Configure as Configure
55
         ( getInstalledPackages, getInstalledPackagesMonitorFiles )
56
57
import Distribution.ParseUtils
         ( ParseResult(..) )
58
import Distribution.Version
59
         ( Version(Version), intersectVersionRanges )
60
import Distribution.Text
61
         ( display, simpleParse )
62
import Distribution.Verbosity
63
         ( Verbosity, normal, lessVerbose )
64
import Distribution.Simple.Utils
65
         ( die, warn, info, fromUTF8, ignoreBOM )
Edsko de Vries's avatar
Edsko de Vries committed
66
67
import Distribution.Client.Setup
         ( RepoContext(..) )
68

69
70
71
72
import           Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import           Distribution.Solver.Types.SourcePackage

73
import Data.Char   (isAlphaNum)
74
import Data.Maybe  (mapMaybe, catMaybes, maybeToList)
75
import Data.List   (isPrefixOf)
76
#if !MIN_VERSION_base(4,8,0)
77
import Data.Monoid (Monoid(..))
78
#endif
79
import qualified Data.Map as Map
Łukasz Dąbek's avatar
Łukasz Dąbek committed
80
import Control.Monad (when, liftM)
81
import Control.Exception (evaluate)
82
83
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
84
import qualified Data.ByteString.Char8 as BSS
85
import Data.ByteString.Lazy (ByteString)
86
import Distribution.Client.GZipUtils (maybeDecompress)
87
88
import Distribution.Client.Utils ( byteStringToFilePath
                                 , tryFindAddSourcePackageDesc )
89
import Distribution.Compat.Exception (catchIO)
90
import Distribution.Compat.Time (getFileAge, getModTime)
91
import System.Directory (doesFileExist, doesDirectoryExist)
Edsko de Vries's avatar
Edsko de Vries committed
92
93
import System.FilePath
         ( (</>), takeExtension, replaceExtension, splitDirectories, normalise )
94
95
import System.FilePath.Posix as FilePath.Posix
         ( takeFileName )
96
import System.IO
97
import System.IO.Unsafe (unsafeInterleaveIO)
98
99
import System.IO.Error (isDoesNotExistError)

Edsko de Vries's avatar
Edsko de Vries committed
100
101
import qualified Hackage.Security.Client    as Sec
import qualified Hackage.Security.Util.Some as Sec
102

bardur.arantsson's avatar
bardur.arantsson committed
103
-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
104
getInstalledPackages :: Verbosity -> Compiler
105
                     -> PackageDBStack -> ProgramDb
106
                     -> IO InstalledPackageIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
107
108
getInstalledPackages verbosity comp packageDbs progdb =
    Configure.getInstalledPackages verbosity' comp packageDbs progdb
109
  where
110
111
    verbosity'  = lessVerbose verbosity

112
113
114
------------------------------------------------------------------------
-- Reading the source package index
--
115

116
117
118
-- | Read a repository index from disk, from the local files specified by
-- a list of 'Repo's.
--
119
-- All the 'SourcePackage's are marked as having come from the appropriate
120
121
122
-- 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
Edsko de Vries's avatar
Edsko de Vries committed
123
124
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages verbosity repoCtxt | null (repoContextRepos repoCtxt) = do
125
126
  warn verbosity $ "No remote package servers have been specified. Usually "
                ++ "you would have one specified in the config file."
127
  return SourcePackageDb {
128
129
130
    packageIndex       = mempty,
    packagePreferences = mempty
  }
Edsko de Vries's avatar
Edsko de Vries committed
131
getSourcePackages verbosity repoCtxt = do
132
  info verbosity "Reading available packages..."
Edsko de Vries's avatar
Edsko de Vries committed
133
  pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)
134
  let (pkgs, prefs) = mconcat pkgss
Duncan Coutts's avatar
Duncan Coutts committed
135
      prefs' = Map.fromListWith intersectVersionRanges
136
                 [ (name, range) | Dependency name range <- prefs ]
137
138
  _ <- evaluate pkgs
  _ <- evaluate prefs'
139
  return SourcePackageDb {
140
141
142
    packageIndex       = pkgs,
    packagePreferences = prefs'
  }
143

144
145
146
147
148
149
150
readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])
readCacheStrict verbosity index mkPkg = do
    updateRepoIndexCache verbosity index
    cache <- liftM readIndexCache $ BSS.readFile (cacheFile index)
    withFile (indexFile index) ReadMode $ \indexHnd ->
      packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict

151
152
153
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
154
-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
155
156
157
--
-- This is a higher level wrapper used internally in cabal-install.
--
Edsko de Vries's avatar
Edsko de Vries committed
158
readRepoIndex :: Verbosity -> RepoContext -> Repo
159
              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency])
Edsko de Vries's avatar
Edsko de Vries committed
160
readRepoIndex verbosity repoCtxt repo =
161
  handleNotFound $ do
162
    warnIfIndexIsOld =<< getIndexFileAge repo
Edsko de Vries's avatar
Edsko de Vries committed
163
164
    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
    readPackageIndexCacheFile mkAvailablePackage (RepoIndex repoCtxt repo)
Duncan Coutts's avatar
Duncan Coutts committed
165

166
  where
167
    mkAvailablePackage pkgEntry =
168
      SourcePackage {
169
        packageInfoId      = pkgid,
170
171
        packageDescription = packageDesc pkgEntry,
        packageSource      = case pkgEntry of
172
173
          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing
          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path,
174
175
176
        packageDescrOverride = case pkgEntry of
          NormalPackage _ _ pkgtxt _ -> Just pkgtxt
          _                          -> Nothing
177
      }
178
179
      where
        pkgid = packageId pkgEntry
180

refold's avatar
refold committed
181
    handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
182
      then do
Edsko de Vries's avatar
Edsko de Vries committed
183
        case repo of
Edsko de Vries's avatar
Edsko de Vries committed
184
185
186
          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
          RepoLocal{..}  -> warn verbosity $
Edsko de Vries's avatar
Edsko de Vries committed
187
               "The package list for the local repo '" ++ repoLocalDir
188
189
190
191
            ++ "' is missing. The repo is invalid."
        return mempty
      else ioError e

192
    isOldThreshold = 15 --days
193
    warnIfIndexIsOld dt = do
Edsko de Vries's avatar
Edsko de Vries committed
194
      when (dt >= isOldThreshold) $ case repo of
Edsko de Vries's avatar
Edsko de Vries committed
195
196
197
198
199
200
201
202
203
204
205
        RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
        RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
        RepoLocal{..}  -> return ()

    errMissingPackageList repoRemote =
         "The package list for '" ++ remoteRepoName repoRemote
      ++ "' does not exist. Run 'cabal update' to download it."
    errOutdatedPackageList repoRemote dt =
         "The package list for '" ++ remoteRepoName repoRemote
      ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
      ++ "'cabal update' to get the latest list of available packages."
206
207
208
209
210

-- | Return the age of the index file in days (as a Double).
getIndexFileAge :: Repo -> IO Double
getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar"

211
212
213
214
215
216
217
-- | A set of files (or directories) that can be monitored to detect when
-- there might have been a change in the source packages.
--
getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
getSourcePackagesMonitorFiles repos =
    [ repoLocalDir repo </> "00-index.cache"
    | repo <- repos ]
218

219
220
221
-- | It is not necessary to call this, as the cache will be updated when the
-- index is read normally. However you can do the work earlier if you like.
--
222
223
224
225
226
227
228
229
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache verbosity index =
    whenCacheOutOfDate index $ do
      updatePackageIndexCacheFile verbosity index

whenCacheOutOfDate :: Index -> IO () -> IO ()
whenCacheOutOfDate index action = do
  exists <- doesFileExist $ cacheFile index
230
231
232
  if not exists
    then action
    else do
233
234
235
      indexTime <- getModTime $ indexFile index
      cacheTime <- getModTime $ cacheFile index
      when (indexTime > cacheTime) action
236
237
238
239

------------------------------------------------------------------------
-- Reading the index file
--
240

241
-- | An index entry is either a normal package, or a local build tree reference.
refold's avatar
refold committed
242
243
data PackageEntry =
  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
  | BuildTreeRef BuildTreeRefType
                 PackageId GenericPackageDescription FilePath   BlockNo

-- | A build tree reference is either a link or a snapshot.
data BuildTreeRefType = SnapshotRef | LinkRef
                      deriving Eq

refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType
refTypeFromTypeCode t
  | t == Tar.buildTreeRefTypeCode      = LinkRef
  | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef
  | otherwise                          =
    error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"

typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode
typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode
typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode
261
262

instance Package PackageEntry where
263
264
  packageId (NormalPackage  pkgid _ _ _) = pkgid
  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
265
266

packageDesc :: PackageEntry -> GenericPackageDescription
267
268
packageDesc (NormalPackage  _ descr _ _) = descr
packageDesc (BuildTreeRef _ _ descr _ _) = descr
269

270
271
272
-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
--
Łukasz Dąbek's avatar
Łukasz Dąbek committed
273
274
275

data PackageOrDep = Pkg PackageEntry | Dep Dependency

276
277
278
279
280
281
282
283
284
285
-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files
--
-- We read the index using 'Tar.read', which gives us a lazily constructed
-- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',
-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a
-- function over this to translate it to a list of IO actions returning
-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of
-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.
parsePackageIndex :: ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read
286
  where
287
    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
Łukasz Dąbek's avatar
Łukasz Dąbek committed
288
    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
289
290
      where
        tryExtractPkg = do
Łukasz Dąbek's avatar
Łukasz Dąbek committed
291
          mkPkgEntry <- maybeToList $ extractPkg entry blockNo
292
          return $ fmap (fmap Pkg) mkPkgEntry
293
294

        tryExtractPrefs = do
295
          prefs' <- maybeToList $ extractPrefs entry
296
          fmap (return . Just . Dep) prefs'
297

298
299
300
301
302
-- | Turn the 'Entries' data structure from the @tar@ package into a list,
-- and pair each entry with its block number.
--
-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read
-- as far as the list is evaluated.
303
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
304
305
tarEntriesList = go 0
  where
306
    go !_ Tar.Done         = []
307
308
    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)
    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
309
310

extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
311
extractPkg entry blockNo = case Tar.entryContent entry of
312
313
314
315
  Tar.NormalFile content _
     | takeExtension fileName == ".cabal"
    -> case splitDirectories (normalise fileName) of
        [pkgname,vers,_] -> case simpleParse vers of
316
          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
317
318
            where
              pkgid  = PackageIdentifier (PackageName pkgname) ver
319
              parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack
320
321
322
323
324
325
                                               $ content
              descr  = case parsed of
                ParseOk _ d -> d
                _           -> error $ "Couldn't read cabal file "
                                    ++ show fileName
          _ -> Nothing
326
        _ -> Nothing
327
328

  Tar.OtherEntryType typeCode content _
329
    | Tar.isBuildTreeRefTypeCode typeCode ->
330
      Just $ do
331
332
333
334
335
336
337
338
339
        let path = byteStringToFilePath content
        dirExists <- doesDirectoryExist path
        result <- if not dirExists then return Nothing
                  else do
                    cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index."
                    descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile
                    return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)
                                                 descr path blockNo
        return result
340

341
  _ -> Nothing
342

343
  where
344
    fileName = Tar.entryPath entry
345

346
extractPrefs :: Tar.Entry -> Maybe [Dependency]
347
348
extractPrefs entry = case Tar.entryContent entry of
  Tar.NormalFile content _
349
     | takeFileName entrypath == "preferred-versions"
350
    -> Just prefs
351
352
    where
      entrypath = Tar.entryPath entry
353
      prefs     = parsePreferredVersions content
354
355
  _ -> Nothing

356
parsePreferredVersions :: ByteString -> [Dependency]
EyalLotem's avatar
EyalLotem committed
357
parsePreferredVersions = mapMaybe simpleParse
358
359
                       . filter (not . isPrefixOf "--")
                       . lines
360
                       . BS.Char8.unpack -- TODO: Are we sure no unicode?
361
362
363
364
365

------------------------------------------------------------------------
-- Reading and updating the index cache
--

366
367
368
369
370
-- | Variation on 'sequence' which evaluates the actions lazily
--
-- Pattern matching on the result list will execute just the first action;
-- more generally pattern matching on the first @n@ '(:)' nodes will execute
-- the first @n@ actions.
Łukasz Dąbek's avatar
Łukasz Dąbek committed
371
lazySequence :: [IO a] -> IO [a]
372
373
374
375
376
377
lazySequence = unsafeInterleaveIO . go
  where
    go []     = return []
    go (x:xs) = do x'  <- x
                   xs' <- lazySequence xs
                   return (x' : xs')
Łukasz Dąbek's avatar
Łukasz Dąbek committed
378

379
380
-- | Which index do we mean?
data Index =
Edsko de Vries's avatar
Edsko de Vries committed
381
    -- | The main index for the specified repository
Edsko de Vries's avatar
Edsko de Vries committed
382
    RepoIndex RepoContext Repo
383

Edsko de Vries's avatar
Edsko de Vries committed
384
385
386
    -- | A sandbox-local repository
    -- Argument is the location of the index file
  | SandboxIndex FilePath
387
388

indexFile :: Index -> FilePath
Edsko de Vries's avatar
Edsko de Vries committed
389
390
indexFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.tar"
indexFile (SandboxIndex index)   = index
391
392

cacheFile :: Index -> FilePath
Edsko de Vries's avatar
Edsko de Vries committed
393
394
cacheFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"
395
396
397
398

updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
    info verbosity ("Updating index cache file " ++ cacheFile index)
399
400
401
402
403
404
405
406
407
408
409
    withIndexEntries index $ \entries -> do
      let cache = Cache { cacheEntries = entries }
      writeFile (cacheFile index) (showIndexCache cache)

-- | Read the index (for the purpose of building a cache)
--
-- The callback is provided with list of cache entries, which is guaranteed to
-- be lazily constructed. This list must ONLY be used in the scope of the
-- callback; when the callback is terminated the file handle to the index will
-- be closed and further attempts to read from the list will result in (pure)
-- I/O exceptions.
Edsko de Vries's avatar
Edsko de Vries committed
410
411
412
413
414
415
416
417
418
419
420
421
422
--
-- In the construction of the index for a secure repo we take advantage of the
-- index built by the @hackage-security@ library to avoid reading the @.tar@
-- file as much as possible (we need to read it only to extract preferred
-- versions). This helps performance, but is also required for correctness:
-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions
-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);
-- by reading the already-built cache from the security library we will be sure
-- to only read the latest versions of all files.
--
-- TODO: It would be nicer if we actually incrementally updated @cabal@'s
-- cache, rather than reconstruct it from zero on each update. However, this
-- would require a change in the cache format.
423
withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a
Edsko de Vries's avatar
Edsko de Vries committed
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =
    repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
      Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
        let mk :: (Sec.DirectoryEntry, fp, Maybe (Sec.Some Sec.IndexFile))
               -> IO [IndexCacheEntry]
            mk (_, _fp, Nothing) =
              return [] -- skip unrecognized file
            mk (_, _fp, Just (Sec.Some (Sec.IndexPkgMetadata _pkgId))) =
              return [] -- skip metadata
            mk (dirEntry, _fp, Just (Sec.Some (Sec.IndexPkgCabal pkgId))) = do
              let blockNo = fromIntegral (Sec.directoryEntryBlockNo dirEntry)
              return [CachePackageId pkgId blockNo]
            mk (dirEntry, _fp, Just (Sec.Some file@(Sec.IndexPkgPrefs _pkgName))) = do
              content <- Sec.indexEntryContent `fmap` indexLookupFileEntry dirEntry file
              return $ map CachePreference (parsePreferredVersions content)
        entriess <- lazySequence $ map mk (Sec.directoryEntries indexDirectory)
        callback $ concat entriess
441
442
443
444
445
withIndexEntries index callback = do
    withFile (indexFile index) ReadMode $ \h -> do
      bs          <- maybeDecompress `fmap` BS.hGetContents h
      pkgsOrPrefs <- lazySequence $ parsePackageIndex bs
      callback $ map toCache (catMaybes pkgsOrPrefs)
446
  where
447
    toCache :: PackageOrDep -> IndexCacheEntry
Łukasz Dąbek's avatar
Łukasz Dąbek committed
448
449
450
    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo
    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
    toCache (Dep d) = CachePreference d
451

452
453
454
data ReadPackageIndexMode = ReadPackageIndexStrict
                          | ReadPackageIndexLazyIO

455
readPackageIndexCacheFile :: Package pkg
456
                          => (PackageEntry -> pkg)
457
                          -> Index
458
                          -> IO (PackageIndex pkg, [Dependency])
Edsko de Vries's avatar
Edsko de Vries committed
459
readPackageIndexCacheFile mkPkg index = do
460
  cache    <- liftM readIndexCache $ BSS.readFile (cacheFile index)
Edsko de Vries's avatar
Edsko de Vries committed
461
462
  indexHnd <- openFile (indexFile index) ReadMode
  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO
463
464

packageIndexFromCache :: Package pkg
465
                      => (PackageEntry -> pkg)
466
                      -> Handle
467
                      -> Cache
468
                      -> ReadPackageIndexMode
469
                      -> IO (PackageIndex pkg, [Dependency])
470
471
472
473
474
475
476
packageIndexFromCache mkPkg hnd cache mode = do
     (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode
     pkgIndex <- evaluate $ PackageIndex.fromList pkgs
     return (pkgIndex, prefs)

-- | Read package list
--
477
478
479
480
481
482
483
-- The result package releases and preference entries are guaranteed
-- to be unique.
--
-- Note: 01-index.tar is an append-only index and therefore contains
-- all .cabal edits and preference-updates. The masking happens
-- here, i.e. the semantics that later entries in a tar file mask
-- earlier ones is resolved in this function.
484
485
486
487
488
packageListFromCache :: (PackageEntry -> pkg)
                     -> Handle
                     -> Cache
                     -> ReadPackageIndexMode
                     -> IO ([pkg], [Dependency])
489
packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries
490
  where
491
    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
492

493
    accum srcpkgs btrs prefs (CachePackageId pkgid blockno : entries) = do
494
495
496
497
      -- Given the cache entry, make a package index entry.
      -- The magic here is that we use lazy IO to read the .cabal file
      -- from the index tarball if it turns out that we need it.
      -- Most of the time we only need the package id.
498
499
500
501
      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
        pkgtxt <- getEntryContent blockno
        pkg    <- readPackageDescription pkgtxt
        return (pkg, pkgtxt)
502
503
504
505
506
507
      let srcpkg = case mode of
            ReadPackageIndexLazyIO ->
              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
            ReadPackageIndexStrict ->
              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg
                                            pkgtxt blockno)
508
      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
509

510
    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
511
512
513
      -- We have to read the .cabal file eagerly here because we can't cache the
      -- package id for build tree references - the user might edit the .cabal
      -- file after the reference was added to the index.
514
      path <- liftM byteStringToFilePath . getEntryContent $ blockno
515
516
517
      pkg  <- do let err = "Error reading package index from cache."
                 file <- tryFindAddSourcePackageDesc path err
                 PackageDesc.Parse.readPackageDescription normal file
518
      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
519
      accum srcpkgs (srcpkg:btrs) prefs entries
520

521
522
    accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _) : entries) =
      accum srcpkgs btrs (Map.insert pn pref prefs) entries
523

524
525
    getEntryContent :: BlockNo -> IO ByteString
    getEntryContent blockno = do
526
527
528
529
530
531
532
      entry <- Tar.hReadEntry hnd blockno
      case Tar.entryContent entry of
        Tar.NormalFile content _size -> return content
        Tar.OtherEntryType typecode content _size
          | Tar.isBuildTreeRefTypeCode typecode
          -> return content
        _ -> interror "unexpected tar entry type"
533

534
    readPackageDescription :: ByteString -> IO GenericPackageDescription
535
    readPackageDescription content =
536
      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of
537
538
539
540
541
542
543
544
545
546
547
548
549
550
        ParseOk _ d -> return d
        _           -> interror "failed to parse .cabal file"

    interror msg = die $ "internal error when reading package index: " ++ msg
                      ++ "The package index or index cache is probably "
                      ++ "corrupt. Running cabal update might fix it."

------------------------------------------------------------------------
-- Index cache data structure
--

-- | Tar files are block structured with 512 byte blocks. Every header and file
-- content starts on a block boundary.
--
551
type BlockNo = Tar.TarEntryOffset
552
553

data IndexCacheEntry = CachePackageId PackageId BlockNo
554
                     | CacheBuildTreeRef BuildTreeRefType BlockNo
refold's avatar
refold committed
555
                     | CachePreference Dependency
556
  deriving (Eq)
557

558
559
packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
packageKey = "pkg:"
560
561
562
563
blocknoKey = "b#"
buildTreeRefKey     = "build-tree-ref:"
preferredVersionKey = "pref-ver:"

564
565
566
567
readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
readIndexCacheEntry = \line ->
  case BSS.words line of
    [key, pkgnamestr, pkgverstr, sep, blocknostr]
568
      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->
refold's avatar
refold committed
569
570
      case (parseName pkgnamestr, parseVer pkgverstr [],
            parseBlockNo blocknostr) of
571
572
573
        (Just pkgname, Just pkgver, Just blockno)
          -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)
        _ -> Nothing
574
    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
575
576
577
578
579
      case (parseRefType typecodestr, parseBlockNo blocknostr) of
        (Just refType, Just blockno)
          -> Just (CacheBuildTreeRef refType blockno)
        _ -> Nothing

580
    (key: remainder) | key == BSS.pack preferredVersionKey ->
refold's avatar
refold committed
581
      fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))
582
    _  -> Nothing
583
  where
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
    parseName str
      | BSS.all (\c -> isAlphaNum c || c == '-') str
                  = Just (PackageName (BSS.unpack str))
      | otherwise = Nothing

    parseVer str vs =
      case BSS.readInt str of
        Nothing        -> Nothing
        Just (v, str') -> case BSS.uncons str' of
          Just ('.', str'') -> parseVer str'' (v:vs)
          Just _            -> Nothing
          Nothing           -> Just (Version (reverse (v:vs)) [])

    parseBlockNo str =
      case BSS.readInt str of
599
600
601
        Just (blockno, remainder)
          | BSS.null remainder -> Just (fromIntegral blockno)
        _                      -> Nothing
602

603
604
605
606
607
608
609
    parseRefType str =
      case BSS.uncons str of
        Just (typeCode, remainder)
          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode
            -> Just (refTypeFromTypeCode typeCode)
        _   -> Nothing

610
showIndexCacheEntry :: IndexCacheEntry -> String
611
showIndexCacheEntry entry = unwords $ case entry of
612
   CachePackageId pkgid b -> [ packageKey
613
614
615
616
617
618
619
620
621
622
623
624
                             , display (packageName pkgid)
                             , display (packageVersion pkgid)
                             , blocknoKey
                             , show b
                             ]
   CacheBuildTreeRef t b  -> [ buildTreeRefKey
                             , [typeCodeFromRefType t]
                             , show b
                             ]
   CachePreference dep    -> [ preferredVersionKey
                             , display dep
                             ]
625

626
627
628
629
630
631
632
633
634
-- | Cabal caches various information about the Hackage index
data Cache = Cache {
    cacheEntries :: [IndexCacheEntry]
  }

readIndexCache :: BSS.ByteString -> Cache
readIndexCache bs = Cache {
    cacheEntries = mapMaybe readIndexCacheEntry $ BSS.lines bs
  }
635

636
637
showIndexCache :: Cache -> String
showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries