IndexUtils.hs 36.4 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
28
29
  IndexState(..),
  getSourcePackagesAtIndexState,

30
  Index(..),
31
  PackageEntry(..),
32
33
  parsePackageIndex,
  updateRepoIndexCache,
34
  updatePackageIndexCacheFile,
35
  readCacheStrict, -- only used by soon-to-be-obsolete sandbox code
36
37

  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
38
39
  ) where

40
41
42
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
43
import qualified Distribution.Client.Tar as Tar
44
import Distribution.Client.IndexUtils.Timestamp
45
import Distribution.Client.Types
46

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

76
77
78
79
import           Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import           Distribution.Solver.Types.SourcePackage

80
81
import GHC.Generics (Generic)

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

Edsko de Vries's avatar
Edsko de Vries committed
113
114
import qualified Hackage.Security.Client    as Sec
import qualified Hackage.Security.Util.Some as Sec
115

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

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141

-- | 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"

142
143
144
------------------------------------------------------------------------
-- Reading the source package index
--
145

146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
-- Note: 'data IndexState' is defined in
-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles

-- | 'IndexStateInfo' contains meta-information about the resulting
-- filtered 'Cache' 'after applying 'filterCache' according to a
-- requested 'IndexState'.
data IndexStateInfo = IndexStateInfo
    { isiMaxTime  :: !Timestamp
    -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current
    -- filtered view of the cache.
    --
    -- The following property holds
    --
    -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)
    --

    , isiHeadTime :: !Timestamp
    -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest
    -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to
    -- 'isiMaxTime'.
    }

emptyStateInfo :: IndexStateInfo
emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp

-- | Filters a 'Cache' according to an 'IndexState'
-- specification. Also returns 'IndexStateInfo' describing the
-- resulting index cache.
--
-- Note: 'filterCache' is idempotent in the 'Cache' value
filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo)
filterCache IndexStateHead cache = (cache, IndexStateInfo{..})
  where
    isiMaxTime  = cacheHeadTs cache
    isiHeadTime = cacheHeadTs cache
filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
  where
    cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime }
    isiHeadTime = cacheHeadTs cache0
    isiMaxTime  = maximumTimestamp (map cacheEntryTimestamp ents)
    ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)

188
189
190
-- | Read a repository index from disk, from the local files specified by
-- a list of 'Repo's.
--
191
-- All the 'SourcePackage's are marked as having come from the appropriate
192
193
194
-- 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
Edsko de Vries's avatar
Edsko de Vries committed
195
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
getSourcePackages verbosity repoCtxt =
    getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead

-- | Variant of 'getSourcePackages' which allows getting the source
-- packages at a particular 'IndexState'.
--
-- Current choices are either the latest (aka HEAD), or the index as
-- it was at a particular time.
--
-- TODO: Enhance to allow specifying per-repo 'IndexState's and also
-- report back per-repo 'IndexStateInfo's (in order for @new-freeze@
-- to access it)
getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState
                           -> IO SourcePackageDb
getSourcePackagesAtIndexState verbosity repoCtxt _
  | null (repoContextRepos repoCtxt) = do
      warn verbosity $ "No remote package servers have been specified. Usually "
                       ++ "you would have one specified in the config file."
      return SourcePackageDb {
        packageIndex       = mempty,
        packagePreferences = mempty
      }
getSourcePackagesAtIndexState verbosity repoCtxt idxState = do
  case idxState of
      IndexStateHead      -> info verbosity "Reading available packages..."
      IndexStateTime time ->
          info verbosity ("Reading available packages (for index-state as of "
                          ++ display time ++ ")...")

  pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
      let rname = maybe "" remoteRepoName $ maybeRepoRemote r
      unless (idxState == IndexStateHead) $
          case r of
            RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")
            RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')")
            RepoSecure {} -> pure ()


      let idxState' = case r of
            RepoSecure {} -> idxState
            _             -> IndexStateHead

      (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState'

      case idxState' of
        IndexStateHead -> do
            info verbosity ("index-state("++rname++") = " ++
                              display (isiHeadTime isi))
            return ()
        IndexStateTime ts0 -> do
            when (isiMaxTime isi /= ts0) $
                warn verbosity ("Requested index-state " ++ display ts0
                                ++ " does not exist in '"++rname++"'!"
                                ++ " Falling back to older state ("
                                ++ display (isiMaxTime isi) ++ ").")
            info verbosity ("index-state("++rname++") = " ++
                              display (isiMaxTime isi) ++ " (HEAD = " ++
                              display (isiHeadTime isi) ++ ")")

      pure (pis,deps)

257
  let (pkgs, prefs) = mconcat pkgss
Duncan Coutts's avatar
Duncan Coutts committed
258
      prefs' = Map.fromListWith intersectVersionRanges
259
                 [ (name, range) | Dependency name range <- prefs ]
260
261
  _ <- evaluate pkgs
  _ <- evaluate prefs'
262
  return SourcePackageDb {
263
264
265
    packageIndex       = pkgs,
    packagePreferences = prefs'
  }
266

267
268
269
readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])
readCacheStrict verbosity index mkPkg = do
    updateRepoIndexCache verbosity index
