IndexUtils.hs 30.3 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
{-# LANGUAGE DeriveGeneric #-}
3
{-# LANGUAGE RecordWildCards #-}
4
{-# LANGUAGE BangPatterns #-}
5
{-# LANGUAGE ViewPatterns #-}
Edsko de Vries's avatar
Edsko de Vries committed
6
{-# LANGUAGE GADTs #-}
7

8
9
-----------------------------------------------------------------------------
-- |
10
-- Module      :  Distribution.Client.IndexUtils
11
12
13
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
Duncan Coutts's avatar
Duncan Coutts committed
14
-- Maintainer  :  duncan@community.haskell.org
15
16
17
18
19
-- Stability   :  provisional
-- Portability :  portable
--
-- Extra utils related to the package indexes.
-----------------------------------------------------------------------------
20
module Distribution.Client.IndexUtils (
21
  getIndexFileAge,
22
  getInstalledPackages,
23
  Configure.getInstalledPackagesMonitorFiles,
24
  getSourcePackages,
25
  getSourcePackagesMonitorFiles,
26

27
  Index(..),
28
  PackageEntry(..),
29
30
  parsePackageIndex,
  updateRepoIndexCache,
31
  updatePackageIndexCacheFile,
32
  readCacheStrict,
33
34

  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
35
36
  ) where

37
38
39
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
40
import qualified Distribution.Client.Tar as Tar
41
import Distribution.Client.Types
42

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

72
73
74
75
import           Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import           Distribution.Solver.Types.SourcePackage

76
77
import GHC.Generics (Generic)

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

Edsko de Vries's avatar
Edsko de Vries committed
109
110
import qualified Hackage.Security.Client    as Sec
import qualified Hackage.Security.Util.Some as Sec
111

bardur.arantsson's avatar
bardur.arantsson committed
112
-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
113
getInstalledPackages :: Verbosity -> Compiler
114
                     -> PackageDBStack -> ProgramDb
115
                     -> IO InstalledPackageIndex
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
116
117
getInstalledPackages verbosity comp packageDbs progdb =
    Configure.getInstalledPackages verbosity' comp packageDbs progdb
118
  where
119
120
    verbosity'  = lessVerbose verbosity

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

-- | Get filename base (i.e. without file extension) for index-related files
--
-- /Secure/ cabal repositories use a new extended & incremental
-- @01-index.tar@. In order to avoid issues resulting from clobbering
-- new/old-style index data, we save them locally to different names.
--
-- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the
-- @00-index.tar.gz@/@01-index.tar.gz@ file.
indexBaseName :: Repo -> FilePath
indexBaseName repo = repoLocalDir repo </> fn
  where
    fn = case repo of
           RepoSecure {} -> "01-index"
           RepoRemote {} -> "00-index"
           RepoLocal  {} -> "00-index"

138
139
140
------------------------------------------------------------------------
-- Reading the source package index
--
141

142
143
144
-- | Read a repository index from disk, from the local files specified by
-- a list of 'Repo's.
--
145
-- All the 'SourcePackage's are marked as having come from the appropriate
146
147
148
-- 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
Edsko de Vries's avatar
Edsko de Vries committed
149
150
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages verbosity repoCtxt | null (repoContextRepos repoCtxt) = do
151
152
  warn verbosity $ "No remote package servers have been specified. Usually "
                ++ "you would have one specified in the config file."
153
  return SourcePackageDb {
154
155
156
    packageIndex       = mempty,
    packagePreferences = mempty
  }
Edsko de Vries's avatar
Edsko de Vries committed
157
getSourcePackages verbosity repoCtxt = do
158
  info verbosity "Reading available packages..."
Edsko de Vries's avatar
Edsko de Vries committed
159
  pkgss <- mapM (\r -> readRepoIndex verbosity repoCtxt r) (repoContextRepos repoCtxt)
160
  let (pkgs, prefs) = mconcat pkgss
Duncan Coutts's avatar
Duncan Coutts committed
161
      prefs' = Map.fromListWith intersectVersionRanges
162
                 [ (name, range) | Dependency name range <- prefs ]
163
164
  _ <- evaluate pkgs
  _ <- evaluate prefs'
165
  return SourcePackageDb {
166
167
168
    packageIndex       = pkgs,
    packagePreferences = prefs'
  }
169

170
171
172
readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])
readCacheStrict verbosity index mkPkg = do
    updateRepoIndexCache verbosity index
173
    cache <- readIndexCache verbosity index
174
175
176
    withFile (indexFile index) ReadMode $ \indexHnd ->
      packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict

177
178
179
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
180
-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
181
182
183
--
-- This is a higher level wrapper used internally in cabal-install.
--
Edsko de Vries's avatar
Edsko de Vries committed
184
readRepoIndex :: Verbosity -> RepoContext -> Repo
185
              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency])
Edsko de Vries's avatar
Edsko de Vries committed
186
readRepoIndex verbosity repoCtxt repo =
187
  handleNotFound $ do
188
    warnIfIndexIsOld =<< getIndexFileAge repo
Edsko de Vries's avatar
Edsko de Vries committed
189
    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
190
191
    readPackageIndexCacheFile verbosity mkAvailablePackage
                              (RepoIndex repoCtxt repo)
Duncan Coutts's avatar
Duncan Coutts committed
192

193
  where
194
    mkAvailablePackage pkgEntry =
195
      SourcePackage {
196
        packageInfoId      = pkgid,
197
198
        packageDescription = packageDesc pkgEntry,
        packageSource      = case pkgEntry of
199
200
          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing
          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path,
201
202
203
        packageDescrOverride = case pkgEntry of
          NormalPackage _ _ pkgtxt _ -> Just pkgtxt
          _                          -> Nothing
204
      }
205
206
      where
        pkgid = packageId pkgEntry
207

refold's avatar
refold committed
208
    handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
209
      then do
Edsko de Vries's avatar
Edsko de Vries committed
210
        case repo of
Edsko de Vries's avatar
Edsko de Vries committed
211
212
213
          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
          RepoLocal{..}  -> warn verbosity $
Edsko de Vries's avatar
Edsko de Vries committed
214
               "The package list for the local repo '" ++ repoLocalDir
215
216
217
218
            ++ "' is missing. The repo is invalid."
        return mempty
      else ioError e

219
    isOldThreshold = 15 --days
220
    warnIfIndexIsOld dt = do
Edsko de Vries's avatar
Edsko de Vries committed
221
      when (dt >= isOldThreshold) $ case repo of
Edsko de Vries's avatar
Edsko de Vries committed
222
223
224
225
226
227
228
229
230
231
232
        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."
233
234
235

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

238
239
240
241
242
-- | 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 =
243
    [ indexBaseName repo <.> "cache" | repo <- repos ]
244

245
246
247
-- | 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.
--
248
249
250
251
252
253
254
255
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
256
257
258
  if not exists
    then action
    else do
259
260
261
      indexTime <- getModTime $ indexFile index
      cacheTime <- getModTime $ cacheFile index
      when (indexTime > cacheTime) action
262
263
264
265

------------------------------------------------------------------------
-- Reading the index file
--
266

267
-- | An index entry is either a normal package, or a local build tree reference.
refold's avatar
refold committed
268
269
data PackageEntry =
  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo
270
271
272
273
274
  | BuildTreeRef BuildTreeRefType
                 PackageId GenericPackageDescription FilePath   BlockNo

-- | A build tree reference is either a link or a snapshot.
data BuildTreeRefType = SnapshotRef | LinkRef
275
276
277
                      deriving (Eq,Generic)

instance Binary BuildTreeRefType
278
279
280
281
282
283
284
285
286
287
288

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
289
290

instance Package PackageEntry where
291
292
  packageId (NormalPackage  pkgid _ _ _) = pkgid
  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
293
294

packageDesc :: PackageEntry -> GenericPackageDescription
295
296
packageDesc (NormalPackage  _ descr _ _) = descr
packageDesc (BuildTreeRef _ _ descr _ _) = descr
297

298
299
300
-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
--
Łukasz Dąbek's avatar
Łukasz Dąbek committed
301
302
303

data PackageOrDep = Pkg PackageEntry | Dep Dependency

304
305
306
307
308
309
310
311
312
313
-- | 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
314
  where
315
    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
Łukasz Dąbek's avatar
Łukasz Dąbek committed
316
    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
317
318
      where
        tryExtractPkg = do
Łukasz Dąbek's avatar
Łukasz Dąbek committed
319
          mkPkgEntry <- maybeToList $ extractPkg entry blockNo
320
          return $ fmap (fmap Pkg) mkPkgEntry
321
322

        tryExtractPrefs = do
323
          prefs' <- maybeToList $ extractPrefs entry
324
          fmap (return . Just . Dep) prefs'
325

326
327
328
329
330
-- | 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.
331
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
332
333
tarEntriesList = go 0
  where
334
    go !_ Tar.Done         = []
335
336
    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)
    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
