IndexUtils.hs 25.2 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
  getSourcePackages,
21

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

  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
30
31
  ) where

32
33
34
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
35
import qualified Distribution.Client.Tar as Tar
36
import Distribution.Client.Types
37

38
import Distribution.Package
39
         ( PackageId, PackageIdentifier(..), PackageName(..)
40
         , Package(..), packageVersion, packageName
41
         , Dependency(Dependency) )
42
import Distribution.Client.PackageIndex (PackageIndex)
refold's avatar
refold committed
43
import qualified Distribution.Client.PackageIndex      as PackageIndex
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
53
54
55
import Distribution.Simple.Compiler
         ( Compiler, PackageDBStack )
import Distribution.Simple.Program
         ( ProgramConfiguration )
import qualified Distribution.Simple.Configure as Configure
         ( getInstalledPackages )
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
import Data.Char   (isAlphaNum)
70
import Data.Maybe  (mapMaybe, catMaybes, maybeToList)
71
import Data.List   (isPrefixOf)
72
#if !MIN_VERSION_base(4,8,0)
73
import Data.Monoid (Monoid(..))
74
#endif
75
import qualified Data.Map as Map
Łukasz Dąbek's avatar
Łukasz Dąbek committed
76
import Control.Monad (when, liftM)
77
import Control.Exception (evaluate)
78
79
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
80
import qualified Data.ByteString.Char8 as BSS
81
import Data.ByteString.Lazy (ByteString)
82
import Distribution.Client.GZipUtils (maybeDecompress)
83
84
import Distribution.Client.Utils ( byteStringToFilePath
                                 , tryFindAddSourcePackageDesc )
85
import Distribution.Compat.Exception (catchIO)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
86
import Distribution.Client.Compat.Time (getFileAge, getModTime)
87
import System.Directory (doesFileExist, doesDirectoryExist)
Edsko de Vries's avatar
Edsko de Vries committed
88
89
import System.FilePath
         ( (</>), takeExtension, replaceExtension, splitDirectories, normalise )
90
91
import System.FilePath.Posix as FilePath.Posix
         ( takeFileName )
92
import System.IO
93
import System.IO.Unsafe (unsafeInterleaveIO)
94
95
import System.IO.Error (isDoesNotExistError)

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

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

108
109
110
------------------------------------------------------------------------
-- Reading the source package index
--
111

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

140
141
142
143
144
145
146
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

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

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

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

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

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


208
209
210
-- | 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.
--
211
212
213
214
215
216
217
218
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
219
220
221
  if not exists
    then action
    else do
222
223
224
      indexTime <- getModTime $ indexFile index
      cacheTime <- getModTime $ cacheFile index
      when (indexTime > cacheTime) action
225
226
227
228

------------------------------------------------------------------------
-- Reading the index file
--
229

230
-- | An index entry is either a normal package, or a local build tree reference.
refold's avatar
refold committed
231
232
data PackageEntry =
  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
  | 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
250
251

instance Package PackageEntry where
252
253
  packageId (NormalPackage  pkgid _ _ _) = pkgid
  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
254
255

packageDesc :: PackageEntry -> GenericPackageDescription
256
257
packageDesc (NormalPackage  _ descr _ _) = descr
packageDesc (BuildTreeRef _ _ descr _ _) = descr
258

259
260
261
-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
--
Łukasz Dąbek's avatar
Łukasz Dąbek committed
262
263
264

data PackageOrDep = Pkg PackageEntry | Dep Dependency

265
266
267
268
269
270
271
272
273
274
-- | 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
275
  where
276
    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
Łukasz Dąbek's avatar
Łukasz Dąbek committed
277
    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
278
279
      where
        tryExtractPkg = do
Łukasz Dąbek's avatar
Łukasz Dąbek committed
280
          mkPkgEntry <- maybeToList $ extractPkg entry blockNo
281
          return $ fmap (fmap Pkg) mkPkgEntry
282
283

        tryExtractPrefs = do