270
    cache <- readIndexCache verbosity index
271
272
273
    withFile (indexFile index) ReadMode $ \indexHnd ->
      packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict

274
275
276
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
277
-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
278
279
280
--
-- This is a higher level wrapper used internally in cabal-install.
--
281
282
283
readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState
              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
readRepoIndex verbosity repoCtxt repo idxState =
284
  handleNotFound $ do
285
    warnIfIndexIsOld =<< getIndexFileAge repo
Edsko de Vries's avatar
Edsko de Vries committed
286
    updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
287
288
    readPackageIndexCacheFile verbosity mkAvailablePackage
                              (RepoIndex repoCtxt repo)
289
                              idxState
Duncan Coutts's avatar
Duncan Coutts committed
290

291
  where
292
    mkAvailablePackage pkgEntry =
293
      SourcePackage {
294
        packageInfoId      = pkgid,
295
296
        packageDescription = packageDesc pkgEntry,
        packageSource      = case pkgEntry of
297
298
          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing
          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path,
299
300
301
        packageDescrOverride = case pkgEntry of
          NormalPackage _ _ pkgtxt _ -> Just pkgtxt
          _                          -> Nothing
302
      }
303
304
      where
        pkgid = packageId pkgEntry
305

refold's avatar
refold committed
306
    handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
307
      then do
Edsko de Vries's avatar
Edsko de Vries committed
308
        case repo of
Edsko de Vries's avatar
Edsko de Vries committed
309
310
311
          RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
          RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
          RepoLocal{..}  -> warn verbosity $
Edsko de Vries's avatar
Edsko de Vries committed
312
               "The package list for the local repo '" ++ repoLocalDir
313
            ++ "' is missing. The repo is invalid."
314
        return (mempty,mempty,emptyStateInfo)
315
316
      else ioError e

317
    isOldThreshold = 15 --days
318
    warnIfIndexIsOld dt = do
Edsko de Vries's avatar
Edsko de Vries committed
319
      when (dt >= isOldThreshold) $ case repo of
Edsko de Vries's avatar
Edsko de Vries committed
320
321
322
323
324
325
326
327
328
329
330
        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."
331
332
333

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

336
337
338
339
340
-- | 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 =
341
    [ indexBaseName repo <.> "cache" | repo <- repos ]
342

343
344
345
-- | 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.
--
346
347
348
349
350
351
352
353
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
354
355
356
  if not exists
    then action
    else do
357
358
359
      indexTime <- getModTime $ indexFile index
      cacheTime <- getModTime $ cacheFile index
      when (indexTime > cacheTime) action
360
361
362
363

------------------------------------------------------------------------
-- Reading the index file
--
364

365
-- | An index entry is either a normal package, or a local build tree reference.
refold's avatar
refold committed
366
367
data PackageEntry =
  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo
368
369
370
371
372
  | BuildTreeRef BuildTreeRefType
                 PackageId GenericPackageDescription FilePath   BlockNo

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

instance Binary BuildTreeRefType
376
377
378
379
380
381
382
383
384
385
386

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
387
388

instance Package PackageEntry where
389
390
  packageId (NormalPackage  pkgid _ _ _) = pkgid
  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
391
392

packageDesc :: PackageEntry -> GenericPackageDescription
393
394
packageDesc (NormalPackage  _ descr _ _) = descr
packageDesc (BuildTreeRef _ _ descr _ _) = descr
395

396
397
398
-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
--
Łukasz Dąbek's avatar
Łukasz Dąbek committed
399
400
401

data PackageOrDep = Pkg PackageEntry | Dep Dependency

402
403
404
405
406
407
408
409
410
411
-- | 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
412
  where
413
    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
Łukasz Dąbek's avatar
Łukasz Dąbek committed
414
    extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
415
416
      where
        tryExtractPkg = do
Łukasz Dąbek's avatar
Łukasz Dąbek committed
417
          mkPkgEntry <- maybeToList $ extractPkg entry blockNo
418
          return $ fmap (fmap Pkg) mkPkgEntry
419
420

        tryExtractPrefs = do
421
          prefs' <- maybeToList $ extractPrefs entry
422
          fmap (return . Just . Dep) prefs'
423

424
425
426
427
428
-- | 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.
429
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
430
431
tarEntriesList = go 0
  where
432
    go !_ Tar.Done         = []
433
434
    go !_ (Tar.Fail e)     = error ("tarEntriesList: " ++ show e)
    go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
435
436

extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
437
extractPkg entry blockNo = case Tar.entryContent entry of
438
439
440
441
  Tar.NormalFile content _
     | takeExtension fileName == ".cabal"
    -> case splitDirectories (normalise fileName) of
        [pkgname,vers,_] -> case simpleParse vers of
442
          Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
443
444
            where
              pkgid  = PackageIdentifier (PackageName pkgname) ver
445
              parsed = parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack
446
447
448
449
450
451
                                               $ content
              descr  = case parsed of
                ParseOk _ d -> d
                _           -> error $ "Couldn't read cabal file "
                                    ++ show fileName
          _ -> Nothing
452
        _ -> Nothing
453
454

  Tar.OtherEntryType typeCode content _
455
    | Tar.isBuildTreeRefTypeCode typeCode ->
456
      Just $ do
457
458
459
460
461
462
463
464
465
        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
466

467
  _ -> Nothing
468

469
  where
470
    fileName = Tar.entryPath entry
471

472
extractPrefs :: Tar.Entry -> Maybe [Dependency]
473
474
extractPrefs entry = case Tar.entryContent entry of
  Tar.NormalFile content _
475
     | takeFileName entrypath == "preferred-versions"
476
    -> Just prefs
477
478
    where
      entrypath = Tar.entryPath entry
479
      prefs     = parsePreferredVersions content
480
481
  _ -> Nothing

482
parsePreferredVersions :: ByteString -> [Dependency]
EyalLotem's avatar
EyalLotem committed
483
parsePreferredVersions = mapMaybe simpleParse
484
485
                       . filter (not . isPrefixOf "--")
                       . lines
486
                       . BS.Char8.unpack -- TODO: Are we sure no unicode?
487
488
489
490
491

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

492
493
494
495
496
-- | 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
497
lazySequence :: [IO a] -> IO [a]
498
499
500
501
502
503
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
504

505
506
507
508
509
510
511
512
513
514
515
516
517
-- | 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')

518
519
-- | Which index do we mean?
data Index =
Edsko de Vries's avatar
Edsko de Vries committed
520
    -- | The main index for the specified repository
Edsko de Vries's avatar
Edsko de Vries committed
521
    RepoIndex RepoContext Repo
522

Edsko de Vries's avatar
Edsko de Vries committed
523
524
525
    -- | A sandbox-local repository
    -- Argument is the location of the index file
  | SandboxIndex FilePath
526
527

indexFile :: Index -> FilePath
528
indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"
Edsko de Vries's avatar
Edsko de Vries committed
529
indexFile (SandboxIndex index)   = index
530
531

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

535
536
537
538
539
540
541
542
543
-- | 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


544
545
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
546
    info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")
547
    withIndexEntries index $ \entries -> do
548
549
550
551
      let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)
          cache = Cache { cacheHeadTs  = maxTs
                        , cacheEntries = entries
                        }
552
      writeIndexCache index cache
553
554
      info verbosity ("Index cache updated to index-state "
                      ++ display (cacheHeadTs cache))
555
556
557
558
559
560
561
562

-- | 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
563
564
565
566
567
568
569
570
571
572
573
574
575
--
-- 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.
576
withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a
Edsko de Vries's avatar
Edsko de Vries committed
577
578
579
withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback =
    repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
      Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
        -- 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
601
602
        timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $
                              epochTimeToTimestamp $ Sec.indexEntryTime sie
603

604
withIndexEntries index callback = do -- non-secure repositories
605
606
607
608
    withFile (indexFile index) ReadMode $ \h -> do
      bs          <- maybeDecompress `fmap` BS.hGetContents h
      pkgsOrPrefs <- lazySequence $ parsePackageIndex bs
      callback $ map toCache (catMaybes pkgsOrPrefs)
609
  where
610
    toCache :: PackageOrDep -> IndexCacheEntry
611
    toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp
Łukasz Dąbek's avatar
Łukasz Dąbek committed
612
    toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
613
    toCache (Dep d) = CachePreference d 0 nullTimestamp
614

615
616
617
data ReadPackageIndexMode = ReadPackageIndexStrict
                          | ReadPackageIndexLazyIO

618
readPackageIndexCacheFile :: Package pkg
619
620
                          => Verbosity
                          -> (PackageEntry -> pkg)
621
                          -> Index
622
623
624
625
626
627
628
629
630
                          -> IndexState
                          -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile verbosity mkPkg index idxState = do
    cache0    <- readIndexCache verbosity index
    indexHnd <- openFile (indexFile index) ReadMode
    let (cache,isi) = filterCache idxState cache0
    (pkgs,deps) <- packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO
    pure (pkgs,deps,isi)

631
632

packageIndexFromCache :: Package pkg
633
                      => (PackageEntry -> pkg)
634
                      -> Handle
635
                      -> Cache
636
                      -> ReadPackageIndexMode
637
                      -> IO (PackageIndex pkg, [Dependency])
638
639
640
641
642
643
644
packageIndexFromCache mkPkg hnd cache mode = do
     (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode
     pkgIndex <- evaluate $ PackageIndex.fromList pkgs
     return (pkgIndex, prefs)

-- | Read package list
--
645
646
647
648
649
650
651
-- 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.
652
653
654
655
656
packageListFromCache :: (PackageEntry -> pkg)
                     -> Handle
                     -> Cache
                     -> ReadPackageIndexMode
                     -> IO ([pkg], [Dependency])
657
packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries
658
  where
659
    accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
660

661
    accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do
662
663
664
665
      -- 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.
666
667
668
669
      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
        pkgtxt <- getEntryContent blockno
        pkg    <- readPackageDescription pkgtxt
        return (pkg, pkgtxt)
670
671
672
673
674
675
      let srcpkg = case mode of
            ReadPackageIndexLazyIO ->
              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
            ReadPackageIndexStrict ->
              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg
                                            pkgtxt blockno)
676
      accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
677

678
    accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
679
680
681
      -- 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.
682
      path <- liftM byteStringToFilePath . getEntryContent $ blockno
683
684
685
      pkg  <- do let err = "Error reading package index from cache."
                 file <- tryFindAddSourcePackageDesc path err
                 PackageDesc.Parse.readPackageDescription normal file
686
      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
687
      accum srcpkgs (srcpkg:btrs) prefs entries
688

689
    accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _) _ _ : entries) =
690
      accum srcpkgs btrs (Map.insert pn pref prefs) entries
691

692
693
    getEntryContent :: BlockNo -> IO ByteString
    getEntryContent blockno = do
694
695
696
697
698
699
700
      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"
701

702
    readPackageDescription :: ByteString -> IO GenericPackageDescription
703
    readPackageDescription content =
704
      case parsePackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of
705
706
707
708
709
710
711
712
713
714
715
        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
--

716
-- | Read the 'Index' cache from the filesystem
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
--
-- 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

733
          either die (return . hashConsCache) =<< readIndexCache' index
734

735
      Right res -> return (hashConsCache res)
736
737
738
739
740
741
742
743

-- | 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)
744
745
746
747
748
749
750

-- | 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)