337
338

extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
339
extractPkg entry blockNo = case Tar.entryContent entry of
340
341
342
343
  Tar.NormalFile content _
     | takeExtension fileName == ".cabal"
    -> case splitDirectories (normalise fileName) of
        [pkgname,vers,_] -> case simpleParse vers of
344
          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
345
346
            where
              pkgid  = PackageIdentifier (PackageName pkgname) ver
347
              parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack
348
349
350
351
352
353
                                               $ content
              descr  = case parsed of
                ParseOk _ d -> d
                _           -> error $ "Couldn't read cabal file "
                                    ++ show fileName
          _ -> Nothing
354
        _ -> Nothing
355
356

  Tar.OtherEntryType typeCode content _
357
    | Tar.isBuildTreeRefTypeCode typeCode ->
358
      Just $ do
359
360
361
362
363
364
365
366
367
        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
368

369
  _ -> Nothing
370

371
  where
372
    fileName = Tar.entryPath entry
373

374
extractPrefs :: Tar.Entry -> Maybe [Dependency]
375
376
extractPrefs entry = case Tar.entryContent entry of
  Tar.NormalFile content _
377
     | takeFileName entrypath == "preferred-versions"
378
    -> Just prefs
379
380
    where
      entrypath = Tar.entryPath entry
