IndexUtils.hs 25.8 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.Client.PackageIndex (PackageIndex)
refold's avatar
refold committed
45
import qualified Distribution.Client.PackageIndex      as PackageIndex
46
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
47
import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse
48
49
import Distribution.PackageDescription
         ( GenericPackageDescription )
50
import Distribution.PackageDescription.Parse
51
         ( parsePackageDescription )
52
53
54
55
56
import Distribution.Simple.Compiler
         ( Compiler, PackageDBStack )
import Distribution.Simple.Program
         ( ProgramConfiguration )
import qualified Distribution.Simple.Configure as Configure
57
         ( getInstalledPackages, getInstalledPackagesMonitorFiles )
58
59
import Distribution.ParseUtils
         ( ParseResult(..) )
60
import Distribution.Version
61
         ( Version(Version), intersectVersionRanges )
62
import Distribution.Text
63
         ( display, simpleParse )
64
import Distribution.Verbosity
65
         ( Verbosity, normal, lessVerbose )
66
import Distribution.Simple.Utils
67
         ( die, warn, info, fromUTF8, ignoreBOM )
Edsko de Vries's avatar
Edsko de Vries committed
68
69
import Distribution.Client.Setup
         ( RepoContext(..) )
70

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

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

bardur.arantsson's avatar
bardur.arantsson committed
101
-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
102
103
getInstalledPackages :: Verbosity -> Compiler
                     -> PackageDBStack -> ProgramConfiguration
104
                     -> IO InstalledPackageIndex
105
getInstalledPackages verbosity comp packageDbs conf =
106
    Configure.getInstalledPackages verbosity' comp packageDbs conf
107
  where
108
109
    verbosity'  = lessVerbose verbosity

110
111
112
------------------------------------------------------------------------
-- Reading the source package index
--
113

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

142
143
144
145
146
147
148
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

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

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

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

190
    isOldThreshold = 15 --days
191
    warnIfIndexIsOld dt = do
Edsko de Vries's avatar
Edsko de Vries committed
192
      when (dt >= isOldThreshold) $ case repo of
Edsko de Vries's avatar
Edsko de Vries committed
193
194
195
196
197
198
199
200
201
202
203
        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."
204
205
206
207
208

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

209
210
211
212
213
214
215
-- | 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 ]
216

217
218
219
-- | 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.
--
220
221
222
223
224
225
226
227
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
228
229
230
  if not exists
    then action
    else do
231
232
233
      indexTime <- getModTime $ indexFile index
      cacheTime <- getModTime $ cacheFile index
      when (indexTime > cacheTime) action
234
235
236
237

------------------------------------------------------------------------
-- Reading the index file
--
238

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

instance Package PackageEntry where
261
262
  packageId (NormalPackage  pkgid _ _ _) = pkgid
  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
263
264

packageDesc :: PackageEntry -> GenericPackageDescription
265
266
packageDesc (NormalPackage  _ descr _ _) = descr
packageDesc (BuildTreeRef _ _ descr _ _) = descr
267

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

data PackageOrDep = Pkg PackageEntry | Dep Dependency

274
275
276
277
278
279
280
281
282
283
-- | 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
284
  where
285
    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
Łukasz Dąbek's avatar
Łukasz Dąbek committed
286
    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
287
288
      where
        tryExtractPkg = do
Łukasz Dąbek's avatar
Łukasz Dąbek committed
289
          mkPkgEntry <- maybeToList $ extractPkg entry blockNo
290
          return $ fmap (fmap Pkg) mkPkgEntry
291
292

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

296
297
298
299
300
-- | 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.
301
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
302
303
tarEntriesList = go 0
  where
304
    go !_ Tar.Done         = []
305
306
    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)
    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
307
308

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

  Tar.OtherEntryType typeCode content _
327
    | Tar.isBuildTreeRefTypeCode typeCode ->
328
      Just $ do
329
330
331
332
333
334
335
336
337
        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
338

339
  _ -> Nothing
340

341
  where
342
    fileName = Tar.entryPath entry
343

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

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

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

364
365
366
367
368
-- | 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
369
lazySequence :: [IO a] -> IO [a]
370
371
372
373
374
375
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
376

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

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

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

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

updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
    info verbosity ("Updating index cache file " ++ cacheFile index)
397
398
399
400
401
402
403
404
405
406
407
    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
408
409
410
411
412
413
414
415
416
417
418
419
420
--
-- 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.
421
withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a
Edsko de Vries's avatar
Edsko de Vries committed
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
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
439
440
441
442
443
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)
444
  where
445
    toCache :: PackageOrDep -> IndexCacheEntry
Łukasz Dąbek's avatar
Łukasz Dąbek committed
446
447
448
    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo
    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
    toCache (Dep d) = CachePreference d
449

450
451
452
data ReadPackageIndexMode = ReadPackageIndexStrict
                          | ReadPackageIndexLazyIO

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

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

-- | Read package list
--
475
476
477
478
479
480
481
-- 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.
482
483
484
485
486
packageListFromCache :: (PackageEntry -> pkg)
                     -> Handle
                     -> Cache
                     -> ReadPackageIndexMode
                     -> IO ([pkg], [Dependency])
487
packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries
488
  where
489
    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
490

491
    accum srcpkgs btrs prefs (CachePackageId pkgid blockno : entries) = do
492
493
494
495
      -- 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.
496
497
498
499
      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
        pkgtxt <- getEntryContent blockno
        pkg    <- readPackageDescription pkgtxt
        return (pkg, pkgtxt)
500
501
502
503
504
505
      let srcpkg = case mode of
            ReadPackageIndexLazyIO ->
              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
            ReadPackageIndexStrict ->
              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg
                                            pkgtxt blockno)
506
      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
507

508
    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
509
510
511
      -- 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.
512
      path <- liftM byteStringToFilePath . getEntryContent $ blockno
513
514
515
      pkg  <- do let err = "Error reading package index from cache."
                 file <- tryFindAddSourcePackageDesc path err
                 PackageDesc.Parse.readPackageDescription normal file
516
      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
517
      accum srcpkgs (srcpkg:btrs) prefs entries
518

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

522
523
    getEntryContent :: BlockNo -> IO ByteString
    getEntryContent blockno = do
524
525
526
527
528
529
530
      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"
531

532
    readPackageDescription :: ByteString -> IO GenericPackageDescription
533
    readPackageDescription content =
534
      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of
535
536
537
538
539
540
541
542
543
544
545
546
547
548
        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.
--
549
type BlockNo = Tar.TarEntryOffset
550
551

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

556
557
installedUnitId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
installedUnitId = "pkg:"
558
559
560
561
blocknoKey = "b#"
buildTreeRefKey     = "build-tree-ref:"
preferredVersionKey = "pref-ver:"

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

578
    (key: remainder) | key == BSS.pack preferredVersionKey ->
refold's avatar
refold committed
579
      fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))
580
    _  -> Nothing
581
  where
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
    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
597
598
599
        Just (blockno, remainder)
          | BSS.null remainder -> Just (fromIntegral blockno)
        _                      -> Nothing
600

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

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

624
625
626
627
628
629
630
631
632
-- | 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
  }
633

634
635
showIndexCache :: Cache -> String
showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries