cabal-install/src/Distribution/Client/IndexUtils.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE CPP #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE LambdaCase #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE RecordWildCards #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9
  10 -----------------------------------------------------------------------------
  11
  12 -----------------------------------------------------------------------------
  13
  14 -- |
  15 -- Module      :  Distribution.Client.IndexUtils
  16 -- Copyright   :  (c) Duncan Coutts 2008
  17 -- License     :  BSD-like
  18 --
  19 -- Maintainer  :  duncan@community.haskell.org
  20 -- Stability   :  provisional
  21 -- Portability :  portable
  22 --
  23 -- Extra utils related to the package indexes.
  24 module Distribution.Client.IndexUtils
  25   ( getIndexFileAge
  26   , getInstalledPackages
  27   , indexBaseName
  28   , Configure.getInstalledPackagesMonitorFiles
  29   , getSourcePackages
  30   , getSourcePackagesMonitorFiles
  31   , TotalIndexState
  32   , getSourcePackagesAtIndexState
  33   , ActiveRepos
  34   , filterSkippedActiveRepos
  35   , Index (..)
  36   , RepoIndexState (..)
  37   , PackageEntry (..)
  38   , parsePackageIndex
  39   , updateRepoIndexCache
  40   , updatePackageIndexCacheFile
  41   , writeIndexTimestamp
  42   , currentIndexTimestamp
  43   , BuildTreeRefType (..)
  44   , refTypeFromTypeCode
  45   , typeCodeFromRefType
  46
  47     -- * preferred-versions utilities
  48   , preferredVersions
  49   , isPreferredVersions
  50   , parsePreferredVersionsWarnings
  51   , PreferredVersionsParseError (..)
  52   ) where
  53
  54 import Distribution.Client.Compat.Prelude
  55 import Prelude ()
  56
  57 import qualified Codec.Archive.Tar as Tar
  58 import qualified Codec.Archive.Tar.Entry as Tar
  59 import qualified Codec.Archive.Tar.Index as Tar
  60 import Distribution.Client.IndexUtils.ActiveRepos
  61 import Distribution.Client.IndexUtils.IndexState
  62 import Distribution.Client.IndexUtils.Timestamp
  63 import qualified Distribution.Client.Tar as Tar
  64 import Distribution.Client.Types
  65 import Distribution.Parsec (simpleParsecBS)
  66 import Distribution.Verbosity
  67
  68 import Distribution.Client.Setup
  69   ( RepoContext (..)
  70   )
  71 import Distribution.Package
  72   ( Package (..)
  73   , PackageId
  74   , PackageIdentifier (..)
  75   , mkPackageName
  76   , packageName
  77   , packageVersion
  78   )
  79 import Distribution.PackageDescription
  80   ( GenericPackageDescription (..)
  81   , PackageDescription (..)
  82   , emptyPackageDescription
  83   )
  84 import Distribution.Simple.Compiler
  85   ( Compiler
  86   , PackageDBStack
  87   )
  88 import qualified Distribution.Simple.Configure as Configure
  89   ( getInstalledPackages
  90   , getInstalledPackagesMonitorFiles
  91   )
  92 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  93 import Distribution.Simple.Program
  94   ( ProgramDb
  95   )
  96 import Distribution.Simple.Utils
  97   ( createDirectoryIfMissingVerbose
  98   , dieWithException
  99   , fromUTF8LBS
 100   , info
 101   , warn
 102   )
 103 import Distribution.Types.Dependency
 104 import Distribution.Types.PackageName (PackageName)
 105 import Distribution.Version
 106   ( Version
 107   , VersionRange
 108   , intersectVersionRanges
 109   , mkVersion
 110   )
 111
 112 import Distribution.PackageDescription.Parsec
 113   ( parseGenericPackageDescription
 114   , parseGenericPackageDescriptionMaybe
 115   )
 116 import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse
 117 import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse
 118
 119 import Distribution.Solver.Types.PackageIndex (PackageIndex)
 120 import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
 121 import Distribution.Solver.Types.SourcePackage
 122
 123 import qualified Codec.Compression.GZip as GZip
 124 import Control.Exception
 125 import qualified Data.ByteString.Char8 as BSS
 126 import Data.ByteString.Lazy (ByteString)
 127 import qualified Data.ByteString.Lazy as BS
 128 import Data.Either
 129   ( rights
 130   )
 131 import Data.List (stripPrefix)
 132 import qualified Data.Map as Map
 133 import qualified Data.Set as Set
 134 import Distribution.Client.GZipUtils (maybeDecompress)
 135 import Distribution.Client.Utils
 136   ( byteStringToFilePath
 137   , tryFindAddSourcePackageDesc
 138   )
 139 import Distribution.Compat.Directory (listDirectory)
 140 import Distribution.Compat.Time (getFileAge, getModTime)
 141 import Distribution.Utils.Generic (fstOf3)
 142 import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredDecodeFileOrFail, structuredEncodeFile)
 143 import System.Directory (doesDirectoryExist, doesFileExist)
 144 import System.FilePath
 145   ( normalise
 146   , splitDirectories
 147   , takeDirectory
 148   , takeExtension
 149   , takeFileName
 150   , (<.>)
 151   , (</>)
 152   )
 153 import qualified System.FilePath.Posix as FilePath.Posix
 154 import System.IO
 155 import System.IO.Error (isDoesNotExistError)
 156 import System.IO.Unsafe (unsafeInterleaveIO)
 157
 158 import Distribution.Client.Errors
 159 import qualified Hackage.Security.Client as Sec
 160 import qualified Hackage.Security.Util.Some as Sec
 161
 162 -- | Reduced-verbosity version of 'Configure.getInstalledPackages'
 163 getInstalledPackages
 164   :: Verbosity
 165   -> Compiler
 166   -> PackageDBStack
 167   -> ProgramDb
 168   -> IO InstalledPackageIndex
 169 getInstalledPackages verbosity comp packageDbs progdb =
 170   Configure.getInstalledPackages verbosity' comp packageDbs progdb
 171   where
 172     verbosity' = lessVerbose verbosity
 173
 174 -- | Get filename base (i.e. without file extension) for index-related files
 175 --
 176 -- /Secure/ cabal repositories use a new extended & incremental
 177 -- @01-index.tar@. In order to avoid issues resulting from clobbering
 178 -- new/old-style index data, we save them locally to different names.
 179 --
 180 -- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the
 181 -- @00-index.tar.gz@/@01-index.tar.gz@ file.
 182 indexBaseName :: Repo -> FilePath
 183 indexBaseName repo = repoLocalDir repo </> fn
 184   where
 185     fn = case repo of
 186       RepoSecure{} -> "01-index"
 187       RepoRemote{} -> "00-index"
 188       RepoLocalNoIndex{} -> "noindex"
 189
 190 ------------------------------------------------------------------------
 191 -- Reading the source package index
 192 --
 193
 194 -- Note: 'data IndexState' is defined in
 195 -- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles
 196
 197 -- | 'IndexStateInfo' contains meta-information about the resulting
 198 -- filtered 'Cache' 'after applying 'filterCache' according to a
 199 -- requested 'IndexState'.
 200 data IndexStateInfo = IndexStateInfo
 201   { isiMaxTime :: !Timestamp
 202   -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current
 203   -- filtered view of the cache.
 204   --
 205   -- The following property holds
 206   --
 207   -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)
 208   , isiHeadTime :: !Timestamp
 209   -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest
 210   -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to
 211   -- 'isiMaxTime'.
 212   }
 213
 214 emptyStateInfo :: IndexStateInfo
 215 emptyStateInfo = IndexStateInfo NoTimestamp NoTimestamp
 216
 217 -- | Filters a 'Cache' according to an 'IndexState'
 218 -- specification. Also returns 'IndexStateInfo' describing the
 219 -- resulting index cache.
 220 --
 221 -- Note: 'filterCache' is idempotent in the 'Cache' value
 222 filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo)
 223 filterCache IndexStateHead cache = (cache, IndexStateInfo{..})
 224   where
 225     isiMaxTime = cacheHeadTs cache
 226     isiHeadTime = cacheHeadTs cache
 227 filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
 228   where
 229     cache = Cache{cacheEntries = ents, cacheHeadTs = isiMaxTime}
 230     isiHeadTime = cacheHeadTs cache0
 231     isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents)
 232     ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)
 233
 234 -- | Read a repository index from disk, from the local files specified by
 235 -- a list of 'Repo's.
 236 --
 237 -- All the 'SourcePackage's are marked as having come from the appropriate
 238 -- 'Repo'.
 239 --
 240 -- This is a higher level wrapper used internally in cabal-install.
 241 getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
 242 getSourcePackages verbosity repoCtxt =
 243   fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
 244
 245 -- | Variant of 'getSourcePackages' which allows getting the source
 246 -- packages at a particular 'IndexState'.
 247 --
 248 -- Current choices are either the latest (aka HEAD), or the index as
 249 -- it was at a particular time.
 250 --
 251 -- Returns also the total index where repositories'
 252 -- RepoIndexState's are not HEAD. This is used in v2-freeze.
 253 getSourcePackagesAtIndexState
 254   :: Verbosity
 255   -> RepoContext
 256   -> Maybe TotalIndexState
 257   -> Maybe ActiveRepos
 258   -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
 259 getSourcePackagesAtIndexState verbosity repoCtxt _ _
 260   | null (repoContextRepos repoCtxt) = do
 261       -- In the test suite, we routinely don't have any remote package
 262       -- servers, so don't bleat about it
 263       warn (verboseUnmarkOutput verbosity) $
 264         "No remote package servers have been specified. Usually "
 265           ++ "you would have one specified in the config file."
 266       return
 267         ( SourcePackageDb
 268             { packageIndex = mempty
 269             , packagePreferences = mempty
 270             }
 271         , headTotalIndexState
 272         , ActiveRepos []
 273         )
 274 getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
 275   let describeState IndexStateHead = "most recent state"
 276       describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
 277
 278   pkgss <- for (repoContextRepos repoCtxt) $ \r -> do
 279     let rname :: RepoName
 280         rname = repoName r
 281
 282     info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
 283
 284     idxState <- case mb_idxState of
 285       Just totalIdxState -> do
 286         let idxState = lookupIndexState rname totalIdxState
 287         info verbosity $
 288           "Using "
 289             ++ describeState idxState
 290             ++ " as explicitly requested (via command line / project configuration)"
 291         return idxState
 292       Nothing -> do
 293         mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
 294         case mb_idxState' of
 295           Nothing -> do
 296             info verbosity "Using most recent state (could not read timestamp file)"
 297             return IndexStateHead
 298           Just idxState -> do
 299             info verbosity $
 300               "Using "
 301                 ++ describeState idxState
 302                 ++ " specified from most recent cabal update"
 303             return idxState
 304
 305     unless (idxState == IndexStateHead) $
 306       case r of
 307         RepoLocalNoIndex{} -> warn verbosity "index-state ignored for file+noindex repositories"
 308         RepoRemote{} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")
 309         RepoSecure{} -> pure ()
 310
 311     let idxState' = case r of
 312           RepoSecure{} -> idxState
 313           _ -> IndexStateHead
 314
 315     (pis, deps, isi) <- readRepoIndex verbosity repoCtxt r idxState'
 316
 317     case idxState' of
 318       IndexStateHead -> do
 319         info verbosity ("index-state(" ++ unRepoName rname ++ ") = " ++ prettyShow (isiHeadTime isi))
 320         return ()
 321       IndexStateTime ts0 ->
 322         -- isiMaxTime is the latest timestamp in the filtered view returned by
 323         -- `readRepoIndex` above. It is always true that isiMaxTime is less or
 324         -- equal to a requested IndexStateTime. When `isiMaxTime isi /= ts0` (or
 325         -- equivalently `isiMaxTime isi < ts0`) it means that ts0 falls between
 326         -- two timestamps in the index.
 327         when (isiMaxTime isi /= ts0) $
 328           let commonMsg =
 329                 "There is no index-state for '"
 330                   ++ unRepoName rname
 331                   ++ "' exactly at the requested timestamp ("
 332                   ++ prettyShow ts0
 333                   ++ "). "
 334            in if isNothing $ timestampToUTCTime (isiMaxTime isi)
 335                 then
 336                   warn verbosity $
 337                     commonMsg
 338                       ++ "Also, there are no index-states before the one requested, so the repository '"
 339                       ++ unRepoName rname
 340                       ++ "' will be empty."
 341                 else
 342                   info verbosity $
 343                     commonMsg
 344                       ++ "Falling back to the previous index-state that exists: "
 345                       ++ prettyShow (isiMaxTime isi)
 346     pure
 347       RepoData
 348         { rdRepoName = rname
 349         , rdTimeStamp = isiMaxTime isi
 350         , rdIndex = pis
 351         , rdPreferences = deps
 352         }
 353
 354   let activeRepos :: ActiveRepos
 355       activeRepos = fromMaybe defaultActiveRepos mb_activeRepos
 356
 357   pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of
 358     Right x -> return x
 359     Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)
 360
 361   let activeRepos' :: ActiveRepos
 362       activeRepos' =
 363         ActiveRepos
 364           [ ActiveRepo (rdRepoName rd) strategy
 365           | (rd, strategy) <- pkgss'
 366           ]
 367
 368   let totalIndexState :: TotalIndexState
 369       totalIndexState =
 370         makeTotalIndexState IndexStateHead $
 371           Map.fromList
 372             [ (n, IndexStateTime ts)
 373             | (RepoData n ts _idx _prefs, _strategy) <- pkgss'
 374             , -- e.g. file+noindex have nullTimestamp as their timestamp
 375             ts /= NoTimestamp
 376             ]
 377
 378   let addIndex
 379         :: PackageIndex UnresolvedSourcePackage
 380         -> (RepoData, CombineStrategy)
 381         -> PackageIndex UnresolvedSourcePackage
 382       addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc
 383       addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx
 384       addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx
 385
 386   let pkgs :: PackageIndex UnresolvedSourcePackage
 387       pkgs = foldl' addIndex mempty pkgss'
 388
 389   -- Note: preferences combined without using CombineStrategy
 390   let prefs :: Map PackageName VersionRange
 391       prefs =
 392         Map.fromListWith
 393           intersectVersionRanges
 394           [ (name, range)
 395           | (RepoData _n _ts _idx prefs', _strategy) <- pkgss'
 396           , Dependency name range _ <- prefs'
 397           ]
 398
 399   _ <- evaluate pkgs
 400   _ <- evaluate prefs
 401   _ <- evaluate totalIndexState
 402   return
 403     ( SourcePackageDb
 404         { packageIndex = pkgs
 405         , packagePreferences = prefs
 406         }
 407     , totalIndexState
 408     , activeRepos'
 409     )
 410
 411 -- auxiliary data used in getSourcePackagesAtIndexState
 412 data RepoData = RepoData
 413   { rdRepoName :: RepoName
 414   , rdTimeStamp :: Timestamp
 415   , rdIndex :: PackageIndex UnresolvedSourcePackage
 416   , rdPreferences :: [Dependency]
 417   }
 418
 419 -- | Read a repository index from disk, from the local file specified by
 420 -- the 'Repo'.
 421 --
 422 -- All the 'SourcePackage's are marked as having come from the given 'Repo'.
 423 --
 424 -- This is a higher level wrapper used internally in cabal-install.
 425 readRepoIndex
 426   :: Verbosity
 427   -> RepoContext
 428   -> Repo
 429   -> RepoIndexState
 430   -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
 431 readRepoIndex verbosity repoCtxt repo idxState =
 432   handleNotFound $ do
 433     ret@(_, _, isi) <-
 434       readPackageIndexCacheFile
 435         verbosity
 436         mkAvailablePackage
 437         (RepoIndex repoCtxt repo)
 438         idxState
 439     when (isRepoRemote repo) $ do
 440       warnIfIndexIsOld =<< getIndexFileAge repo
 441       dieIfRequestedIdxIsNewer isi
 442     pure ret
 443   where
 444     mkAvailablePackage pkgEntry =
 445       SourcePackage
 446         { srcpkgPackageId = pkgid
 447         , srcpkgDescription = pkgdesc
 448         , srcpkgSource = case pkgEntry of
 449             NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing
 450             BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path
 451         , srcpkgDescrOverride = case pkgEntry of
 452             NormalPackage _ _ pkgtxt _ -> Just pkgtxt
 453             _ -> Nothing
 454         }
 455       where
 456         pkgdesc = packageDesc pkgEntry
 457         pkgid = packageId pkgEntry
 458
 459     handleNotFound action = catchIO action $ \e ->
 460       if isDoesNotExistError e
 461         then do
 462           case repo of
 463             RepoRemote{..} -> dieWithException verbosity $ MissingPackageList repoRemote
 464             RepoSecure{..} -> dieWithException verbosity $ MissingPackageList repoRemote
 465             RepoLocalNoIndex local _ ->
 466               warn verbosity $
 467                 "Error during construction of local+noindex "
 468                   ++ unRepoName (localRepoName local)
 469                   ++ " repository index: "
 470                   ++ show e
 471           return (mempty, mempty, emptyStateInfo)
 472         else ioError e
 473
 474     isOldThreshold :: Double
 475     isOldThreshold = 15 -- days
 476     warnIfIndexIsOld dt = do
 477       when (dt >= isOldThreshold) $ case repo of
 478         RepoRemote{..} -> warn verbosity $ warnOutdatedPackageList repoRemote dt
 479         RepoSecure{..} -> warn verbosity $ warnOutdatedPackageList repoRemote dt
 480         RepoLocalNoIndex{} -> return ()
 481
 482     dieIfRequestedIdxIsNewer isi =
 483       let latestTime = isiHeadTime isi
 484        in case idxState of
 485             IndexStateTime t -> when (t > latestTime) $ case repo of
 486               RepoSecure{..} ->
 487                 dieWithException verbosity $ UnusableIndexState repoRemote latestTime t
 488               RepoRemote{} -> pure ()
 489               RepoLocalNoIndex{} -> return ()
 490             IndexStateHead -> pure ()
 491
 492     warnOutdatedPackageList repoRemote dt =
 493       "The package list for '"
 494         ++ unRepoName (remoteRepoName repoRemote)
 495         ++ "' is "
 496         ++ shows (floor dt :: Int) " days old.\nRun "
 497         ++ "'cabal update' to get the latest list of available packages."
 498
 499 -- | Return the age of the index file in days (as a Double).
 500 getIndexFileAge :: Repo -> IO Double
 501 getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"
 502
 503 -- | A set of files (or directories) that can be monitored to detect when
 504 -- there might have been a change in the source packages.
 505 getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
 506 getSourcePackagesMonitorFiles repos =
 507   concat
 508     [ [ indexBaseName repo <.> "cache"
 509       , indexBaseName repo <.> "timestamp"
 510       ]
 511     | repo <- repos
 512     ]
 513
 514 -- | It is not necessary to call this, as the cache will be updated when the
 515 -- index is read normally. However you can do the work earlier if you like.
 516 updateRepoIndexCache :: Verbosity -> Index -> IO ()
 517 updateRepoIndexCache verbosity index =
 518   whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index
 519
 520 whenCacheOutOfDate :: Index -> IO () -> IO ()
 521 whenCacheOutOfDate index action = do
 522   exists <- doesFileExist $ cacheFile index
 523   if not exists
 524     then action
 525     else
 526       if localNoIndex index
 527         then return () -- TODO: don't update cache for local+noindex repositories
 528         else do
 529           indexTime <- getModTime $ indexFile index
 530           cacheTime <- getModTime $ cacheFile index
 531           when (indexTime > cacheTime) action
 532
 533 localNoIndex :: Index -> Bool
 534 localNoIndex (RepoIndex _ (RepoLocalNoIndex{})) = True
 535 localNoIndex _ = False
 536
 537 ------------------------------------------------------------------------
 538 -- Reading the index file
 539 --
 540
 541 -- | An index entry is either a normal package, or a local build tree reference.
 542 data PackageEntry
 543   = NormalPackage PackageId GenericPackageDescription ByteString BlockNo
 544   | BuildTreeRef
 545       BuildTreeRefType
 546       PackageId
 547       GenericPackageDescription
 548       FilePath
 549       BlockNo
 550
 551 -- | A build tree reference is either a link or a snapshot.
 552 data BuildTreeRefType = SnapshotRef | LinkRef
 553   deriving (Eq, Show, Generic)
 554
 555 instance Binary BuildTreeRefType
 556 instance Structured BuildTreeRefType
 557
 558 refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType
 559 refTypeFromTypeCode t
 560   | t == Tar.buildTreeRefTypeCode = LinkRef
 561   | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef
 562   | otherwise =
 563       error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"
 564
 565 typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode
 566 typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode
 567 typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode
 568
 569 instance Package PackageEntry where
 570   packageId (NormalPackage pkgid _ _ _) = pkgid
 571   packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
 572
 573 packageDesc :: PackageEntry -> GenericPackageDescription
 574 packageDesc (NormalPackage _ descr _ _) = descr
 575 packageDesc (BuildTreeRef _ _ descr _ _) = descr
 576
 577 -- | Parse an uncompressed \"00-index.tar\" repository index file represented
 578 -- as a 'ByteString'.
 579 data PackageOrDep = Pkg PackageEntry | Dep Dependency
 580
 581 -- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files
 582 --
 583 -- We read the index using 'Tar.read', which gives us a lazily constructed
 584 -- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',
 585 -- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a
 586 -- function over this to translate it to a list of IO actions returning
 587 -- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of
 588 -- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.
 589 parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
 590 parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read
 591   where
 592     extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
 593     extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
 594       where
 595         tryExtractPkg = do
 596           mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo
 597           return $ fmap (fmap Pkg) mkPkgEntry
 598
 599         tryExtractPrefs = do
 600           prefs' <- maybeToList $ extractPrefs entry
 601           fmap (return . Just . Dep) prefs'
 602
 603 -- | Turn the 'Entries' data structure from the @tar@ package into a list,
 604 -- and pair each entry with its block number.
 605 --
 606 -- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read
 607 -- as far as the list is evaluated.
 608 tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
 609 tarEntriesList = go 0
 610   where
 611     go !_ Tar.Done = []
 612     go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e)
 613     go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
 614
 615 extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
 616 extractPkg verbosity entry blockNo = case Tar.entryContent entry of
 617   Tar.NormalFile content _
 618     | takeExtension fileName == ".cabal" ->
 619         case splitDirectories (normalise fileName) of
 620           [pkgname, vers, _] -> case simpleParsec vers of
 621             Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
 622               where
 623                 pkgid = PackageIdentifier (mkPackageName pkgname) ver
 624                 parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)
 625                 descr = case parsed of
 626                   Just d -> d
 627                   Nothing ->
 628                     error $
 629                       "Couldn't read cabal file "
 630                         ++ show fileName
 631             _ -> Nothing
 632           _ -> Nothing
 633   Tar.OtherEntryType typeCode content _
 634     | Tar.isBuildTreeRefTypeCode typeCode ->
 635         Just $ do
 636           let path = byteStringToFilePath content
 637           dirExists <- doesDirectoryExist path
 638           if not dirExists
 639             then return Nothing
 640             else do
 641               cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index."
 642               descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile
 643               return . Just $
 644                 BuildTreeRef
 645                   (refTypeFromTypeCode typeCode)
 646                   (packageId descr)
 647                   descr
 648                   path
 649                   blockNo
 650   _ -> Nothing
 651   where
 652     fileName = Tar.entryPath entry
 653
 654 extractPrefs :: Tar.Entry -> Maybe [Dependency]
 655 extractPrefs entry = case Tar.entryContent entry of
 656   Tar.NormalFile content _
 657     | isPreferredVersions entrypath ->
 658         Just prefs
 659     where
 660       entrypath = Tar.entryPath entry
 661       prefs = parsePreferredVersions content
 662   _ -> Nothing
 663
 664 ------------------------------------------------------------------------
 665 -- Filename and parsers for 'preferred-versions' file.
 666 --
 667
 668 -- | Expected name of the 'preferred-versions' file.
 669 --
 670 -- Contains special constraints, such as a preferred version of a package
 671 -- or deprecations of certain package versions.
 672 --
 673 -- Expected format:
 674 --
 675 -- @
 676 -- binary > 0.9.0.0 || < 0.9.0.0
 677 -- text == 1.2.1.0
 678 -- @
 679 preferredVersions :: FilePath
 680 preferredVersions = "preferred-versions"
 681
 682 -- | Does the given filename match with the expected name of 'preferred-versions'?
 683 isPreferredVersions :: FilePath -> Bool
 684 isPreferredVersions = (== preferredVersions) . takeFileName
 685
 686 -- | Parse `preferred-versions` file, ignoring any parse failures.
 687 --
 688 -- To obtain parse errors, use 'parsePreferredVersionsWarnings'.
 689 parsePreferredVersions :: ByteString -> [Dependency]
 690 parsePreferredVersions = rights . parsePreferredVersionsWarnings
 691
 692 -- | Parser error of the `preferred-versions` file.
 693 data PreferredVersionsParseError = PreferredVersionsParseError
 694   { preferredVersionsParsecError :: String
 695   -- ^ Parser error to show to a user.
 696   , preferredVersionsOriginalDependency :: String
 697   -- ^ Original input that produced the parser error.
 698   }
 699   deriving (Generic, Read, Show, Eq, Ord, Typeable)
 700
 701 -- | Parse `preferred-versions` file, collecting parse errors that can be shown
 702 -- in error messages.
 703 parsePreferredVersionsWarnings
 704   :: ByteString
 705   -> [Either PreferredVersionsParseError Dependency]
 706 parsePreferredVersionsWarnings =
 707   map parsePreference
 708     . filter (not . isPrefixOf "--")
 709     . lines
 710     . fromUTF8LBS
 711   where
 712     parsePreference :: String -> Either PreferredVersionsParseError Dependency
 713     parsePreference s = case eitherParsec s of
 714       Left err ->
 715         Left $
 716           PreferredVersionsParseError
 717             { preferredVersionsParsecError = err
 718             , preferredVersionsOriginalDependency = s
 719             }
 720       Right dep -> Right dep
 721
 722 ------------------------------------------------------------------------
 723 -- Reading and updating the index cache
 724 --
 725
 726 -- | Variation on 'sequence' which evaluates the actions lazily
 727 --
 728 -- Pattern matching on the result list will execute just the first action;
 729 -- more generally pattern matching on the first @n@ '(:)' nodes will execute
 730 -- the first @n@ actions.
 731 lazySequence :: [IO a] -> IO [a]
 732 lazySequence = unsafeInterleaveIO . go
 733   where
 734     go [] = return []
 735     go (x : xs) = do
 736       x' <- x
 737       xs' <- lazySequence xs
 738       return (x' : xs')
 739
 740 -- | A lazy unfolder for lookup operations which return the current
 741 -- value and (possibly) the next key
 742 lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k, v)]
 743 lazyUnfold step = goLazy . Just
 744   where
 745     goLazy s = unsafeInterleaveIO (go s)
 746
 747     go Nothing = return []
 748     go (Just k) = do
 749       (v, mk') <- step k
 750       vs' <- goLazy mk'
 751       return ((k, v) : vs')
 752
 753 -- | Which index do we mean?
 754 data Index
 755   = -- | The main index for the specified repository
 756     RepoIndex RepoContext Repo
 757
 758 indexFile :: Index -> FilePath
 759 indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"
 760
 761 cacheFile :: Index -> FilePath
 762 cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"
 763
 764 timestampFile :: Index -> FilePath
 765 timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"
 766
 767 -- | Return 'True' if 'Index' uses 01-index format (aka secure repo)
 768 is01Index :: Index -> Bool
 769 is01Index (RepoIndex _ repo) = case repo of
 770   RepoSecure{} -> True
 771   RepoRemote{} -> False
 772   RepoLocalNoIndex{} -> True
 773
 774 updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
 775 updatePackageIndexCacheFile verbosity index = do
 776   info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")
 777   withIndexEntries verbosity index callback callbackNoIndex
 778   where
 779     callback entries = do
 780       let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)
 781           cache =
 782             Cache
 783               { cacheHeadTs = maxTs
 784               , cacheEntries = entries
 785               }
 786       writeIndexCache index cache
 787       info
 788         verbosity
 789         ( "Index cache updated to index-state "
 790             ++ prettyShow (cacheHeadTs cache)
 791         )
 792
 793     callbackNoIndex entries = do
 794       writeNoIndexCache verbosity index $ NoIndexCache entries
 795       info verbosity "Index cache updated"
 796
 797 -- | Read the index (for the purpose of building a cache)
 798 --
 799 -- The callback is provided with list of cache entries, which is guaranteed to
 800 -- be lazily constructed. This list must ONLY be used in the scope of the
 801 -- callback; when the callback is terminated the file handle to the index will
 802 -- be closed and further attempts to read from the list will result in (pure)
 803 -- I/O exceptions.
 804 --
 805 -- In the construction of the index for a secure repo we take advantage of the
 806 -- index built by the @hackage-security@ library to avoid reading the @.tar@
 807 -- file as much as possible (we need to read it only to extract preferred
 808 -- versions). This helps performance, but is also required for correctness:
 809 -- the new @01-index.tar.gz@ may have multiple versions of preferred-versions
 810 -- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);
 811 -- by reading the already-built cache from the security library we will be sure
 812 -- to only read the latest versions of all files.
 813 --
 814 -- TODO: It would be nicer if we actually incrementally updated @cabal@'s
 815 -- cache, rather than reconstruct it from zero on each update. However, this
 816 -- would require a change in the cache format.
 817 withIndexEntries
 818   :: Verbosity
 819   -> Index
 820   -> ([IndexCacheEntry] -> IO a)
 821   -> ([NoIndexCacheEntry] -> IO a)
 822   -> IO a
 823 withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ =
 824   repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
 825     Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
 826       -- Incrementally (lazily) read all the entries in the tar file in order,
 827       -- including all revisions, not just the last revision of each file
 828       indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)
 829       callback
 830         [ cacheEntry
 831         | (dirEntry, indexEntry) <- indexEntries
 832         , cacheEntry <- toCacheEntries dirEntry indexEntry
 833         ]
 834   where
 835     toCacheEntries
 836       :: Sec.DirectoryEntry
 837       -> Sec.Some Sec.IndexEntry
 838       -> [IndexCacheEntry]
 839     toCacheEntries dirEntry (Sec.Some sie) =
 840       case Sec.indexEntryPathParsed sie of
 841         Nothing -> [] -- skip unrecognized file
 842         Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata
 843         Just (Sec.IndexPkgCabal pkgId) ->
 844           force
 845             [CachePackageId pkgId blockNo timestamp]
 846         Just (Sec.IndexPkgPrefs _pkgName) ->
 847           force
 848             [ CachePreference dep blockNo timestamp
 849             | dep <- parsePreferredVersions (Sec.indexEntryContent sie)
 850             ]
 851       where
 852         blockNo = Sec.directoryEntryBlockNo dirEntry
 853         timestamp =
 854           epochTimeToTimestamp $
 855             Sec.indexEntryTime sie
 856 withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do
 857   dirContents <- listDirectory localDir
 858   let contentSet = Set.fromList dirContents
 859
 860   entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do
 861     case isTarGz file of
 862       Nothing
 863         | isPreferredVersions file -> do
 864             contents <- BS.readFile (localDir </> file)
 865             let versionPreferencesParsed = parsePreferredVersionsWarnings contents
 866             let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed
 867             unless (null warnings) $ do
 868               warn verbosity $
 869                 "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: "
 870                   ++ (localDir </> file)
 871               for_ warnings $ \err -> do
 872                 warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err
 873                 warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err
 874             return $ Just $ NoIndexCachePreference versionPreferences
 875         | otherwise -> do
 876             unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $
 877               info verbosity $
 878                 "Skipping " ++ file
 879             return Nothing
 880       Just pkgid | cabalPath `Set.member` contentSet -> do
 881         contents <- BSS.readFile (localDir </> cabalPath)
 882         for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->
 883           return (CacheGPD gpd contents)
 884         where
 885           cabalPath = prettyShow pkgid ++ ".cabal"
 886       Just pkgId -> do
 887         -- check for the right named .cabal file in the compressed tarball
 888         tarGz <- BS.readFile (localDir </> file)
 889         let tar = GZip.decompress tarGz
 890             entries = Tar.read tar
 891
 892         case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of
 893           Just ce -> return (Just ce)
 894           Nothing -> dieWithException verbosity $ CannotReadCabalFile file
 895
 896   let (prefs, gpds) =
 897         partitionEithers $
 898           map
 899             ( \case
 900                 NoIndexCachePreference deps -> Left deps
 901                 CacheGPD gpd _ -> Right gpd
 902             )
 903             entries
 904
 905   info verbosity $ "Entries in file+noindex repository " ++ unRepoName name
 906   for_ gpds $ \gpd ->
 907     info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)
 908   unless (null prefs) $ do
 909     info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name
 910     for_ (concat prefs) $ \pref ->
 911       info verbosity ("* " ++ prettyShow pref)
 912
 913   callback entries
 914   where
 915     handler :: IOException -> IO a
 916     handler e = dieWithException verbosity $ ErrorUpdatingIndex (unRepoName name) e
 917
 918     isTarGz :: FilePath -> Maybe PackageIdentifier
 919     isTarGz fp = do
 920       pfx <- stripSuffix ".tar.gz" fp
 921       simpleParsec pfx
 922
 923     stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str))
 924
 925     -- look for <pkgid>/<pkgname>.cabal inside the tarball
 926     readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry
 927     readCabalEntry pkgId entry Nothing
 928       | filename == Tar.entryPath entry
 929       , Tar.NormalFile contents _ <- Tar.entryContent entry =
 930           let bs = BS.toStrict contents
 931            in ((`CacheGPD` bs) <$> parseGenericPackageDescriptionMaybe bs)
 932       where
 933         filename = prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"
 934     readCabalEntry _ _ x = x
 935 withIndexEntries verbosity index callback _ = do
 936   -- non-secure repositories
 937   withFile (indexFile index) ReadMode $ \h -> do
 938     bs <- maybeDecompress `fmap` BS.hGetContents h
 939     pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs
 940     callback $ map toCache (catMaybes pkgsOrPrefs)
 941   where
 942     toCache :: PackageOrDep -> IndexCacheEntry
 943     toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo NoTimestamp
 944     toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
 945     toCache (Dep d) = CachePreference d 0 NoTimestamp
 946
 947 -- | Read package data from a repository.
 948 -- Throws IOException if any arise while accessing the index
 949 -- (unless the repo is local+no-index) and dies if the cache
 950 -- is corrupted and cannot be regenerated correctly.
 951 readPackageIndexCacheFile
 952   :: Package pkg
 953   => Verbosity
 954   -> (PackageEntry -> pkg)
 955   -> Index
 956   -> RepoIndexState
 957   -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
 958 readPackageIndexCacheFile verbosity mkPkg index idxState
 959   | localNoIndex index = do
 960       cache0 <- readNoIndexCache verbosity index
 961       (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0
 962       pure (pkgs, prefs, emptyStateInfo)
 963   | otherwise = do
 964       (cache, isi) <- getIndexCache verbosity index idxState
 965       indexHnd <- openFile (indexFile index) ReadMode
 966       (pkgs, deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache
 967       pure (pkgs, deps, isi)
 968
 969 -- | Read 'Cache' and 'IndexStateInfo' from the repository index file.
 970 -- Throws IOException if any arise (e.g. the index or its cache are missing).
 971 -- Dies if the index cache is corrupted and cannot be regenerated correctly.
 972 getIndexCache :: Verbosity -> Index -> RepoIndexState -> IO (Cache, IndexStateInfo)
 973 getIndexCache verbosity index idxState =
 974   filterCache idxState <$> readIndexCache verbosity index
 975
 976 packageIndexFromCache
 977   :: Package pkg
 978   => Verbosity
 979   -> (PackageEntry -> pkg)
 980   -> Handle
 981   -> Cache
 982   -> IO (PackageIndex pkg, [Dependency])
 983 packageIndexFromCache verbosity mkPkg hnd cache = do
 984   (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache
 985   pkgIndex <- evaluate $ PackageIndex.fromList pkgs
 986   return (pkgIndex, prefs)
 987
 988 packageNoIndexFromCache
 989   :: forall pkg
 990    . Package pkg
 991   => Verbosity
 992   -> (PackageEntry -> pkg)
 993   -> NoIndexCache
 994   -> IO (PackageIndex pkg, [Dependency])
 995 packageNoIndexFromCache _verbosity mkPkg cache = do
 996   let (pkgs, prefs) = packageListFromNoIndexCache
 997   pkgIndex <- evaluate $ PackageIndex.fromList pkgs
 998   pure (pkgIndex, prefs)
 999   where
1000     packageListFromNoIndexCache :: ([pkg], [Dependency])
1001     packageListFromNoIndexCache = foldr go mempty (noIndexCacheEntries cache)
1002
1003     go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])
1004     go (CacheGPD gpd bs) (pkgs, prefs) =
1005       let pkgId = package $ Distribution.PackageDescription.packageDescription gpd
1006        in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs)
1007     go (NoIndexCachePreference deps) (pkgs, prefs) =
1008       (pkgs, deps ++ prefs)
1009
1010 -- | Read package list
1011 --
1012 -- The result package releases and preference entries are guaranteed
1013 -- to be unique.
1014 --
1015 -- Note: 01-index.tar is an append-only index and therefore contains
1016 -- all .cabal edits and preference-updates. The masking happens
1017 -- here, i.e. the semantics that later entries in a tar file mask
1018 -- earlier ones is resolved in this function.
1019 packageListFromCache
1020   :: Verbosity
1021   -> (PackageEntry -> pkg)
1022   -> Handle
1023   -> Cache
1024   -> IO ([pkg], [Dependency])
1025 packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries
1026   where
1027     accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
1028     accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do
1029       -- Given the cache entry, make a package index entry.
1030       -- The magic here is that we use lazy IO to read the .cabal file
1031       -- from the index tarball if it turns out that we need it.
1032       -- Most of the time we only need the package id.
1033       ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
1034         pkgtxt <- getEntryContent blockno
1035         pkg <- readPackageDescription pkgid pkgtxt
1036         return (pkg, pkgtxt)
1037
1038       let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
1039       accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
1040     accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
1041       -- We have to read the .cabal file eagerly here because we can't cache the
1042       -- package id for build tree references - the user might edit the .cabal
1043       -- file after the reference was added to the index.
1044       path <- fmap byteStringToFilePath . getEntryContent $ blockno
1045       pkg <- do
1046         let err = "Error reading package index from cache."
1047         file <- tryFindAddSourcePackageDesc verbosity path err
1048         PackageDesc.Parse.readGenericPackageDescription normal file
1049       let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
1050       accum srcpkgs (srcpkg : btrs) prefs entries
1051     accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) =
1052       accum srcpkgs btrs (Map.insert pn pref prefs) entries
1053
1054     getEntryContent :: BlockNo -> IO ByteString
1055     getEntryContent blockno = do
1056       entry <- Tar.hReadEntry hnd blockno
1057       case Tar.entryContent entry of
1058         Tar.NormalFile content _size -> return content
1059         Tar.OtherEntryType typecode content _size
1060           | Tar.isBuildTreeRefTypeCode typecode ->
1061               return content
1062         _ -> interror "unexpected tar entry type"
1063
1064     readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription
1065     readPackageDescription pkgid content =
1066       case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of
1067         Right gpd -> return gpd
1068         Left (Just specVer, _) | specVer >= mkVersion [2, 2] -> return (dummyPackageDescription specVer)
1069         Left _ -> interror "failed to parse .cabal file"
1070       where
1071         dummyPackageDescription :: Version -> GenericPackageDescription
1072         dummyPackageDescription specVer =
1073           GenericPackageDescription
1074             { packageDescription =
1075                 emptyPackageDescription
1076                   { package = pkgid
1077                   , synopsis = dummySynopsis
1078                   }
1079             , gpdScannedVersion = Just specVer -- tells index scanner to skip this file.
1080             , genPackageFlags = []
1081             , condLibrary = Nothing
1082             , condSubLibraries = []
1083             , condForeignLibs = []
1084             , condExecutables = []
1085             , condTestSuites = []
1086             , condBenchmarks = []
1087             }
1088
1089         dummySynopsis = "<could not be parsed due to unsupported CABAL spec-version>"
1090
1091     interror :: String -> IO a
1092     interror msg =
1093       dieWithException verbosity $ InternalError msg
1094
1095 ------------------------------------------------------------------------
1096 -- Index cache data structure --
1097
1098 -- | Read a repository cache from the filesystem
1099 --
1100 -- If a corrupted index cache is detected this function regenerates
1101 -- the index cache and then reattempt to read the index once (and
1102 -- 'dieWithException's if it fails again).
1103 readIndexCache :: Verbosity -> Index -> IO Cache
1104 readIndexCache verbosity index = do
1105   cacheOrFail <- readIndexCache' index
1106   case cacheOrFail of
1107     Left msg -> do
1108       warn verbosity $
1109         concat
1110           [ "Parsing the index cache failed ("
1111           , msg
1112           , "). "
1113           , "Trying to regenerate the index cache..."
1114           ]
1115
1116       updatePackageIndexCacheFile verbosity index
1117
1118       either (dieWithException verbosity . CorruptedIndexCache) (return . hashConsCache) =<< readIndexCache' index
1119     Right res -> return (hashConsCache res)
1120
1121 -- | Read a no-index repository cache from the filesystem
1122 --
1123 -- If a corrupted index cache is detected this function regenerates
1124 -- the index cache and then reattempts to read the index once (and
1125 -- 'dieWithException's if it fails again). Throws IOException if any arise.
1126 readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
1127 readNoIndexCache verbosity index = do
1128   cacheOrFail <- readNoIndexCache' index
1129   case cacheOrFail of
1130     Left msg -> do
1131       warn verbosity $
1132         concat
1133           [ "Parsing the index cache failed ("
1134           , msg
1135           , "). "
1136           , "Trying to regenerate the index cache..."
1137           ]
1138
1139       updatePackageIndexCacheFile verbosity index
1140
1141       either (dieWithException verbosity . CorruptedIndexCache) return =<< readNoIndexCache' index
1142
1143     -- we don't hash cons local repository cache, they are hopefully small
1144     Right res -> return res
1145
1146 -- | Read the 'Index' cache from the filesystem. Throws IO exceptions
1147 -- if any arise and returns Left on invalid input.
1148 readIndexCache' :: Index -> IO (Either String Cache)
1149 readIndexCache' index
1150   | is01Index index =
1151       structuredDecodeFileOrFail (cacheFile index)
1152   | otherwise =
1153       Right . read00IndexCache <$> BSS.readFile (cacheFile index)
1154
1155 readNoIndexCache' :: Index -> IO (Either String NoIndexCache)
1156 readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)
1157
1158 -- | Write the 'Index' cache to the filesystem
1159 writeIndexCache :: Index -> Cache -> IO ()
1160 writeIndexCache index cache
1161   | is01Index index = structuredEncodeFile (cacheFile index) cache
1162   | otherwise = writeFile (cacheFile index) (show00IndexCache cache)
1163
1164 writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()
1165 writeNoIndexCache verbosity index cache = do
1166   let path = cacheFile index
1167   createDirectoryIfMissingVerbose verbosity True (takeDirectory path)
1168   structuredEncodeFile path cache
1169
1170 -- | Write the 'IndexState' to the filesystem
1171 writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
1172 writeIndexTimestamp index st =
1173   writeFile (timestampFile index) (prettyShow st)
1174
1175 -- | Read out the "current" index timestamp, i.e., what
1176 -- timestamp you would use to revert to this version.
1177 --
1178 -- Note: this is not the same as 'readIndexTimestamp'!
1179 -- This resolves HEAD to the index's 'isiHeadTime', i.e.
1180 -- the index latest known timestamp.
1181 --
1182 -- Return NoTimestamp if the index has never been updated.
1183 currentIndexTimestamp :: Verbosity -> Index -> IO Timestamp
1184 currentIndexTimestamp verbosity index = do
1185   mb_is <- readIndexTimestamp verbosity index
1186   case mb_is of
1187     -- If the index timestamp file specifies an index state time, use that
1188     Just (IndexStateTime ts) ->
1189       return ts
1190     -- Otherwise used the head time as stored in the index cache
1191     _otherwise ->
1192       fmap (isiHeadTime . snd) (getIndexCache verbosity index IndexStateHead)
1193         `catchIO` \e ->
1194           if isDoesNotExistError e
1195             then return NoTimestamp
1196             else ioError e
1197
1198 -- | Read the 'IndexState' from the filesystem
1199 readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)
1200 readIndexTimestamp verbosity index =
1201   fmap simpleParsec (readFile (timestampFile index))
1202     `catchIO` \e ->
1203       if isDoesNotExistError e
1204         then return Nothing
1205         else do
1206           warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e
1207           return Nothing
1208
1209 -- | Optimise sharing of equal values inside 'Cache'
1210 --
1211 -- c.f. https://en.wikipedia.org/wiki/Hash_consing
1212 hashConsCache :: Cache -> Cache
1213 hashConsCache cache0 =
1214   cache0{cacheEntries = go mempty mempty (cacheEntries cache0)}
1215   where
1216     -- TODO/NOTE:
1217     --
1218     -- If/when we redo the binary serialisation via e.g. CBOR and we
1219     -- are able to use incremental decoding, we may want to move the
1220     -- hash-consing into the incremental deserialisation, or
1221     -- alternatively even do something like
1222     -- http://cbor.schmorp.de/value-sharing
1223     --
1224     go _ _ [] = []
1225     -- for now we only optimise only CachePackageIds since those
1226     -- represent the vast majority
1227     go !pns !pvs (CachePackageId pid bno ts : rest) =
1228       CachePackageId pid' bno ts : go pns' pvs' rest
1229       where
1230         !pid' = PackageIdentifier pn' pv'
1231         (!pn', !pns') = mapIntern pn pns
1232         (!pv', !pvs') = mapIntern pv pvs
1233         PackageIdentifier pn pv = pid
1234     go pns pvs (x : xs) = x : go pns pvs xs
1235
1236     mapIntern :: Ord k => k -> Map.Map k k -> (k, Map.Map k k)
1237     mapIntern k m = maybe (k, Map.insert k k m) (\k' -> (k', m)) (Map.lookup k m)
1238
1239 -- | Cabal caches various information about the Hackage index
1240 data Cache = Cache
1241   { cacheHeadTs :: Timestamp
1242   -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the
1243   -- invariant of 'cacheEntries' being in chronological order is
1244   -- violated, this corresponds to the last (seen) 'Timestamp' in
1245   -- 'cacheEntries'
1246   , cacheEntries :: [IndexCacheEntry]
1247   }
1248   deriving (Show, Generic)
1249
1250 instance NFData Cache where
1251   rnf = rnf . cacheEntries
1252
1253 -- | Cache format for 'file+noindex' repositories
1254 newtype NoIndexCache = NoIndexCache
1255   { noIndexCacheEntries :: [NoIndexCacheEntry]
1256   }
1257   deriving (Show, Generic)
1258
1259 instance NFData NoIndexCache where
1260   rnf = rnf . noIndexCacheEntries
1261
1262 -- | Tar files are block structured with 512 byte blocks. Every header and file
1263 -- content starts on a block boundary.
1264 type BlockNo = Word32 -- Tar.TarEntryOffset
1265
1266 data IndexCacheEntry
1267   = CachePackageId PackageId !BlockNo !Timestamp
1268   | CachePreference Dependency !BlockNo !Timestamp
1269   | CacheBuildTreeRef !BuildTreeRefType !BlockNo
1270   -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build
1271   deriving (Eq, Show, Generic)
1272
1273 data NoIndexCacheEntry
1274   = CacheGPD GenericPackageDescription !BSS.ByteString
1275   | NoIndexCachePreference [Dependency]
1276   deriving (Eq, Show, Generic)
1277
1278 instance NFData IndexCacheEntry where
1279   rnf (CachePackageId pkgid _ _) = rnf pkgid
1280   rnf (CachePreference dep _ _) = rnf dep
1281   rnf (CacheBuildTreeRef _ _) = ()
1282
1283 instance NFData NoIndexCacheEntry where
1284   rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs
1285   rnf (NoIndexCachePreference dep) = rnf dep
1286
1287 cacheEntryTimestamp :: IndexCacheEntry -> Timestamp
1288 cacheEntryTimestamp (CacheBuildTreeRef _ _) = NoTimestamp
1289 cacheEntryTimestamp (CachePreference _ _ ts) = ts
1290 cacheEntryTimestamp (CachePackageId _ _ ts) = ts
1291
1292 ----------------------------------------------------------------------------
1293 -- new binary 01-index.cache format
1294
1295 instance Binary Cache
1296 instance Binary IndexCacheEntry
1297 instance Binary NoIndexCache
1298
1299 instance Structured Cache
1300 instance Structured IndexCacheEntry
1301 instance Structured NoIndexCache
1302
1303 -- | We need to save only .cabal file contents
1304 instance Binary NoIndexCacheEntry where
1305   put (CacheGPD _ bs) = do
1306     put (0 :: Word8)
1307     put bs
1308   put (NoIndexCachePreference dep) = do
1309     put (1 :: Word8)
1310     put dep
1311
1312   get = do
1313     t :: Word8 <- get
1314     case t of
1315       0 -> do
1316         bs <- get
1317         case parseGenericPackageDescriptionMaybe bs of
1318           Just gpd -> return (CacheGPD gpd bs)
1319           Nothing -> fail "Failed to parse GPD"
1320       1 -> do
1321         NoIndexCachePreference <$> get
1322       _ -> fail "Failed to parse NoIndexCacheEntry"
1323
1324 instance Structured NoIndexCacheEntry where
1325   structure = nominalStructure
1326
1327 ----------------------------------------------------------------------------
1328 -- legacy 00-index.cache format
1329
1330 packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
1331 packageKey = "pkg:"
1332 blocknoKey = "b#"
1333 buildTreeRefKey = "build-tree-ref:"
1334 preferredVersionKey = "pref-ver:"
1335
1336 -- legacy 00-index.cache format
1337 read00IndexCache :: BSS.ByteString -> Cache
1338 read00IndexCache bs =
1339   Cache
1340     { cacheHeadTs = NoTimestamp
1341     , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs
1342     }
1343
1344 read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
1345 read00IndexCacheEntry = \line ->
1346   case BSS.words line of
1347     [key, pkgnamestr, pkgverstr, sep, blocknostr]
1348       | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->
1349           case ( parseName pkgnamestr
1350                , parseVer pkgverstr []
1351                , parseBlockNo blocknostr
1352                ) of
1353             (Just pkgname, Just pkgver, Just blockno) ->
1354               Just
1355                 ( CachePackageId
1356                     (PackageIdentifier pkgname pkgver)
1357                     blockno
1358                     NoTimestamp
1359                 )
1360             _ -> Nothing
1361     [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
1362       case (parseRefType typecodestr, parseBlockNo blocknostr) of
1363         (Just refType, Just blockno) ->
1364           Just (CacheBuildTreeRef refType blockno)
1365         _ -> Nothing
1366     (key : remainder) | key == BSS.pack preferredVersionKey -> do
1367       pref <- simpleParsecBS (BSS.unwords remainder)
1368       return $ CachePreference pref 0 NoTimestamp
1369     _ -> Nothing
1370   where
1371     parseName str
1372       | BSS.all (\c -> isAlphaNum c || c == '-') str =
1373           Just (mkPackageName (BSS.unpack str))
1374       | otherwise = Nothing
1375
1376     parseVer str vs =
1377       case BSS.readInt str of
1378         Nothing -> Nothing
1379         Just (v, str') -> case BSS.uncons str' of
1380           Just ('.', str'') -> parseVer str'' (v : vs)
1381           Just _ -> Nothing
1382           Nothing -> Just (mkVersion (reverse (v : vs)))
1383
1384     parseBlockNo str =
1385       case BSS.readInt str of
1386         Just (blockno, remainder)
1387           | BSS.null remainder -> Just (fromIntegral blockno)
1388         _ -> Nothing
1389
1390     parseRefType str =
1391       case BSS.uncons str of
1392         Just (typeCode, remainder)
1393           | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode ->
1394               Just (refTypeFromTypeCode typeCode)
1395         _ -> Nothing
1396
1397 -- legacy 00-index.cache format
1398 show00IndexCache :: Cache -> String
1399 show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries
1400
1401 show00IndexCacheEntry :: IndexCacheEntry -> String
1402 show00IndexCacheEntry entry = unwords $ case entry of
1403   CachePackageId pkgid b _ ->
1404     [ packageKey
1405     , prettyShow (packageName pkgid)
1406     , prettyShow (packageVersion pkgid)
1407     , blocknoKey
1408     , show b
1409     ]
1410   CacheBuildTreeRef tr b ->
1411     [ buildTreeRefKey
1412     , [typeCodeFromRefType tr]
1413     , show b
1414     ]
1415   CachePreference dep _ _ ->
1416     [ preferredVersionKey
1417     , prettyShow dep
1418     ]