381
      prefs     = parsePreferredVersions content
382
383
  _ -> Nothing

384
parsePreferredVersions :: ByteString -> [Dependency]
EyalLotem's avatar
EyalLotem committed
385
parsePreferredVersions = mapMaybe simpleParse
386
387
                       . filter (not . isPrefixOf "--")
                       . lines
388
                       . BS.Char8.unpack -- TODO: Are we sure no unicode?
389
390
391
392
393

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

394
395
396
397
398
-- | 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
399
lazySequence :: [IO a] -> IO [a]
400
401
402
403
404
405
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
406

407
408
409
410
411
412
413
414
415
416
417
418
419
-- | A lazy unfolder for lookup operations which return the current
-- value and (possibly) the next key
lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]
lazyUnfold step = goLazy . Just
  where
    goLazy s = unsafeInterleaveIO (go s)

    go Nothing  = return []
    go (Just k) = do
        (v, mk') <- step k
        vs' <- goLazy mk'
        return ((k,v):vs')

420
421
-- | Which index do we mean?
data Index =
Edsko de Vries's avatar
Edsko de Vries committed
422
    -- | The main index for the specified repository
Edsko de Vries's avatar
Edsko de Vries committed
423
    RepoIndex RepoContext Repo
424

Edsko de Vries's avatar
Edsko de Vries committed
425
426
427
    -- | A sandbox-local repository
    -- Argument is the location of the index file
  | SandboxIndex FilePath
428
429

indexFile :: Index -> FilePath
430
indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"
Edsko de Vries's avatar
Edsko de Vries committed
431
indexFile (SandboxIndex index)   = index
432
433

cacheFile :: Index -> FilePath
434
cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"
Edsko de Vries's avatar
Edsko de Vries committed
435
cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"
436

437
438
439
440
441
442
443
444
445
-- | Return 'True' if 'Index' uses 01-index format (aka secure repo)
is01Index :: Index -> Bool
is01Index (RepoIndex _ repo) = case repo of
                                 RepoSecure {} -> True
                                 RepoRemote {} -> False
                                 RepoLocal  {} -> False
is01Index (SandboxIndex _)   = False


446
447
448
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
    info verbosity ("Updating index cache file " ++ cacheFile index)
449
450
    withIndexEntries index $ \entries -> do
      let cache = Cache { cacheEntries = entries }
451
      writeIndexCache index cache
452
453
454
455
456
457
458
459

-- | 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
460
461
462
463
464
465
466
467
468
469
470
471
472
--
-- 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.
473
withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a
Edsko de Vries's avatar
Edsko de Vries committed
474
475
476
withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =
    repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
      Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
        -- Incrementally (lazily) read all the entries in the tar file in order,
        -- including all revisions, not just the last revision of each file
        indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)
        callback [ cacheEntry
                 | (dirEntry, indexEntry) <- indexEntries
                 , cacheEntry <- toCacheEntries dirEntry indexEntry ]
  where
    toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry
                   -> [IndexCacheEntry]
    toCacheEntries dirEntry (Sec.Some sie) =
        case Sec.indexEntryPathParsed sie of
          Nothing                            -> [] -- skip unrecognized file
          Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata
          Just (Sec.IndexPkgCabal pkgId)     -> force
              [CachePackageId pkgId blockNo timestamp]
          Just (Sec.IndexPkgPrefs _pkgName)  -> force
              [ CachePreference dep blockNo timestamp
              | dep <- parsePreferredVersions (Sec.indexEntryContent sie)
              ]
      where
        blockNo = Sec.directoryEntryBlockNo dirEntry
        timestamp = Sec.indexEntryTime sie

500
withIndexEntries index callback = do -- non-secure repositories
501
502
503
504
    withFile (indexFile index) ReadMode $ \h -> do
      bs          <- maybeDecompress `fmap` BS.hGetContents h
      pkgsOrPrefs <- lazySequence $ parsePackageIndex bs
      callback $ map toCache (catMaybes pkgsOrPrefs)
505
  where
506
    toCache :: PackageOrDep -> IndexCacheEntry
507
    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo (-1)
Łukasz Dąbek's avatar
Łukasz Dąbek committed
508
    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
509
    toCache (Dep d) = CachePreference d 0 (-1)
510

511
512
513
data ReadPackageIndexMode = ReadPackageIndexStrict
                          | ReadPackageIndexLazyIO

514
readPackageIndexCacheFile :: Package pkg
515
516
                          => Verbosity
                          -> (PackageEntry -> pkg)
517
                          -> Index
518
                          -> IO (PackageIndex pkg, [Dependency])
519
520
readPackageIndexCacheFile verbosity mkPkg index = do
  cache    <- readIndexCache verbosity index
Edsko de Vries's avatar
Edsko de Vries committed
521
522
  indexHnd <- openFile (indexFile index) ReadMode
  packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO
523
524

packageIndexFromCache :: Package pkg
525
                      => (PackageEntry -> pkg)
526
                      -> Handle
527
                      -> Cache
528
                      -> ReadPackageIndexMode
529
                      -> IO (PackageIndex pkg, [Dependency])
530
531
532
533
534
535
536
packageIndexFromCache mkPkg hnd cache mode = do
     (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode
     pkgIndex <- evaluate $ PackageIndex.fromList pkgs
     return (pkgIndex, prefs)

-- | Read package list
--
537
538
539
540
541
542
543
-- 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.
544
545
546
547
548
packageListFromCache :: (PackageEntry -> pkg)
                     -> Handle
                     -> Cache
                     -> ReadPackageIndexMode
                     -> IO ([pkg], [Dependency])
549
packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries
550
  where
551
    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
552

553
    accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do
554
555
556
557
      -- 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.
558
559
560
561
      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
        pkgtxt <- getEntryContent blockno
        pkg    <- readPackageDescription pkgtxt
        return (pkg, pkgtxt)
562
563
564
565
566
567
      let srcpkg = case mode of
            ReadPackageIndexLazyIO ->
              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
            ReadPackageIndexStrict ->
              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg
                                            pkgtxt blockno)
568
      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
569

570
    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
571
572
573
      -- 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.
574
      path <- liftM byteStringToFilePath . getEntryContent $ blockno
575
576
577
      pkg  <- do let err = "Error reading package index from cache."
                 file <- tryFindAddSourcePackageDesc path err
                 PackageDesc.Parse.readPackageDescription normal file
578
      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
579
      accum srcpkgs (srcpkg:btrs) prefs entries
580

581
    accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _) _ _ : entries) =