284
          prefs' <- maybeToList $ extractPrefs entry
285
          fmap (return . Just . Dep) prefs'
286

287
288
289
290
291
-- | 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.
292
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
293
294
tarEntriesList = go 0
  where
295
    go !_ Tar.Done         = []
296
297
    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)
    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
298
299

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

  Tar.OtherEntryType typeCode content _
318
    | Tar.isBuildTreeRefTypeCode typeCode ->
319
      Just $ do
320
321
322
323
324
325
326
327
328
        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
329

330
  _ -> Nothing
331

332
  where
333
    fileName = Tar.entryPath entry
334

335
extractPrefs :: Tar.Entry -> Maybe [Dependency]
336
337
extractPrefs entry = case Tar.entryContent entry of
  Tar.NormalFile content _
338
     | takeFileName entrypath == "preferred-versions"
339
    -> Just prefs
340
341
    where
      entrypath = Tar.entryPath entry
342
      prefs     = parsePreferredVersions content
343
344
  _ -> Nothing

345
parsePreferredVersions :: ByteString -> [Dependency]
EyalLotem's avatar
EyalLotem committed
346
parsePreferredVersions = mapMaybe simpleParse
347
348
                       . filter (not . isPrefixOf "--")
                       . lines
349
                       . BS.Char8.unpack -- TODO: Are we sure no unicode?
350
351
352
353
354

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

355
356
357
358
359
-- | 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
360
lazySequence :: [IO a] -> IO [a]
361
362
363
364
365
366
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
367

368
369
-- | Which index do we mean?
data Index =
Edsko de Vries's avatar
Edsko de Vries committed
370
    -- | The main index for the specified repository
Edsko de Vries's avatar
Edsko de Vries committed
371
    RepoIndex RepoContext Repo
372

Edsko de Vries's avatar
Edsko de Vries committed
373
374
375
    -- | A sandbox-local repository
    -- Argument is the location of the index file
  | SandboxIndex FilePath
376
377

indexFile :: Index -> FilePath
Edsko de Vries's avatar
Edsko de Vries committed
378
379
indexFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.tar"
indexFile (SandboxIndex index)   = index
380
381

cacheFile :: Index -> FilePath
Edsko de Vries's avatar
Edsko de Vries committed
382
383
cacheFile (RepoIndex _ctxt repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"
384
385
386
387

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

441
442
443
data ReadPackageIndexMode = ReadPackageIndexStrict
                          | ReadPackageIndexLazyIO

444
readPackageIndexCacheFile :: Package pkg
445
                          => (PackageEntry -> pkg)
446
                          -> Index
447
                          -> IO (PackageIndex pkg, [Dependency])
Edsko de Vries's avatar
Edsko de Vries committed
448
readPackageIndexCacheFile mkPkg index = do
449
  cache    <- liftM readIndexCache $ BSS.readFile (cacheFile index)
Edsko de Vries's avatar
Edsko de Vries committed
450
451
  indexHnd <- openFile (indexFile index) ReadMode
  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO
452
453

packageIndexFromCache :: Package pkg
454
                      => (PackageEntry -> pkg)
455
                      -> Handle
456
                      -> Cache
457
                      -> ReadPackageIndexMode
458
                      -> IO (PackageIndex pkg, [Dependency])
459
460
461
462
463
464
465
466
467
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
--
-- The result packages (though not the preferences) are guaranteed to be listed
-- in the same order as they are in the tar file (because later entries in a tar
-- file mask earlier ones).
packageListFromCache :: (PackageEntry -> pkg)
                     -> Handle
                     -> Cache
                     -> ReadPackageIndexMode
                     -> IO ([pkg], [Dependency])
packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries
475
  where
476
    accum srcpkgs prefs [] = return (reverse srcpkgs, prefs)
477
478
479
480
481
482

    accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do
      -- 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.
483
484
485
486
      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
        pkgtxt <- getEntryContent blockno
        pkg    <- readPackageDescription pkgtxt
        return (pkg, pkgtxt)
487
488
489
490
491
492
      let srcpkg = case mode of
            ReadPackageIndexLazyIO ->
              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
            ReadPackageIndexStrict ->
              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg
                                            pkgtxt blockno)
