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

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