582
      accum srcpkgs btrs (Map.insert pn pref prefs) entries
583

584
585
    getEntryContent :: BlockNo -> IO ByteString
    getEntryContent blockno = do
586
587
588
589
590
591
592
      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"
593

594
    readPackageDescription :: ByteString -> IO GenericPackageDescription
595
    readPackageDescription content =
596
      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of
597
598
599
600
601
602
603
604
605
606
607
        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
--

608
-- | Read the 'Index' cache from the filesystem
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
--
-- If a corrupted index cache is detected this function regenerates
-- the index cache and then reattempt to read the index once (and
-- 'die's if it fails again).
readIndexCache :: Verbosity -> Index -> IO Cache
readIndexCache verbosity index = do
    cacheOrFail <- readIndexCache' index
    case cacheOrFail of
      Left msg -> do
          warn verbosity $ concat
              [ "Parsing the index cache failed (", msg, "). "
              , "Trying to regenerated the index cache..."
              ]

          updatePackageIndexCacheFile verbosity index

          either die return =<< readIndexCache' index

      Right res -> return res

-- | Read the 'Index' cache from the filesystem without attempting to
-- regenerate on parsing failures.
readIndexCache' :: Index -> IO (Either String Cache)
readIndexCache' index
  | is01Index index = decodeFileOrFail' (cacheFile index)
  | otherwise       = liftM (Right .read00IndexCache) $
                      BSS.readFile (cacheFile index)
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650