493
494
      accum (srcpkg:srcpkgs) prefs entries

495
    accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do
496
497
498
      -- 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.
499
      path <- liftM byteStringToFilePath . getEntryContent $ blockno
500
501
502
      pkg  <- do let err = "Error reading package index from cache."
                 file <- tryFindAddSourcePackageDesc path err
                 PackageDesc.Parse.readPackageDescription normal file
503
      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
504
505
      accum (srcpkg:srcpkgs) prefs entries

refold's avatar
refold committed
506
    accum srcpkgs prefs (CachePreference pref : entries) =
507
508
      accum srcpkgs (pref:prefs) entries

509
510
    getEntryContent :: BlockNo -> IO ByteString
    getEntryContent blockno = do
511
512
513
514
515
516
517
      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"
518

519
    readPackageDescription :: ByteString -> IO GenericPackageDescription
520
    readPackageDescription content =
521
      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of
522
523
524
525
526
527
528
529
530
531
532
533
534
535
        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.
--
536
type BlockNo = Tar.TarEntryOffset
537
538

data IndexCacheEntry = CachePackageId PackageId BlockNo
539
                     | CacheBuildTreeRef BuildTreeRefType BlockNo
refold's avatar
refold committed
540
                     | CachePreference Dependency
541
  deriving (Eq)
542

543
544
installedComponentId, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
installedComponentId = "pkg:"
545
546
547
548
blocknoKey = "b#"
buildTreeRefKey     = "build-tree-ref:"
preferredVersionKey = "pref-ver:"

549
550
551
552
readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
readIndexCacheEntry = \line ->
  case BSS.words line of
    [key, pkgnamestr, pkgverstr, sep, blocknostr]
553
      | key == BSS.pack installedComponentId && sep == BSS.pack blocknoKey ->
refold's avatar
refold committed
554
555
      case (parseName pkgnamestr, parseVer pkgverstr [],
            parseBlockNo blocknostr) of
556
557
558
        (Just pkgname, Just pkgver, Just blockno)
          -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)
        _ -> Nothing
559
    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
560
561
562
563
564
      case (parseRefType typecodestr, parseBlockNo blocknostr) of
        (Just refType, Just blockno)
          -> Just (CacheBuildTreeRef refType blockno)
        _ -> Nothing

565
    (key: remainder) | key == BSS.pack preferredVersionKey ->
refold's avatar
refold committed
566
      fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))
567
    _  -> Nothing
568
  where
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
    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
584
585
586
        Just (blockno, remainder)
          | BSS.null remainder -> Just (fromIntegral blockno)
        _                      -> Nothing
587

588
589
590
591
592
593
594
    parseRefType str =
      case BSS.uncons str of
        Just (typeCode, remainder)
          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode
            -> Just (refTypeFromTypeCode typeCode)
        _   -> Nothing

595
showIndexCacheEntry :: IndexCacheEntry -> String
596
showIndexCacheEntry entry = unwords $ case entry of
597
   CachePackageId pkgid b -> [ installedComponentId
598
599
600
601
602
603
604
605
606
607
608
609
                             , display (packageName pkgid)
                             , display (packageVersion pkgid)
                             , blocknoKey
                             , show b
                             ]
   CacheBuildTreeRef t b  -> [ buildTreeRefKey
                             , [typeCodeFromRefType t]
                             , show b
                             ]
   CachePreference dep    -> [ preferredVersionKey
                             , display dep
                             ]
610

611
612
613
614
615
616
617
618
619
-- | 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
  }
620

621
622
showIndexCache :: Cache -> String
showIndexCache Cache{..} = unlines $ map showIndexCacheEntry cacheEntries