751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
-- | Optimise sharing of equal values inside 'Cache'
--
-- c.f. https://en.wikipedia.org/wiki/Hash_consing
hashConsCache :: Cache -> Cache
hashConsCache cache0
    = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) }
  where
    -- TODO/NOTE:
    --
    -- If/when we redo the binary serialisation via e.g. CBOR and we
    -- are able to use incremental decoding, we may want to move the
    -- hash-consing into the incremental deserialisation, or
    -- alterantively even do something like
    -- http://cbor.schmorp.de/value-sharing
    --
    go _ _ [] = []
    -- for now we only optimise only CachePackageIds since those
    -- represent the vast majority
    go !pns !pvs (CachePackageId pid bno ts : rest)
        = CachePackageId pid' bno ts : go pns' pvs' rest
      where
        !pid' = PackageIdentifier pn' pv'
        (!pn',!pns') = mapIntern pn pns
        (!pv',!pvs') = mapIntern pv pvs
        PackageIdentifier pn pv = pid

    go pns pvs (x:xs) = x : go pns pvs xs

    mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k)
    mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m)

782
-- | Cabal caches various information about the Hackage index
783
784
785
786
787
788
789
790
data Cache = Cache
    { cacheHeadTs  :: Timestamp
      -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the
      -- invariant of 'cacheEntries' being in chronological order is
      -- violated, this corresponds to the last (seen) 'Timestamp' in
      -- 'cacheEntries'
    , cacheEntries :: [IndexCacheEntry]
    }
791
792
793
794

instance NFData Cache where
    rnf = rnf . cacheEntries

795
796
797
-- | Tar files are block structured with 512 byte blocks. Every header and file
-- content starts on a block boundary.
--
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
type BlockNo = Word32 -- Tar.TarEntryOffset


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 _ _) = ()

813
814
815
816
817
cacheEntryTimestamp :: IndexCacheEntry -> Timestamp
cacheEntryTimestamp (CacheBuildTreeRef _ _)  = nullTimestamp
cacheEntryTimestamp (CachePreference _ _ ts) = ts
cacheEntryTimestamp (CachePackageId _ _ ts)  = ts

818
819
820
821
----------------------------------------------------------------------------
-- new binary 01-index.cache format

instance Binary Cache where
822
    put (Cache headTs ents) = do
823
824
825
826
827
        -- magic / format version
        --
        -- NB: this currently encodes word-size implicitly; when we
        -- switch to CBOR encoding, we will have a platform
        -- independent binary encoding
828
829
        put (0xcaba1002::Word)
        put headTs
830
831
832
833
        put ents

    get = do
        magic <- get
834
        when (magic /= (0xcaba1002::Word)) $
835
            fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic)
836
        Cache <$> get <*> get
837
838
839
840
841

instance Binary IndexCacheEntry

----------------------------------------------------------------------------
-- legacy 00-index.cache format
842

843
844
packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
packageKey = "pkg:"
845
846
847
848
blocknoKey = "b#"
buildTreeRefKey     = "build-tree-ref:"
preferredVersionKey = "pref-ver:"

849
850
-- legacy 00-index.cache format
read00IndexCache :: BSS.ByteString -> Cache
851
852
853
read00IndexCache bs = Cache
  { cacheHeadTs  = nullTimestamp
  , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs
854
855
856
857
  }

read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry = \line ->
858
859
  case BSS.words line of
    [key, pkgnamestr, pkgverstr, sep, blocknostr]
860
      | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->
refold's avatar
refold committed
861
862
      case (parseName pkgnamestr, parseVer pkgverstr [],
            parseBlockNo blocknostr) of
863
        (Just pkgname, Just pkgver, Just blockno)
864
865
          -> Just (CachePackageId (PackageIdentifier pkgname pkgver)
                                  blockno nullTimestamp)
866
        _ -> Nothing
867
    [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
868
869
870
871
872
      case (parseRefType typecodestr, parseBlockNo blocknostr) of
        (Just refType, Just blockno)
          -> Just (CacheBuildTreeRef refType blockno)
        _ -> Nothing

873
874
    (key: remainder) | key == BSS.pack preferredVersionKey -> do
      pref <- simpleParse (BSS.unpack (BSS.unwords remainder))
875
      return $ CachePreference pref 0 nullTimestamp
876

877
    _  -> Nothing
878
  where
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
    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
894
895
896
        Just (blockno, remainder)
          | BSS.null remainder -> Just (fromIntegral blockno)
        _                      -> Nothing
897

898
899
900
901
902
903
904
    parseRefType str =
      case BSS.uncons str of
        Just (typeCode, remainder)
          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode
            -> Just (refTypeFromTypeCode typeCode)
        _   -> Nothing

905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
-- 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
                               ]