-- | Write the 'Index' cache to the filesystem
writeIndexCache :: Index -> Cache -> IO ()
writeIndexCache index cache
  | is01Index index = encodeFile (cacheFile index) cache
  | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)

-- | Cabal caches various information about the Hackage index
data Cache = Cache {
    cacheEntries :: [IndexCacheEntry]
  }

instance NFData Cache where
    rnf = rnf . cacheEntries

651
652
653
-- | Tar files are block structured with 512 byte blocks. Every header and file
-- content starts on a block boundary.
--
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
type BlockNo = Word32 -- Tar.TarEntryOffset

-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
type Timestamp = Int64 -- Tar.EpochTime

data IndexCacheEntry
    = CachePackageId PackageId !BlockNo !Timestamp
    | CachePreference Dependency !BlockNo !Timestamp
    | CacheBuildTreeRef !BuildTreeRefType !BlockNo
      -- NB: CacheBuildTreeRef is irrelevant for 01-index & new-build
  deriving (Eq,Generic)

instance NFData IndexCacheEntry where
    rnf (CachePackageId pkgid _ _) = rnf pkgid
    rnf (CachePreference dep _ _) = rnf dep
    rnf (CacheBuildTreeRef _ _) = ()

----------------------------------------------------------------------------
-- new binary 01-index.cache format

instance Binary Cache where
    put (Cache ents) = do
        -- magic / format version
        --
        -- NB: this currently encodes word-size implicitly; when we
        -- switch to CBOR encoding, we will have a platform
        -- independent binary encoding
        put (0xcaba1001::Word)
        put ents

    get = do
        magic <- get
        when (magic /= (0xcaba1001::Word)) $
            fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic)
        liftM Cache get

instance Binary IndexCacheEntry

----------------------------------------------------------------------------
-- legacy 00-index.cache format
694

695
696
packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
packageKey = "pkg:"
697
698
699
700
blocknoKey = "b#"
buildTreeRefKey     = "build-tree-ref:"
preferredVersionKey = "pref-ver:"

701
702
703
704
705
706
707
708
-- legacy 00-index.cache format
read00IndexCache :: BSS.ByteString -> Cache
read00IndexCache bs = Cache {
    cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs
  }

read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry = \line ->
709
710
  case BSS.words line of
    [key, pkgnamestr, pkgverstr, sep, blocknostr]
711
      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->
refold's avatar
refold committed
712
713
      case (parseName pkgnamestr, parseVer pkgverstr [],
            parseBlockNo blocknostr) of
714
        (Just pkgname, Just pkgver, Just blockno)
715
          -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno (-1))
716
        _ -> Nothing
717
    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
718
719
720
721
722
      case (parseRefType typecodestr, parseBlockNo blocknostr) of
        (Just refType, Just blockno)
          -> Just (CacheBuildTreeRef refType blockno)
        _ -> Nothing

723
724
725
726
    (key: remainder) | key == BSS.pack preferredVersionKey -> do
      pref <- simpleParse (BSS.unpack (BSS.unwords remainder))
      return $ CachePreference pref 0 (-1)

727
    _  -> Nothing
728
  where
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
    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
744
745
746
        Just (blockno, remainder)
          | BSS.null remainder -> Just (fromIntegral blockno)
        _                      -> Nothing
747

748
749
750
751
752
753
754
    parseRefType str =
      case BSS.uncons str of
        Just (typeCode, remainder)
          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode
            -> Just (refTypeFromTypeCode typeCode)
        _   -> Nothing

755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
-- legacy 00-index.cache format
show00IndexCache :: Cache -> String
show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries

show00IndexCacheEntry :: IndexCacheEntry -> String
show00IndexCacheEntry entry = unwords $ case entry of
   CachePackageId pkgid b _ -> [ packageKey
                               , display (packageName pkgid)
                               , display (packageVersion pkgid)
                               , blocknoKey
                               , show b
                               ]
   CacheBuildTreeRef tr b   -> [ buildTreeRefKey
                               , [typeCodeFromRefType tr]
                               , show b
                               ]
   CachePreference dep _ _  -> [ preferredVersionKey
                               , display dep
                               ]