{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.IndexUtils
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Extra utils related to the package indexes.
-----------------------------------------------------------------------------
module Distribution.Client.IndexUtils (
  getIndexFileAge,
  getInstalledPackages,
  indexBaseName,
  Configure.getInstalledPackagesMonitorFiles,
  getSourcePackages,
  getSourcePackagesMonitorFiles,

  TotalIndexState,
  getSourcePackagesAtIndexState,
  ActiveRepos,
  filterSkippedActiveRepos,

  Index(..),
  RepoIndexState (..),
  PackageEntry(..),
  parsePackageIndex,
  updateRepoIndexCache,
  updatePackageIndexCacheFile,
  writeIndexTimestamp,
  currentIndexTimestamp,

  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType,
  -- * preferred-versions utilities
  preferredVersions, isPreferredVersions, parsePreferredVersionsWarnings,
  PreferredVersionsParseError(..)
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.IndexUtils.ActiveRepos
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.Types
import Distribution.Verbosity
import Distribution.Parsec (simpleParsecBS)

import Distribution.Package
         ( PackageId, PackageIdentifier(..), mkPackageName
         , Package(..), packageVersion, packageName )
import Distribution.Types.Dependency
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.PackageDescription
         ( GenericPackageDescription(..)
         , PackageDescription(..), emptyPackageDescription )
import Distribution.Simple.Compiler
         ( Compiler, PackageDBStack )
import Distribution.Simple.Program
         ( ProgramDb )
import qualified Distribution.Simple.Configure as Configure
         ( getInstalledPackages, getInstalledPackagesMonitorFiles )
import Distribution.Types.PackageName (PackageName)
import Distribution.Version
         ( Version, VersionRange, mkVersion, intersectVersionRanges )
import Distribution.Simple.Utils
         ( die', warn, info, createDirectoryIfMissingVerbose, fromUTF8LBS )
import Distribution.Client.Setup
         ( RepoContext(..) )

import Distribution.PackageDescription.Parsec
         ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe )
import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse
import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse

import           Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import           Distribution.Solver.Types.SourcePackage

import Data.Either
         ( rights )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Exception
import Data.List (stripPrefix)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Char8 as BSS
import Data.ByteString.Lazy (ByteString)
import Distribution.Client.GZipUtils (maybeDecompress)
import Distribution.Client.Utils ( byteStringToFilePath
                                 , tryFindAddSourcePackageDesc )
import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail)
import Distribution.Compat.Time (getFileAge, getModTime)
import System.Directory (doesFileExist, doesDirectoryExist)
import System.FilePath
         ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory )
import qualified System.FilePath.Posix as FilePath.Posix
import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO.Error (isDoesNotExistError)
import Distribution.Compat.Directory (listDirectory)
import Distribution.Utils.Generic (fstOf3)

import qualified Codec.Compression.GZip as GZip

import qualified Hackage.Security.Client    as Sec
import qualified Hackage.Security.Util.Some as Sec

-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
getInstalledPackages :: Verbosity -> Compiler
                     -> PackageDBStack -> ProgramDb
                     -> IO InstalledPackageIndex
getInstalledPackages :: Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStack
packageDbs ProgramDb
progdb =
    Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
Configure.getInstalledPackages Verbosity
verbosity' Compiler
comp PackageDBStack
packageDbs ProgramDb
progdb
  where
    verbosity' :: Verbosity
verbosity'  = Verbosity -> Verbosity
lessVerbose Verbosity
verbosity


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

------------------------------------------------------------------------
-- Reading the source package index
--

-- Note: 'data IndexState' is defined in
-- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles

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

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

emptyStateInfo :: IndexStateInfo
emptyStateInfo :: IndexStateInfo
emptyStateInfo = Timestamp -> Timestamp -> IndexStateInfo
IndexStateInfo Timestamp
nullTimestamp Timestamp
nullTimestamp

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

-- | Read a repository index from disk, from the local files specified by
-- a list of 'Repo's.
--
-- All the 'SourcePackage's are marked as having come from the appropriate
-- 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity RepoContext
repoCtxt =
    forall a b c. (a, b, c) -> a
fstOf3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState Verbosity
verbosity RepoContext
repoCtxt forall a. Maybe a
Nothing forall a. Maybe a
Nothing

-- | Variant of 'getSourcePackages' which allows getting the source
-- packages at a particular 'IndexState'.
--
-- Current choices are either the latest (aka HEAD), or the index as
-- it was at a particular time.
--
-- Returns also the total index where repositories'
-- RepoIndexState's are not HEAD. This is used in v2-freeze.
--
getSourcePackagesAtIndexState
    :: Verbosity
    -> RepoContext
    -> Maybe TotalIndexState
    -> Maybe ActiveRepos
    -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState :: Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> Maybe ActiveRepos
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState Verbosity
verbosity RepoContext
repoCtxt Maybe TotalIndexState
_ Maybe ActiveRepos
_
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt) = do
      -- In the test suite, we routinely don't have any remote package
      -- servers, so don't bleat about it
      Verbosity -> [Char] -> IO ()
warn (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity) forall a b. (a -> b) -> a -> b
$
        [Char]
"No remote package servers have been specified. Usually " forall a. [a] -> [a] -> [a]
++
        [Char]
"you would have one specified in the config file."
      forall (m :: * -> *) a. Monad m => a -> m a
return (SourcePackageDb {
        packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex       = forall a. Monoid a => a
mempty,
        packagePreferences :: Map PackageName VersionRange
packagePreferences = forall a. Monoid a => a
mempty
      }, TotalIndexState
headTotalIndexState, [ActiveRepoEntry] -> ActiveRepos
ActiveRepos [])
getSourcePackagesAtIndexState Verbosity
verbosity RepoContext
repoCtxt Maybe TotalIndexState
mb_idxState Maybe ActiveRepos
mb_activeRepos = do
  let describeState :: RepoIndexState -> [Char]
describeState RepoIndexState
IndexStateHead        = [Char]
"most recent state"
      describeState (IndexStateTime Timestamp
time) = [Char]
"historical state as of " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Timestamp
time

  [RepoData]
pkgss <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt) forall a b. (a -> b) -> a -> b
$ \Repo
r -> do
      let rname :: RepoName
          rname :: RepoName
rname = Repo -> RepoName
repoName Repo
r

      Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"Reading available packages of " forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname forall a. [a] -> [a] -> [a]
++ [Char]
"...")

      RepoIndexState
idxState <- case Maybe TotalIndexState
mb_idxState of
        Just TotalIndexState
totalIdxState -> do
          let idxState :: RepoIndexState
idxState = RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState RepoName
rname TotalIndexState
totalIdxState
          Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Using " forall a. [a] -> [a] -> [a]
++ RepoIndexState -> [Char]
describeState RepoIndexState
idxState forall a. [a] -> [a] -> [a]
++
            [Char]
" as explicitly requested (via command line / project configuration)"
          forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
idxState
        Maybe TotalIndexState
Nothing -> do
          Maybe RepoIndexState
mb_idxState' <- Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp Verbosity
verbosity (RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
r)
          case Maybe RepoIndexState
mb_idxState' of
            Maybe RepoIndexState
Nothing -> do
              Verbosity -> [Char] -> IO ()
info Verbosity
verbosity [Char]
"Using most recent state (could not read timestamp file)"
              forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
IndexStateHead
            Just RepoIndexState
idxState -> do
              Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Using " forall a. [a] -> [a] -> [a]
++ RepoIndexState -> [Char]
describeState RepoIndexState
idxState forall a. [a] -> [a] -> [a]
++
                [Char]
" specified from most recent cabal update"
              forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
idxState

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoIndexState
idxState forall a. Eq a => a -> a -> Bool
== RepoIndexState
IndexStateHead) forall a b. (a -> b) -> a -> b
$
          case Repo
r of
            RepoLocalNoIndex {} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
"index-state ignored for file+noindex repositories"
            RepoRemote {} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char]
"index-state ignored for old-format (remote repository '" forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname forall a. [a] -> [a] -> [a]
++ [Char]
"')")
            RepoSecure {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

      (PackageIndex UnresolvedSourcePackage
pis,[Dependency]
deps,IndexStateInfo
isi) <- Verbosity
-> RepoContext
-> Repo
-> RepoIndexState
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
readRepoIndex Verbosity
verbosity RepoContext
repoCtxt Repo
r RepoIndexState
idxState'

      case RepoIndexState
idxState' of
        RepoIndexState
IndexStateHead -> do
            Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"index-state("forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname forall a. [a] -> [a] -> [a]
++[Char]
") = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi))
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IndexStateTime Timestamp
ts0 -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi forall a. Eq a => a -> a -> Bool
/= Timestamp
ts0) forall a b. (a -> b) -> a -> b
$
                if Timestamp
ts0 forall a. Ord a => a -> a -> Bool
> IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi
                    then Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
                                   [Char]
"Requested index-state " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Timestamp
ts0
                                forall a. [a] -> [a] -> [a]
++ [Char]
" is newer than '" forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname forall a. [a] -> [a] -> [a]
++ [Char]
"'!"
                                forall a. [a] -> [a] -> [a]
++ [Char]
" Falling back to older state ("
                                forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi) forall a. [a] -> [a] -> [a]
++ [Char]
")."
                    else Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
                                   [Char]
"Requested index-state " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Timestamp
ts0
                                forall a. [a] -> [a] -> [a]
++ [Char]
" does not exist in '"forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname forall a. [a] -> [a] -> [a]
++[Char]
"'!"
                                forall a. [a] -> [a] -> [a]
++ [Char]
" Falling back to older state ("
                                forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi) forall a. [a] -> [a] -> [a]
++ [Char]
")."
            Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"index-state("forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname forall a. [a] -> [a] -> [a]
++[Char]
") = " forall a. [a] -> [a] -> [a]
++
                              forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi) forall a. [a] -> [a] -> [a]
++ [Char]
" (HEAD = " forall a. [a] -> [a] -> [a]
++
                              forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi) forall a. [a] -> [a] -> [a]
++ [Char]
")")

      forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoData
          { rdRepoName :: RepoName
rdRepoName    = RepoName
rname
          , rdTimeStamp :: Timestamp
rdTimeStamp   = IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi
          , rdIndex :: PackageIndex UnresolvedSourcePackage
rdIndex       = PackageIndex UnresolvedSourcePackage
pis
          , rdPreferences :: [Dependency]
rdPreferences = [Dependency]
deps
          }

  let activeRepos :: ActiveRepos
      activeRepos :: ActiveRepos
activeRepos = forall a. a -> Maybe a -> a
fromMaybe ActiveRepos
defaultActiveRepos Maybe ActiveRepos
mb_activeRepos

  [(RepoData, CombineStrategy)]
pkgss' <- case forall a.
ActiveRepos
-> (a -> RepoName) -> [a] -> Either [Char] [(a, CombineStrategy)]
organizeByRepos ActiveRepos
activeRepos RepoData -> RepoName
rdRepoName [RepoData]
pkgss of
    Right [(RepoData, CombineStrategy)]
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return [(RepoData, CombineStrategy)]
x
    Left [Char]
err -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (\RepoData
x -> (RepoData
x, CombineStrategy
CombineStrategyMerge)) [RepoData]
pkgss)

  let activeRepos' :: ActiveRepos
      activeRepos' :: ActiveRepos
activeRepos' = [ActiveRepoEntry] -> ActiveRepos
ActiveRepos
          [ RepoName -> CombineStrategy -> ActiveRepoEntry
ActiveRepo (RepoData -> RepoName
rdRepoName RepoData
rd) CombineStrategy
strategy
          | (RepoData
rd, CombineStrategy
strategy) <- [(RepoData, CombineStrategy)]
pkgss'
          ]

  let totalIndexState :: TotalIndexState
      totalIndexState :: TotalIndexState
totalIndexState = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
makeTotalIndexState RepoIndexState
IndexStateHead forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (RepoName
n, Timestamp -> RepoIndexState
IndexStateTime Timestamp
ts)
          | (RepoData RepoName
n Timestamp
ts PackageIndex UnresolvedSourcePackage
_idx [Dependency]
_prefs, CombineStrategy
_strategy) <- [(RepoData, CombineStrategy)]
pkgss'
          -- e.g. file+noindex have nullTimestamp as their timestamp
          , Timestamp
ts forall a. Eq a => a -> a -> Bool
/= Timestamp
nullTimestamp
          ]

  let addIndex
          :: PackageIndex UnresolvedSourcePackage
          -> (RepoData, CombineStrategy)
          -> PackageIndex UnresolvedSourcePackage
      addIndex :: PackageIndex UnresolvedSourcePackage
-> (RepoData, CombineStrategy)
-> PackageIndex UnresolvedSourcePackage
addIndex PackageIndex UnresolvedSourcePackage
acc (RepoData RepoName
_ Timestamp
_ PackageIndex UnresolvedSourcePackage
_   [Dependency]
_, CombineStrategy
CombineStrategySkip)     = PackageIndex UnresolvedSourcePackage
acc
      addIndex PackageIndex UnresolvedSourcePackage
acc (RepoData RepoName
_ Timestamp
_ PackageIndex UnresolvedSourcePackage
idx [Dependency]
_, CombineStrategy
CombineStrategyMerge)    = forall pkg.
Package pkg =>
PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg
PackageIndex.merge PackageIndex UnresolvedSourcePackage
acc PackageIndex UnresolvedSourcePackage
idx
      addIndex PackageIndex UnresolvedSourcePackage
acc (RepoData RepoName
_ Timestamp
_ PackageIndex UnresolvedSourcePackage
idx [Dependency]
_, CombineStrategy
CombineStrategyOverride) = forall pkg.
Package pkg =>
PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg
PackageIndex.override PackageIndex UnresolvedSourcePackage
acc PackageIndex UnresolvedSourcePackage
idx

  let pkgs :: PackageIndex UnresolvedSourcePackage
      pkgs :: PackageIndex UnresolvedSourcePackage
pkgs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PackageIndex UnresolvedSourcePackage
-> (RepoData, CombineStrategy)
-> PackageIndex UnresolvedSourcePackage
addIndex forall a. Monoid a => a
mempty [(RepoData, CombineStrategy)]
pkgss'

  -- Note: preferences combined without using CombineStrategy
  let prefs :: Map PackageName VersionRange
      prefs :: Map PackageName VersionRange
prefs = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith VersionRange -> VersionRange -> VersionRange
intersectVersionRanges
          [ (PackageName
name, VersionRange
range)
          | (RepoData RepoName
_n Timestamp
_ts PackageIndex UnresolvedSourcePackage
_idx [Dependency]
prefs', CombineStrategy
_strategy) <- [(RepoData, CombineStrategy)]
pkgss'
          , Dependency PackageName
name VersionRange
range NonEmptySet LibraryName
_ <- [Dependency]
prefs'
          ]

  PackageIndex UnresolvedSourcePackage
_ <- forall a. a -> IO a
evaluate PackageIndex UnresolvedSourcePackage
pkgs
  Map PackageName VersionRange
_ <- forall a. a -> IO a
evaluate Map PackageName VersionRange
prefs
  TotalIndexState
_ <- forall a. a -> IO a
evaluate TotalIndexState
totalIndexState
  forall (m :: * -> *) a. Monad m => a -> m a
return (SourcePackageDb {
    packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex       = PackageIndex UnresolvedSourcePackage
pkgs,
    packagePreferences :: Map PackageName VersionRange
packagePreferences = Map PackageName VersionRange
prefs
  }, TotalIndexState
totalIndexState, ActiveRepos
activeRepos')

-- auxiliary data used in getSourcePackagesAtIndexState
data RepoData = RepoData
    { RepoData -> RepoName
rdRepoName    :: RepoName
    , RepoData -> Timestamp
rdTimeStamp   :: Timestamp
    , RepoData -> PackageIndex UnresolvedSourcePackage
rdIndex       :: PackageIndex UnresolvedSourcePackage
    , RepoData -> [Dependency]
rdPreferences :: [Dependency]
    }

-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
--
readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState
              -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
readRepoIndex :: Verbosity
-> RepoContext
-> Repo
-> RepoIndexState
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
readRepoIndex Verbosity
verbosity RepoContext
repoCtxt Repo
repo RepoIndexState
idxState =
  IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
handleNotFound forall a b. (a -> b) -> a -> b
$ do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Repo -> Bool
isRepoRemote Repo
repo) forall a b. (a -> b) -> a -> b
$ Double -> IO ()
warnIfIndexIsOld forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Repo -> IO Double
getIndexFileAge Repo
repo
    -- note that if this step fails due to a bad repo cache, the the procedure can still succeed by reading from the existing cache, which is updated regardless.
    Verbosity -> Index -> IO ()
updateRepoIndexCache Verbosity
verbosity (RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
repo) forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO`
       (\IOException
e -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"unable to update the repo index cache -- " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> [Char]
displayException IOException
e)
    forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Index
-> RepoIndexState
-> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile Verbosity
verbosity PackageEntry -> UnresolvedSourcePackage
mkAvailablePackage
                              (RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
repo)
                              RepoIndexState
idxState

  where
    mkAvailablePackage :: PackageEntry -> UnresolvedSourcePackage
mkAvailablePackage PackageEntry
pkgEntry = SourcePackage
      { srcpkgPackageId :: PackageId
srcpkgPackageId   = PackageId
pkgid
      , srcpkgDescription :: GenericPackageDescription
srcpkgDescription = GenericPackageDescription
pkgdesc
      , srcpkgSource :: PackageLocation (Maybe [Char])
srcpkgSource      = case PackageEntry
pkgEntry of
          NormalPackage PackageId
_ GenericPackageDescription
_ ByteString
_ BlockNo
_       -> forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid forall a. Maybe a
Nothing
          BuildTreeRef  BuildTreeRefType
_  PackageId
_ GenericPackageDescription
_ [Char]
path BlockNo
_ -> forall local. [Char] -> PackageLocation local
LocalUnpackedPackage [Char]
path
      , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = case PackageEntry
pkgEntry of
          NormalPackage PackageId
_ GenericPackageDescription
_ ByteString
pkgtxt BlockNo
_ -> forall a. a -> Maybe a
Just ByteString
pkgtxt
          PackageEntry
_                          -> forall a. Maybe a
Nothing
      }
      where
        pkgdesc :: GenericPackageDescription
pkgdesc = PackageEntry -> GenericPackageDescription
packageDesc PackageEntry
pkgEntry
        pkgid :: PackageId
pkgid = forall pkg. Package pkg => pkg -> PackageId
packageId PackageEntry
pkgEntry

    handleNotFound :: IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
handleNotFound IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
action = forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
action forall a b. (a -> b) -> a -> b
$ \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
      then do
        case Repo
repo of
          RepoRemote{[Char]
RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: [Char]
repoRemote :: RemoteRepo
repoLocalDir :: Repo -> [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ RemoteRepo -> [Char]
errMissingPackageList RemoteRepo
repoRemote
          RepoSecure{[Char]
RemoteRepo
repoLocalDir :: [Char]
repoRemote :: RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ RemoteRepo -> [Char]
errMissingPackageList RemoteRepo
repoRemote
          RepoLocalNoIndex LocalRepo
local [Char]
_ -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
              [Char]
"Error during construction of local+noindex "
              forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local) forall a. [a] -> [a] -> [a]
++ [Char]
" repository index: "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show IOException
e
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty,forall a. Monoid a => a
mempty,IndexStateInfo
emptyStateInfo)
      else forall a. IOException -> IO a
ioError IOException
e

    isOldThreshold :: Double
isOldThreshold = Double
15 --days
    warnIfIndexIsOld :: Double -> IO ()
warnIfIndexIsOld Double
dt = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
dt forall a. Ord a => a -> a -> Bool
>= Double
isOldThreshold) forall a b. (a -> b) -> a -> b
$ case Repo
repo of
        RepoRemote{[Char]
RemoteRepo
repoLocalDir :: [Char]
repoRemote :: RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall {a}. RealFrac a => RemoteRepo -> a -> [Char]
errOutdatedPackageList RemoteRepo
repoRemote Double
dt
        RepoSecure{[Char]
RemoteRepo
repoLocalDir :: [Char]
repoRemote :: RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall {a}. RealFrac a => RemoteRepo -> a -> [Char]
errOutdatedPackageList RemoteRepo
repoRemote Double
dt
        RepoLocalNoIndex {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    errMissingPackageList :: RemoteRepo -> [Char]
errMissingPackageList RemoteRepo
repoRemote =
         [Char]
"The package list for '" forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repoRemote)
      forall a. [a] -> [a] -> [a]
++ [Char]
"' does not exist. Run 'cabal update' to download it."
    errOutdatedPackageList :: RemoteRepo -> a -> [Char]
errOutdatedPackageList RemoteRepo
repoRemote a
dt =
         [Char]
"The package list for '" forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repoRemote)
      forall a. [a] -> [a] -> [a]
++ [Char]
"' is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char] -> [Char]
shows (forall a b. (RealFrac a, Integral b) => a -> b
floor a
dt :: Int) [Char]
" days old.\nRun "
      forall a. [a] -> [a] -> [a]
++ [Char]
"'cabal update' to get the latest list of available packages."

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

-- | A set of files (or directories) that can be monitored to detect when
-- there might have been a change in the source packages.
--
getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
getSourcePackagesMonitorFiles :: [Repo] -> [[Char]]
getSourcePackagesMonitorFiles [Repo]
repos =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ Repo -> [Char]
indexBaseName Repo
repo [Char] -> [Char] -> [Char]
<.> [Char]
"cache"
             , Repo -> [Char]
indexBaseName Repo
repo [Char] -> [Char] -> [Char]
<.> [Char]
"timestamp" ]
           | Repo
repo <- [Repo]
repos ]

-- | It is not necessary to call this, as the cache will be updated when the
-- index is read normally. However you can do the work earlier if you like.
--
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache Verbosity
verbosity Index
index =
    Index -> IO () -> IO ()
whenCacheOutOfDate Index
index forall a b. (a -> b) -> a -> b
$ Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index

whenCacheOutOfDate :: Index -> IO () -> IO ()
whenCacheOutOfDate :: Index -> IO () -> IO ()
whenCacheOutOfDate Index
index IO ()
action = do
  Bool
exists <- [Char] -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ Index -> [Char]
cacheFile Index
index
  if Bool -> Bool
not Bool
exists
  then IO ()
action
  else if Index -> Bool
localNoIndex Index
index
      then forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: don't update cache for local+noindex repositories
      else do
          ModTime
indexTime <- [Char] -> IO ModTime
getModTime forall a b. (a -> b) -> a -> b
$ Index -> [Char]
indexFile Index
index
          ModTime
cacheTime <- [Char] -> IO ModTime
getModTime forall a b. (a -> b) -> a -> b
$ Index -> [Char]
cacheFile Index
index
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModTime
indexTime forall a. Ord a => a -> a -> Bool
> ModTime
cacheTime) IO ()
action

localNoIndex :: Index -> Bool
localNoIndex :: Index -> Bool
localNoIndex (RepoIndex RepoContext
_ (RepoLocalNoIndex {})) = Bool
True
localNoIndex Index
_ = Bool
False

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

-- | An index entry is either a normal package, or a local build tree reference.
data PackageEntry
  = NormalPackage  PackageId GenericPackageDescription ByteString BlockNo
  | BuildTreeRef BuildTreeRefType
                 PackageId GenericPackageDescription FilePath   BlockNo

-- | A build tree reference is either a link or a snapshot.
data BuildTreeRefType = SnapshotRef | LinkRef
                      deriving (BuildTreeRefType -> BuildTreeRefType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildTreeRefType -> BuildTreeRefType -> Bool
$c/= :: BuildTreeRefType -> BuildTreeRefType -> Bool
== :: BuildTreeRefType -> BuildTreeRefType -> Bool
$c== :: BuildTreeRefType -> BuildTreeRefType -> Bool
Eq,Int -> BuildTreeRefType -> [Char] -> [Char]
[BuildTreeRefType] -> [Char] -> [Char]
BuildTreeRefType -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [BuildTreeRefType] -> [Char] -> [Char]
$cshowList :: [BuildTreeRefType] -> [Char] -> [Char]
show :: BuildTreeRefType -> [Char]
$cshow :: BuildTreeRefType -> [Char]
showsPrec :: Int -> BuildTreeRefType -> [Char] -> [Char]
$cshowsPrec :: Int -> BuildTreeRefType -> [Char] -> [Char]
Show,forall x. Rep BuildTreeRefType x -> BuildTreeRefType
forall x. BuildTreeRefType -> Rep BuildTreeRefType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BuildTreeRefType x -> BuildTreeRefType
$cfrom :: forall x. BuildTreeRefType -> Rep BuildTreeRefType x
Generic)

instance Binary BuildTreeRefType
instance Structured BuildTreeRefType

refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType
refTypeFromTypeCode :: Char -> BuildTreeRefType
refTypeFromTypeCode Char
t
  | Char
t forall a. Eq a => a -> a -> Bool
== Char
Tar.buildTreeRefTypeCode      = BuildTreeRefType
LinkRef
  | Char
t forall a. Eq a => a -> a -> Bool
== Char
Tar.buildTreeSnapshotTypeCode = BuildTreeRefType
SnapshotRef
  | Bool
otherwise                          =
    forall a. HasCallStack => [Char] -> a
error [Char]
"Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"

typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode
typeCodeFromRefType :: BuildTreeRefType -> Char
typeCodeFromRefType BuildTreeRefType
LinkRef     = Char
Tar.buildTreeRefTypeCode
typeCodeFromRefType BuildTreeRefType
SnapshotRef = Char
Tar.buildTreeSnapshotTypeCode

instance Package PackageEntry where
  packageId :: PackageEntry -> PackageId
packageId (NormalPackage  PackageId
pkgid GenericPackageDescription
_ ByteString
_ BlockNo
_) = PackageId
pkgid
  packageId (BuildTreeRef BuildTreeRefType
_ PackageId
pkgid GenericPackageDescription
_ [Char]
_ BlockNo
_) = PackageId
pkgid

packageDesc :: PackageEntry -> GenericPackageDescription
packageDesc :: PackageEntry -> GenericPackageDescription
packageDesc (NormalPackage  PackageId
_ GenericPackageDescription
descr ByteString
_ BlockNo
_) = GenericPackageDescription
descr
packageDesc (BuildTreeRef BuildTreeRefType
_ PackageId
_ GenericPackageDescription
descr [Char]
_ BlockNo
_) = GenericPackageDescription
descr

-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
--

data PackageOrDep = Pkg PackageEntry | Dep Dependency

-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files
--
-- We read the index using 'Tar.read', which gives us a lazily constructed
-- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',
-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a
-- function over this to translate it to a list of IO actions returning
-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of
-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.
parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex Verbosity
verbosity = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BlockNo -> Entry -> [IO (Maybe PackageOrDep)]
extract) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Show e => Entries e -> [(BlockNo, Entry)]
tarEntriesList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
  where
    extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
    extract :: BlockNo -> Entry -> [IO (Maybe PackageOrDep)]
extract BlockNo
blockNo Entry
entry = [IO (Maybe PackageOrDep)]
tryExtractPkg forall a. [a] -> [a] -> [a]
++ [IO (Maybe PackageOrDep)]
tryExtractPrefs
      where
        tryExtractPkg :: [IO (Maybe PackageOrDep)]
tryExtractPkg = do
          IO (Maybe PackageEntry)
mkPkgEntry <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Verbosity -> Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
extractPkg Verbosity
verbosity Entry
entry BlockNo
blockNo
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageEntry -> PackageOrDep
Pkg) IO (Maybe PackageEntry)
mkPkgEntry

        tryExtractPrefs :: [IO (Maybe PackageOrDep)]
tryExtractPrefs = do
          [Dependency]
prefs' <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ Entry -> Maybe [Dependency]
extractPrefs Entry
entry
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> PackageOrDep
Dep) [Dependency]
prefs'

-- | Turn the 'Entries' data structure from the @tar@ package into a list,
-- and pair each entry with its block number.
--
-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read
-- as far as the list is evaluated.
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
tarEntriesList :: forall e. Show e => Entries e -> [(BlockNo, Entry)]
tarEntriesList = forall {a}. Show a => BlockNo -> Entries a -> [(BlockNo, Entry)]
go BlockNo
0
  where
    go :: BlockNo -> Entries a -> [(BlockNo, Entry)]
go !BlockNo
_ Entries a
Tar.Done         = []
    go !BlockNo
_ (Tar.Fail a
e)     = forall a. HasCallStack => [Char] -> a
error ([Char]
"tarEntriesList: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
e)
    go !BlockNo
n (Tar.Next Entry
e Entries a
es') = (BlockNo
n, Entry
e) forall a. a -> [a] -> [a]
: BlockNo -> Entries a -> [(BlockNo, Entry)]
go (Entry -> BlockNo -> BlockNo
Tar.nextEntryOffset Entry
e BlockNo
n) Entries a
es'

extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
extractPkg :: Verbosity -> Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
extractPkg Verbosity
verbosity Entry
entry BlockNo
blockNo = case Entry -> EntryContent
Tar.entryContent Entry
entry of
  Tar.NormalFile ByteString
content FileSize
_
     | [Char] -> [Char]
takeExtension [Char]
fileName forall a. Eq a => a -> a -> Bool
== [Char]
".cabal"
    -> case [Char] -> [[Char]]
splitDirectories ([Char] -> [Char]
normalise [Char]
fileName) of
        [[Char]
pkgname,[Char]
vers,[Char]
_] -> case forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
vers of
          Just Version
ver -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PackageId
-> GenericPackageDescription
-> ByteString
-> BlockNo
-> PackageEntry
NormalPackage PackageId
pkgid GenericPackageDescription
descr ByteString
content BlockNo
blockNo)
            where
              pkgid :: PackageId
pkgid  = PackageName -> Version -> PackageId
PackageIdentifier ([Char] -> PackageName
mkPackageName [Char]
pkgname) Version
ver
              parsed :: Maybe GenericPackageDescription
parsed = ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe (ByteString -> ByteString
BS.toStrict ByteString
content)
              descr :: GenericPackageDescription
descr = case Maybe GenericPackageDescription
parsed of
                  Just GenericPackageDescription
d  -> GenericPackageDescription
d
                  Maybe GenericPackageDescription
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Couldn't read cabal file "
                                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
fileName
          Maybe Version
_ -> forall a. Maybe a
Nothing
        [[Char]]
_ -> forall a. Maybe a
Nothing

  Tar.OtherEntryType Char
typeCode ByteString
content FileSize
_
    | Char -> Bool
Tar.isBuildTreeRefTypeCode Char
typeCode ->
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
        let path :: [Char]
path = ByteString -> [Char]
byteStringToFilePath ByteString
content
        Bool
dirExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
        Maybe PackageEntry
result <- if Bool -> Bool
not Bool
dirExists then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                  else do
                    [Char]
cabalFile <- Verbosity -> [Char] -> [Char] -> IO [Char]
tryFindAddSourcePackageDesc Verbosity
verbosity [Char]
path [Char]
"Error reading package index."
                    GenericPackageDescription
descr     <- Verbosity -> [Char] -> IO GenericPackageDescription
PackageDesc.Parse.readGenericPackageDescription Verbosity
normal [Char]
cabalFile
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BuildTreeRefType
-> PackageId
-> GenericPackageDescription
-> [Char]
-> BlockNo
-> PackageEntry
BuildTreeRef (Char -> BuildTreeRefType
refTypeFromTypeCode Char
typeCode) (forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
descr)
                                                 GenericPackageDescription
descr [Char]
path BlockNo
blockNo
        forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageEntry
result

  EntryContent
_ -> forall a. Maybe a
Nothing

  where
    fileName :: [Char]
fileName = Entry -> [Char]
Tar.entryPath Entry
entry

extractPrefs :: Tar.Entry -> Maybe [Dependency]
extractPrefs :: Entry -> Maybe [Dependency]
extractPrefs Entry
entry = case Entry -> EntryContent
Tar.entryContent Entry
entry of
  Tar.NormalFile ByteString
content FileSize
_
     | [Char] -> Bool
isPreferredVersions [Char]
entrypath
    -> forall a. a -> Maybe a
Just [Dependency]
prefs
    where
      entrypath :: [Char]
entrypath = Entry -> [Char]
Tar.entryPath Entry
entry
      prefs :: [Dependency]
prefs     = ByteString -> [Dependency]
parsePreferredVersions ByteString
content
  EntryContent
_ -> forall a. Maybe a
Nothing

------------------------------------------------------------------------
-- Filename and parsers for 'preferred-versions' file.
--

-- | Expected name of the 'preferred-versions' file.
--
-- Contains special constraints, such as a preferred version of a package
-- or deprecations of certain package versions.
--
-- Expected format:
--
-- @
-- binary > 0.9.0.0 || < 0.9.0.0
-- text == 1.2.1.0
-- @
preferredVersions :: FilePath
preferredVersions :: [Char]
preferredVersions = [Char]
"preferred-versions"

-- | Does the given filename match with the expected name of 'preferred-versions'?
isPreferredVersions :: FilePath -> Bool
isPreferredVersions :: [Char] -> Bool
isPreferredVersions = (forall a. Eq a => a -> a -> Bool
== [Char]
preferredVersions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
takeFileName

-- | Parse `preferred-versions` file, ignoring any parse failures.
--
-- To obtain parse errors, use 'parsePreferredVersionsWarnings'.
parsePreferredVersions :: ByteString -> [Dependency]
parsePreferredVersions :: ByteString -> [Dependency]
parsePreferredVersions = forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Either PreferredVersionsParseError Dependency]
parsePreferredVersionsWarnings

-- | Parser error of the `preferred-versions` file.
data PreferredVersionsParseError = PreferredVersionsParseError
    { PreferredVersionsParseError -> [Char]
preferredVersionsParsecError :: String
    -- ^ Parser error to show to a user.
    , PreferredVersionsParseError -> [Char]
preferredVersionsOriginalDependency :: String
    -- ^ Original input that produced the parser error.
    }
  deriving (forall x.
Rep PreferredVersionsParseError x -> PreferredVersionsParseError
forall x.
PreferredVersionsParseError -> Rep PreferredVersionsParseError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep PreferredVersionsParseError x -> PreferredVersionsParseError
$cfrom :: forall x.
PreferredVersionsParseError -> Rep PreferredVersionsParseError x
Generic, ReadPrec [PreferredVersionsParseError]
ReadPrec PreferredVersionsParseError
Int -> ReadS PreferredVersionsParseError
ReadS [PreferredVersionsParseError]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PreferredVersionsParseError]
$creadListPrec :: ReadPrec [PreferredVersionsParseError]
readPrec :: ReadPrec PreferredVersionsParseError
$creadPrec :: ReadPrec PreferredVersionsParseError
readList :: ReadS [PreferredVersionsParseError]
$creadList :: ReadS [PreferredVersionsParseError]
readsPrec :: Int -> ReadS PreferredVersionsParseError
$creadsPrec :: Int -> ReadS PreferredVersionsParseError
Read, Int -> PreferredVersionsParseError -> [Char] -> [Char]
[PreferredVersionsParseError] -> [Char] -> [Char]
PreferredVersionsParseError -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [PreferredVersionsParseError] -> [Char] -> [Char]
$cshowList :: [PreferredVersionsParseError] -> [Char] -> [Char]
show :: PreferredVersionsParseError -> [Char]
$cshow :: PreferredVersionsParseError -> [Char]
showsPrec :: Int -> PreferredVersionsParseError -> [Char] -> [Char]
$cshowsPrec :: Int -> PreferredVersionsParseError -> [Char] -> [Char]
Show, PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c/= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
== :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c== :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
Eq, Eq PreferredVersionsParseError
PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
PreferredVersionsParseError
-> PreferredVersionsParseError -> Ordering
PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
$cmin :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
max :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
$cmax :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
>= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c>= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
> :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c> :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
<= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c<= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
< :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c< :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
compare :: PreferredVersionsParseError
-> PreferredVersionsParseError -> Ordering
$ccompare :: PreferredVersionsParseError
-> PreferredVersionsParseError -> Ordering
Ord, Typeable)

-- | Parse `preferred-versions` file, collecting parse errors that can be shown
-- in error messages.
parsePreferredVersionsWarnings :: ByteString
                               -> [Either PreferredVersionsParseError Dependency]
parsePreferredVersionsWarnings :: ByteString -> [Either PreferredVersionsParseError Dependency]
parsePreferredVersionsWarnings =
  forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Either PreferredVersionsParseError Dependency
parsePreference
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"--")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
fromUTF8LBS
    where
      parsePreference :: String -> Either PreferredVersionsParseError Dependency
      parsePreference :: [Char] -> Either PreferredVersionsParseError Dependency
parsePreference [Char]
s = case forall a. Parsec a => [Char] -> Either [Char] a
eitherParsec [Char]
s of
          Left [Char]
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PreferredVersionsParseError
              { preferredVersionsParsecError :: [Char]
preferredVersionsParsecError = [Char]
err
              , preferredVersionsOriginalDependency :: [Char]
preferredVersionsOriginalDependency = [Char]
s
              }
          Right Dependency
dep -> forall a b. b -> Either a b
Right Dependency
dep

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

-- | Variation on 'sequence' which evaluates the actions lazily
--
-- Pattern matching on the result list will execute just the first action;
-- more generally pattern matching on the first @n@ '(:)' nodes will execute
-- the first @n@ actions.
lazySequence :: [IO a] -> IO [a]
lazySequence :: forall a. [IO a] -> IO [a]
lazySequence = forall a. IO a -> IO a
unsafeInterleaveIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [IO a] -> IO [a]
go
  where
    go :: [IO a] -> IO [a]
go []     = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (IO a
x:[IO a]
xs) = do a
x'  <- IO a
x
                   [a]
xs' <- forall a. [IO a] -> IO [a]
lazySequence [IO a]
xs
                   forall (m :: * -> *) a. Monad m => a -> m a
return (a
x' forall a. a -> [a] -> [a]
: [a]
xs')

-- | A lazy unfolder for lookup operations which return the current
-- value and (possibly) the next key
lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]
lazyUnfold :: forall k v. (k -> IO (v, Maybe k)) -> k -> IO [(k, v)]
lazyUnfold k -> IO (v, Maybe k)
step = Maybe k -> IO [(k, v)]
goLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
  where
    goLazy :: Maybe k -> IO [(k, v)]
goLazy Maybe k
s = forall a. IO a -> IO a
unsafeInterleaveIO (Maybe k -> IO [(k, v)]
go Maybe k
s)

    go :: Maybe k -> IO [(k, v)]
go Maybe k
Nothing  = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (Just k
k) = do
        (v
v, Maybe k
mk') <- k -> IO (v, Maybe k)
step k
k
        [(k, v)]
vs' <- Maybe k -> IO [(k, v)]
goLazy Maybe k
mk'
        forall (m :: * -> *) a. Monad m => a -> m a
return ((k
k,v
v)forall a. a -> [a] -> [a]
:[(k, v)]
vs')

-- | Which index do we mean?
data Index =
    -- | The main index for the specified repository
    RepoIndex RepoContext Repo

    -- | A sandbox-local repository
    -- Argument is the location of the index file
  | SandboxIndex FilePath

indexFile :: Index -> FilePath
indexFile :: Index -> [Char]
indexFile (RepoIndex RepoContext
_ctxt Repo
repo) = Repo -> [Char]
indexBaseName Repo
repo [Char] -> [Char] -> [Char]
<.> [Char]
"tar"
indexFile (SandboxIndex [Char]
index)   = [Char]
index

cacheFile :: Index -> FilePath
cacheFile :: Index -> [Char]
cacheFile (RepoIndex RepoContext
_ctxt Repo
repo) = Repo -> [Char]
indexBaseName Repo
repo [Char] -> [Char] -> [Char]
<.> [Char]
"cache"
cacheFile (SandboxIndex [Char]
index)   = [Char]
index [Char] -> [Char] -> [Char]
`replaceExtension` [Char]
"cache"

timestampFile :: Index -> FilePath
timestampFile :: Index -> [Char]
timestampFile (RepoIndex RepoContext
_ctxt Repo
repo) = Repo -> [Char]
indexBaseName Repo
repo [Char] -> [Char] -> [Char]
<.> [Char]
"timestamp"
timestampFile (SandboxIndex [Char]
index)   = [Char]
index [Char] -> [Char] -> [Char]
`replaceExtension` [Char]
"timestamp"

-- | Return 'True' if 'Index' uses 01-index format (aka secure repo)
is01Index :: Index -> Bool
is01Index :: Index -> Bool
is01Index (RepoIndex RepoContext
_ Repo
repo) = case Repo
repo of
                                 RepoSecure {} -> Bool
True
                                 RepoRemote {} -> Bool
False
                                 RepoLocalNoIndex {} -> Bool
True
is01Index (SandboxIndex [Char]
_)   = Bool
False


updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index = do
    Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"Updating index cache file " forall a. [a] -> [a] -> [a]
++ Index -> [Char]
cacheFile Index
index forall a. [a] -> [a] -> [a]
++ [Char]
" ...")
    forall a.
Verbosity
-> Index
-> ([IndexCacheEntry] -> IO a)
-> ([NoIndexCacheEntry] -> IO a)
-> IO a
withIndexEntries Verbosity
verbosity Index
index [IndexCacheEntry] -> IO ()
callback [NoIndexCacheEntry] -> IO ()
callbackNoIndex
  where
    callback :: [IndexCacheEntry] -> IO ()
callback [IndexCacheEntry]
entries = do
        let !maxTs :: Timestamp
maxTs = [Timestamp] -> Timestamp
maximumTimestamp (forall a b. (a -> b) -> [a] -> [b]
map IndexCacheEntry -> Timestamp
cacheEntryTimestamp [IndexCacheEntry]
entries)
            cache :: Cache
cache = Cache { cacheHeadTs :: Timestamp
cacheHeadTs  = Timestamp
maxTs
                          , cacheEntries :: [IndexCacheEntry]
cacheEntries = [IndexCacheEntry]
entries
                          }
        Index -> Cache -> IO ()
writeIndexCache Index
index Cache
cache
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"Index cache updated to index-state "
                        forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (Cache -> Timestamp
cacheHeadTs Cache
cache))

    callbackNoIndex :: [NoIndexCacheEntry] -> IO ()
callbackNoIndex [NoIndexCacheEntry]
entries = do
        Verbosity -> Index -> NoIndexCache -> IO ()
writeNoIndexCache Verbosity
verbosity Index
index forall a b. (a -> b) -> a -> b
$ [NoIndexCacheEntry] -> NoIndexCache
NoIndexCache [NoIndexCacheEntry]
entries
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity [Char]
"Index cache updated"

-- | Read the index (for the purpose of building a cache)
--
-- The callback is provided with list of cache entries, which is guaranteed to
-- be lazily constructed. This list must ONLY be used in the scope of the
-- callback; when the callback is terminated the file handle to the index will
-- be closed and further attempts to read from the list will result in (pure)
-- I/O exceptions.
--
-- In the construction of the index for a secure repo we take advantage of the
-- index built by the @hackage-security@ library to avoid reading the @.tar@
-- file as much as possible (we need to read it only to extract preferred
-- versions). This helps performance, but is also required for correctness:
-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions
-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);
-- by reading the already-built cache from the security library we will be sure
-- to only read the latest versions of all files.
--
-- TODO: It would be nicer if we actually incrementally updated @cabal@'s
-- cache, rather than reconstruct it from zero on each update. However, this
-- would require a change in the cache format.
withIndexEntries
    :: Verbosity -> Index
    -> ([IndexCacheEntry] -> IO a)
    -> ([NoIndexCacheEntry] -> IO a)
    -> IO a
withIndexEntries :: forall a.
Verbosity
-> Index
-> ([IndexCacheEntry] -> IO a)
-> ([NoIndexCacheEntry] -> IO a)
-> IO a
withIndexEntries Verbosity
_ (RepoIndex RepoContext
repoCtxt repo :: Repo
repo@RepoSecure{}) [IndexCacheEntry] -> IO a
callback [NoIndexCacheEntry] -> IO a
_ =
    RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo forall a b. (a -> b) -> a -> b
$ \Repository down
repoSecure ->
      forall (down :: * -> *) a.
Repository down -> (IndexCallbacks -> IO a) -> IO a
Sec.withIndex Repository down
repoSecure forall a b. (a -> b) -> a -> b
$ \Sec.IndexCallbacks{Directory
DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry)
Throws InvalidPackageException =>
PackageId -> IO (Trusted ByteString)
Throws InvalidPackageException => PackageId -> IO (Trusted Targets)
(Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted FileInfo)
(Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted Hash)
forall dec. DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec)
forall dec. IndexFile dec -> IO (Maybe (IndexEntry dec))
indexLookupEntry :: IndexCallbacks
-> DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry)
indexLookupFile :: IndexCallbacks
-> forall dec. IndexFile dec -> IO (Maybe (IndexEntry dec))
indexLookupFileEntry :: IndexCallbacks
-> forall dec.
   DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec)
indexLookupCabal :: IndexCallbacks
-> Throws InvalidPackageException =>
   PackageId -> IO (Trusted ByteString)
indexLookupMetadata :: IndexCallbacks
-> Throws InvalidPackageException =>
   PackageId -> IO (Trusted Targets)
indexLookupFileInfo :: IndexCallbacks
-> (Throws InvalidPackageException, Throws VerificationError) =>
   PackageId -> IO (Trusted FileInfo)
indexLookupHash :: IndexCallbacks
-> (Throws InvalidPackageException, Throws VerificationError) =>
   PackageId -> IO (Trusted Hash)
indexDirectory :: IndexCallbacks -> Directory
indexDirectory :: Directory
indexLookupHash :: (Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted Hash)
indexLookupFileInfo :: (Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted FileInfo)
indexLookupMetadata :: Throws InvalidPackageException => PackageId -> IO (Trusted Targets)
indexLookupCabal :: Throws InvalidPackageException =>
PackageId -> IO (Trusted ByteString)
indexLookupFileEntry :: forall dec. DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec)
indexLookupFile :: forall dec. IndexFile dec -> IO (Maybe (IndexEntry dec))
indexLookupEntry :: DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry)
..} -> do
        -- Incrementally (lazily) read all the entries in the tar file in order,
        -- including all revisions, not just the last revision of each file
        [(DirectoryEntry, Some IndexEntry)]
indexEntries <- forall k v. (k -> IO (v, Maybe k)) -> k -> IO [(k, v)]
lazyUnfold DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry)
indexLookupEntry (Directory -> DirectoryEntry
Sec.directoryFirst Directory
indexDirectory)
        [IndexCacheEntry] -> IO a
callback [ IndexCacheEntry
cacheEntry
                 | (DirectoryEntry
dirEntry, Some IndexEntry
indexEntry) <- [(DirectoryEntry, Some IndexEntry)]
indexEntries
                 , IndexCacheEntry
cacheEntry <- DirectoryEntry -> Some IndexEntry -> [IndexCacheEntry]
toCacheEntries DirectoryEntry
dirEntry Some IndexEntry
indexEntry ]
  where
    toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry
                   -> [IndexCacheEntry]
    toCacheEntries :: DirectoryEntry -> Some IndexEntry -> [IndexCacheEntry]
toCacheEntries DirectoryEntry
dirEntry (Sec.Some IndexEntry a
sie) =
        case forall dec. IndexEntry dec -> Maybe (IndexFile dec)
Sec.indexEntryPathParsed IndexEntry a
sie of
          Maybe (IndexFile a)
Nothing                            -> [] -- skip unrecognized file
          Just (Sec.IndexPkgMetadata PackageId
_pkgId) -> [] -- skip metadata
          Just (Sec.IndexPkgCabal PackageId
pkgId)     -> forall a. NFData a => a -> a
force
              [PackageId -> BlockNo -> Timestamp -> IndexCacheEntry
CachePackageId PackageId
pkgId BlockNo
blockNo Timestamp
timestamp]
          Just (Sec.IndexPkgPrefs PackageName
_pkgName)  -> forall a. NFData a => a -> a
force
              [ Dependency -> BlockNo -> Timestamp -> IndexCacheEntry
CachePreference Dependency
dep BlockNo
blockNo Timestamp
timestamp
              | Dependency
dep <- ByteString -> [Dependency]
parsePreferredVersions (forall dec. IndexEntry dec -> ByteString
Sec.indexEntryContent IndexEntry a
sie)
              ]
      where
        blockNo :: BlockNo
blockNo = DirectoryEntry -> BlockNo
Sec.directoryEntryBlockNo DirectoryEntry
dirEntry
        timestamp :: Timestamp
timestamp = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"withIndexEntries: invalid timestamp") forall a b. (a -> b) -> a -> b
$
                              FileSize -> Maybe Timestamp
epochTimeToTimestamp forall a b. (a -> b) -> a -> b
$ forall dec. IndexEntry dec -> FileSize
Sec.indexEntryTime IndexEntry a
sie

withIndexEntries Verbosity
verbosity (RepoIndex RepoContext
_repoCtxt (RepoLocalNoIndex (LocalRepo RepoName
name [Char]
localDir Bool
_) [Char]
_cacheDir)) [IndexCacheEntry] -> IO a
_ [NoIndexCacheEntry] -> IO a
callback = do
    [[Char]]
dirContents <- [Char] -> IO [[Char]]
listDirectory [Char]
localDir
    let contentSet :: Set [Char]
contentSet = forall a. Ord a => [a] -> Set a
Set.fromList [[Char]]
dirContents

    [NoIndexCacheEntry]
entries <- forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a. IOException -> IO a
handler forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]]
dirContents forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
        case [Char] -> Maybe PackageId
isTarGz [Char]
file of
            Maybe PackageId
Nothing
              | [Char] -> Bool
isPreferredVersions [Char]
file -> do
                  ByteString
contents <- [Char] -> IO ByteString
BS.readFile ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
file)
                  let versionPreferencesParsed :: [Either PreferredVersionsParseError Dependency]
versionPreferencesParsed = ByteString -> [Either PreferredVersionsParseError Dependency]
parsePreferredVersionsWarnings ByteString
contents
                  let ([PreferredVersionsParseError]
warnings, [Dependency]
versionPreferences) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either PreferredVersionsParseError Dependency]
versionPreferencesParsed
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PreferredVersionsParseError]
warnings) forall a b. (a -> b) -> a -> b
$ do
                      Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
                          [Char]
"withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: "
                              forall a. [a] -> [a] -> [a]
++ ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
file)
                      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PreferredVersionsParseError]
warnings forall a b. (a -> b) -> a -> b
$ \PreferredVersionsParseError
err -> do
                          Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"* \"" forall a. [a] -> [a] -> [a]
++ PreferredVersionsParseError -> [Char]
preferredVersionsOriginalDependency PreferredVersionsParseError
err
                          Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Parser Error: " forall a. [a] -> [a] -> [a]
++ PreferredVersionsParseError -> [Char]
preferredVersionsParsecError PreferredVersionsParseError
err
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Dependency] -> NoIndexCacheEntry
NoIndexCachePreference [Dependency]
versionPreferences
              | Bool
otherwise -> do
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> [Char]
takeFileName [Char]
file forall a. Eq a => a -> a -> Bool
== [Char]
"noindex.cache" Bool -> Bool -> Bool
|| [Char]
".cabal" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
file) forall a b. (a -> b) -> a -> b
$
                      Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Skipping " forall a. [a] -> [a] -> [a]
++ [Char]
file
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just PackageId
pkgid | [Char]
cabalPath forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
contentSet -> do
                ByteString
contents <- [Char] -> IO ByteString
BSS.readFile ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
cabalPath)
                forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
contents) forall a b. (a -> b) -> a -> b
$ \GenericPackageDescription
gpd ->
                    forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription -> ByteString -> NoIndexCacheEntry
CacheGPD GenericPackageDescription
gpd ByteString
contents)
              where
                cabalPath :: [Char]
cabalPath = forall a. Pretty a => a -> [Char]
prettyShow PackageId
pkgid forall a. [a] -> [a] -> [a]
++ [Char]
".cabal"
            Just PackageId
pkgId -> do
                -- check for the right named .cabal file in the compressed tarball
                ByteString
tarGz <- [Char] -> IO ByteString
BS.readFile ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
file)
                let tar :: ByteString
tar = ByteString -> ByteString
GZip.decompress ByteString
tarGz
                    entries :: Entries FormatError
entries = ByteString -> Entries FormatError
Tar.read ByteString
tar

                case forall a e. (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a
Tar.foldEntries (PackageId
-> Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry
readCabalEntry PackageId
pkgId) forall a. Maybe a
Nothing (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) Entries FormatError
entries of
                    Just NoIndexCacheEntry
ce -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just NoIndexCacheEntry
ce)
                    Maybe NoIndexCacheEntry
Nothing -> forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot read .cabal file inside " forall a. [a] -> [a] -> [a]
++ [Char]
file

    let ([[Dependency]]
prefs, [GenericPackageDescription]
gpds) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
            (\case
                NoIndexCachePreference [Dependency]
deps -> forall a b. a -> Either a b
Left [Dependency]
deps
                CacheGPD GenericPackageDescription
gpd ByteString
_ -> forall a b. b -> Either a b
Right GenericPackageDescription
gpd
            )
            [NoIndexCacheEntry]
entries

    Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Entries in file+noindex repository " forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
name
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [GenericPackageDescription]
gpds forall a b. (a -> b) -> a -> b
$ \GenericPackageDescription
gpd ->
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"- " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (PackageDescription -> PackageId
package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Distribution.PackageDescription.packageDescription GenericPackageDescription
gpd)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Dependency]]
prefs) forall a b. (a -> b) -> a -> b
$ do
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Preferred versions in file+noindex repository " forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
name
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dependency]]
prefs) forall a b. (a -> b) -> a -> b
$ \Dependency
pref ->
            Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"* " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Dependency
pref)

    [NoIndexCacheEntry] -> IO a
callback [NoIndexCacheEntry]
entries
  where
    handler :: IOException -> IO a
    handler :: forall a. IOException -> IO a
handler IOException
e = forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Error while updating index for " forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
name forall a. [a] -> [a] -> [a]
++ [Char]
" repository " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show IOException
e

    isTarGz :: FilePath -> Maybe PackageIdentifier
    isTarGz :: [Char] -> Maybe PackageId
isTarGz [Char]
fp = do
        [Char]
pfx <- forall {a}. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
".tar.gz" [Char]
fp
        forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
pfx

    stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
sfx [a]
str = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse (forall {a}. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (forall a. [a] -> [a]
reverse [a]
sfx) (forall a. [a] -> [a]
reverse [a]
str))

    -- look for <pkgid>/<pkgname>.cabal inside the tarball
    readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry
    readCabalEntry :: PackageId
-> Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry
readCabalEntry PackageId
pkgId Entry
entry Maybe NoIndexCacheEntry
Nothing
        | [Char]
filename forall a. Eq a => a -> a -> Bool
== Entry -> [Char]
Tar.entryPath Entry
entry
        , Tar.NormalFile ByteString
contents FileSize
_ <- Entry -> EntryContent
Tar.entryContent Entry
entry
        = let bs :: ByteString
bs = ByteString -> ByteString
BS.toStrict ByteString
contents
          in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\GenericPackageDescription
gpd -> GenericPackageDescription -> ByteString -> NoIndexCacheEntry
CacheGPD GenericPackageDescription
gpd ByteString
bs) forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
bs
      where
        filename :: [Char]
filename =  forall a. Pretty a => a -> [Char]
prettyShow PackageId
pkgId [Char] -> [Char] -> [Char]
FilePath.Posix.</> forall a. Pretty a => a -> [Char]
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgId) forall a. [a] -> [a] -> [a]
++ [Char]
".cabal"
    readCabalEntry PackageId
_ Entry
_ Maybe NoIndexCacheEntry
x = Maybe NoIndexCacheEntry
x

withIndexEntries Verbosity
verbosity Index
index [IndexCacheEntry] -> IO a
callback [NoIndexCacheEntry] -> IO a
_ = do -- non-secure repositories
    forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile (Index -> [Char]
indexFile Index
index) IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      ByteString
bs          <- ByteString -> ByteString
maybeDecompress forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle -> IO ByteString
BS.hGetContents Handle
h
      [Maybe PackageOrDep]
pkgsOrPrefs <- forall a. [IO a] -> IO [a]
lazySequence forall a b. (a -> b) -> a -> b
$ Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex Verbosity
verbosity ByteString
bs
      [IndexCacheEntry] -> IO a
callback forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageOrDep -> IndexCacheEntry
toCache (forall a. [Maybe a] -> [a]
catMaybes [Maybe PackageOrDep]
pkgsOrPrefs)
  where
    toCache :: PackageOrDep -> IndexCacheEntry
    toCache :: PackageOrDep -> IndexCacheEntry
toCache (Pkg (NormalPackage PackageId
pkgid GenericPackageDescription
_ ByteString
_ BlockNo
blockNo)) = PackageId -> BlockNo -> Timestamp -> IndexCacheEntry
CachePackageId PackageId
pkgid BlockNo
blockNo Timestamp
nullTimestamp
    toCache (Pkg (BuildTreeRef BuildTreeRefType
refType PackageId
_ GenericPackageDescription
_ [Char]
_ BlockNo
blockNo)) = BuildTreeRefType -> BlockNo -> IndexCacheEntry
CacheBuildTreeRef BuildTreeRefType
refType BlockNo
blockNo
    toCache (Dep Dependency
d) = Dependency -> BlockNo -> Timestamp -> IndexCacheEntry
CachePreference Dependency
d BlockNo
0 Timestamp
nullTimestamp

readPackageIndexCacheFile :: Package pkg
                          => Verbosity
                          -> (PackageEntry -> pkg)
                          -> Index
                          -> RepoIndexState
                          -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile :: forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Index
-> RepoIndexState
-> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile Verbosity
verbosity PackageEntry -> pkg
mkPkg Index
index RepoIndexState
idxState
    | Index -> Bool
localNoIndex Index
index = do
        NoIndexCache
cache0 <- Verbosity -> Index -> IO NoIndexCache
readNoIndexCache Verbosity
verbosity Index
index
        (PackageIndex pkg
pkgs, [Dependency]
prefs) <- forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> NoIndexCache
-> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg NoIndexCache
cache0
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex pkg
pkgs, [Dependency]
prefs, IndexStateInfo
emptyStateInfo)

    | Bool
otherwise = do
        Cache
cache0   <- Verbosity -> Index -> IO Cache
readIndexCache Verbosity
verbosity Index
index
        Handle
indexHnd <- [Char] -> IOMode -> IO Handle
openFile (Index -> [Char]
indexFile Index
index) IOMode
ReadMode
        let (Cache
cache,IndexStateInfo
isi) = RepoIndexState -> Cache -> (Cache, IndexStateInfo)
filterCache RepoIndexState
idxState Cache
cache0
        (PackageIndex pkg
pkgs,[Dependency]
deps) <- forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
indexHnd Cache
cache
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex pkg
pkgs,[Dependency]
deps,IndexStateInfo
isi)

packageIndexFromCache :: Package pkg
                      => Verbosity
                     -> (PackageEntry -> pkg)
                      -> Handle
                      -> Cache
                      -> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache :: forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache
cache = do
     ([pkg]
pkgs, [Dependency]
prefs) <- forall pkg.
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO ([pkg], [Dependency])
packageListFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache
cache
     PackageIndex pkg
pkgIndex <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => [pkg] -> PackageIndex pkg
PackageIndex.fromList [pkg]
pkgs
     forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIndex pkg
pkgIndex, [Dependency]
prefs)

packageNoIndexFromCache
    :: forall pkg. Package pkg
    => Verbosity
    -> (PackageEntry -> pkg)
    -> NoIndexCache
    -> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache :: forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> NoIndexCache
-> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache Verbosity
_verbosity PackageEntry -> pkg
mkPkg NoIndexCache
cache = do
    let ([pkg]
pkgs, [Dependency]
prefs) = ([pkg], [Dependency])
packageListFromNoIndexCache
    PackageIndex pkg
pkgIndex <- forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => [pkg] -> PackageIndex pkg
PackageIndex.fromList [pkg]
pkgs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex pkg
pkgIndex, [Dependency]
prefs)
  where
    packageListFromNoIndexCache :: ([pkg], [Dependency])
    packageListFromNoIndexCache :: ([pkg], [Dependency])
packageListFromNoIndexCache = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])
go forall a. Monoid a => a
mempty (NoIndexCache -> [NoIndexCacheEntry]
noIndexCacheEntries NoIndexCache
cache)

    go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])
    go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])
go (CacheGPD GenericPackageDescription
gpd ByteString
bs) ([pkg]
pkgs, [Dependency]
prefs) =
        let pkgId :: PackageId
pkgId = PackageDescription -> PackageId
package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Distribution.PackageDescription.packageDescription GenericPackageDescription
gpd
        in (PackageEntry -> pkg
mkPkg (PackageId
-> GenericPackageDescription
-> ByteString
-> BlockNo
-> PackageEntry
NormalPackage PackageId
pkgId GenericPackageDescription
gpd (ByteString -> ByteString
BS.fromStrict ByteString
bs) BlockNo
0) forall a. a -> [a] -> [a]
: [pkg]
pkgs, [Dependency]
prefs)
    go (NoIndexCachePreference [Dependency]
deps) ([pkg]
pkgs, [Dependency]
prefs) =
        ([pkg]
pkgs, [Dependency]
deps forall a. [a] -> [a] -> [a]
++ [Dependency]
prefs)


-- | Read package list
--
-- The result package releases and preference entries are guaranteed
-- to be unique.
--
-- Note: 01-index.tar is an append-only index and therefore contains
-- all .cabal edits and preference-updates. The masking happens
-- here, i.e. the semantics that later entries in a tar file mask
-- earlier ones is resolved in this function.
packageListFromCache :: Verbosity
                     -> (PackageEntry -> pkg)
                     -> Handle
                     -> Cache
                     -> IO ([pkg], [Dependency])
packageListFromCache :: forall pkg.
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO ([pkg], [Dependency])
packageListFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache{[IndexCacheEntry]
Timestamp
cacheEntries :: [IndexCacheEntry]
cacheHeadTs :: Timestamp
cacheEntries :: Cache -> [IndexCacheEntry]
cacheHeadTs :: Cache -> Timestamp
..} = Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum forall a. Monoid a => a
mempty [] forall a. Monoid a => a
mempty [IndexCacheEntry]
cacheEntries
  where
    accum :: Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum !Map PackageId pkg
srcpkgs [pkg]
btrs !Map PackageName Dependency
prefs [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Map k a -> [a]
Map.elems Map PackageId pkg
srcpkgs forall a. [a] -> [a] -> [a]
++ [pkg]
btrs, forall k a. Map k a -> [a]
Map.elems Map PackageName Dependency
prefs)

    accum Map PackageId pkg
srcpkgs [pkg]
btrs Map PackageName Dependency
prefs (CachePackageId PackageId
pkgid BlockNo
blockno Timestamp
_ : [IndexCacheEntry]
entries) = do
      -- Given the cache entry, make a package index entry.
      -- The magic here is that we use lazy IO to read the .cabal file
      -- from the index tarball if it turns out that we need it.
      -- Most of the time we only need the package id.
      ~(GenericPackageDescription
pkg, ByteString
pkgtxt) <- forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
        ByteString
pkgtxt <- BlockNo -> IO ByteString
getEntryContent BlockNo
blockno
        GenericPackageDescription
pkg    <- PackageId -> ByteString -> IO GenericPackageDescription
readPackageDescription PackageId
pkgid ByteString
pkgtxt
        forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription
pkg, ByteString
pkgtxt)

      let srcpkg :: pkg
srcpkg = PackageEntry -> pkg
mkPkg (PackageId
-> GenericPackageDescription
-> ByteString
-> BlockNo
-> PackageEntry
NormalPackage PackageId
pkgid GenericPackageDescription
pkg ByteString
pkgtxt BlockNo
blockno)
      Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageId
pkgid pkg
srcpkg Map PackageId pkg
srcpkgs) [pkg]
btrs Map PackageName Dependency
prefs [IndexCacheEntry]
entries

    accum Map PackageId pkg
srcpkgs [pkg]
btrs Map PackageName Dependency
prefs (CacheBuildTreeRef BuildTreeRefType
refType BlockNo
blockno : [IndexCacheEntry]
entries) = do
      -- We have to read the .cabal file eagerly here because we can't cache the
      -- package id for build tree references - the user might edit the .cabal
      -- file after the reference was added to the index.
      [Char]
path <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> [Char]
byteStringToFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNo -> IO ByteString
getEntryContent forall a b. (a -> b) -> a -> b
$ BlockNo
blockno
      GenericPackageDescription
pkg  <- do let err :: [Char]
err = [Char]
"Error reading package index from cache."
                 [Char]
file <- Verbosity -> [Char] -> [Char] -> IO [Char]
tryFindAddSourcePackageDesc Verbosity
verbosity [Char]
path [Char]
err
                 Verbosity -> [Char] -> IO GenericPackageDescription
PackageDesc.Parse.readGenericPackageDescription Verbosity
normal [Char]
file
      let srcpkg :: pkg
srcpkg = PackageEntry -> pkg
mkPkg (BuildTreeRefType
-> PackageId
-> GenericPackageDescription
-> [Char]
-> BlockNo
-> PackageEntry
BuildTreeRef BuildTreeRefType
refType (forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg) GenericPackageDescription
pkg [Char]
path BlockNo
blockno)
      Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum Map PackageId pkg
srcpkgs (pkg
srcpkgforall a. a -> [a] -> [a]
:[pkg]
btrs) Map PackageName Dependency
prefs [IndexCacheEntry]
entries

    accum Map PackageId pkg
srcpkgs [pkg]
btrs Map PackageName Dependency
prefs (CachePreference pref :: Dependency
pref@(Dependency PackageName
pn VersionRange
_ NonEmptySet LibraryName
_) BlockNo
_ Timestamp
_ : [IndexCacheEntry]
entries) =
      Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum Map PackageId pkg
srcpkgs [pkg]
btrs (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageName
pn Dependency
pref Map PackageName Dependency
prefs) [IndexCacheEntry]
entries

    getEntryContent :: BlockNo -> IO ByteString
    getEntryContent :: BlockNo -> IO ByteString
getEntryContent BlockNo
blockno = do
      Entry
entry <- Handle -> BlockNo -> IO Entry
Tar.hReadEntry Handle
hnd BlockNo
blockno
      case Entry -> EntryContent
Tar.entryContent Entry
entry of
        Tar.NormalFile ByteString
content FileSize
_size -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
        Tar.OtherEntryType Char
typecode ByteString
content FileSize
_size
          | Char -> Bool
Tar.isBuildTreeRefTypeCode Char
typecode
          -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
        EntryContent
_ -> forall a. [Char] -> IO a
interror [Char]
"unexpected tar entry type"

    readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription
    readPackageDescription :: PackageId -> ByteString -> IO GenericPackageDescription
readPackageDescription PackageId
pkgid ByteString
content =
      case forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
PackageDesc.Parse.runParseResult forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
content of
        Right GenericPackageDescription
gpd                                           -> forall (m :: * -> *) a. Monad m => a -> m a
return GenericPackageDescription
gpd
        Left (Just Version
specVer, NonEmpty PError
_) | Version
specVer forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2,Int
2] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> GenericPackageDescription
dummyPackageDescription Version
specVer)
        Left (Maybe Version, NonEmpty PError)
_                                              -> forall a. [Char] -> IO a
interror [Char]
"failed to parse .cabal file"
      where
        dummyPackageDescription :: Version -> GenericPackageDescription
        dummyPackageDescription :: Version -> GenericPackageDescription
dummyPackageDescription Version
specVer = GenericPackageDescription
            { packageDescription :: PackageDescription
packageDescription = PackageDescription
emptyPackageDescription
                                   { package :: PackageId
package     = PackageId
pkgid
                                   , synopsis :: ShortText
synopsis    = ShortText
dummySynopsis
                                   }
            , gpdScannedVersion :: Maybe Version
gpdScannedVersion = forall a. a -> Maybe a
Just Version
specVer -- tells index scanner to skip this file.
            , genPackageFlags :: [PackageFlag]
genPackageFlags  = []
            , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
condLibrary      = forall a. Maybe a
Nothing
            , condSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries = []
            , condForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
condForeignLibs  = []
            , condExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condExecutables  = []
            , condTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites   = []
            , condBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks   = []
            }

        dummySynopsis :: ShortText
dummySynopsis = ShortText
"<could not be parsed due to unsupported CABAL spec-version>"

    interror :: String -> IO a
    interror :: forall a. [Char] -> IO a
interror [Char]
msg = forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"internal error when reading package index: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
                      forall a. [a] -> [a] -> [a]
++ [Char]
"The package index or index cache is probably "
                      forall a. [a] -> [a] -> [a]
++ [Char]
"corrupt. Running cabal update might fix it."



------------------------------------------------------------------------
-- Index cache data structure --

-- | Read the 'Index' cache from the filesystem
--
-- If a corrupted index cache is detected this function regenerates
-- the index cache and then reattempt to read the index once (and
-- 'die's if it fails again).
readIndexCache :: Verbosity -> Index -> IO Cache
readIndexCache :: Verbosity -> Index -> IO Cache
readIndexCache Verbosity
verbosity Index
index = do
    Either [Char] Cache
cacheOrFail <- Index -> IO (Either [Char] Cache)
readIndexCache' Index
index
    case Either [Char] Cache
cacheOrFail of
      Left [Char]
msg -> do
          Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [Char]
"Parsing the index cache failed (", [Char]
msg, [Char]
"). "
              , [Char]
"Trying to regenerate the index cache..."
              ]

          Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index

          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache -> Cache
hashConsCache) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Index -> IO (Either [Char] Cache)
readIndexCache' Index
index

      Right Cache
res -> forall (m :: * -> *) a. Monad m => a -> m a
return (Cache -> Cache
hashConsCache Cache
res)

readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
readNoIndexCache Verbosity
verbosity Index
index = do
    Either [Char] NoIndexCache
cacheOrFail <- Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Index
index
    case Either [Char] NoIndexCache
cacheOrFail of
      Left [Char]
msg -> do
          Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [Char]
"Parsing the index cache failed (", [Char]
msg, [Char]
"). "
              , [Char]
"Trying to regenerate the index cache..."
              ]

          Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index

          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [Char] -> IO a
die' Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Index
index

      -- we don't hash cons local repository cache, they are hopefully small
      Right NoIndexCache
res -> forall (m :: * -> *) a. Monad m => a -> m a
return NoIndexCache
res

-- | Read the 'Index' cache from the filesystem without attempting to
-- regenerate on parsing failures.
readIndexCache' :: Index -> IO (Either String Cache)
readIndexCache' :: Index -> IO (Either [Char] Cache)
readIndexCache' Index
index
  | Index -> Bool
is01Index Index
index = forall a.
(Binary a, Structured a) =>
[Char] -> IO (Either [Char] a)
structuredDecodeFileOrFail (Index -> [Char]
cacheFile Index
index)
  | Bool
otherwise       = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
.ByteString -> Cache
read00IndexCache) forall a b. (a -> b) -> a -> b
$
                      [Char] -> IO ByteString
BSS.readFile (Index -> [Char]
cacheFile Index
index)

readNoIndexCache' :: Index -> IO (Either String NoIndexCache)
readNoIndexCache' :: Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Index
index = forall a.
(Binary a, Structured a) =>
[Char] -> IO (Either [Char] a)
structuredDecodeFileOrFail (Index -> [Char]
cacheFile Index
index)

-- | Write the 'Index' cache to the filesystem
writeIndexCache :: Index -> Cache -> IO ()
writeIndexCache :: Index -> Cache -> IO ()
writeIndexCache Index
index Cache
cache
  | Index -> Bool
is01Index Index
index = forall a. (Binary a, Structured a) => [Char] -> a -> IO ()
structuredEncodeFile (Index -> [Char]
cacheFile Index
index) Cache
cache
  | Bool
otherwise       = [Char] -> [Char] -> IO ()
writeFile (Index -> [Char]
cacheFile Index
index) (Cache -> [Char]
show00IndexCache Cache
cache)

writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()
writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()
writeNoIndexCache Verbosity
verbosity Index
index NoIndexCache
cache = do
    let path :: [Char]
path = Index -> [Char]
cacheFile Index
index
    Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True ([Char] -> [Char]
takeDirectory [Char]
path)
    forall a. (Binary a, Structured a) => [Char] -> a -> IO ()
structuredEncodeFile [Char]
path NoIndexCache
cache

-- | Write the 'IndexState' to the filesystem
writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
writeIndexTimestamp Index
index RepoIndexState
st
  = [Char] -> [Char] -> IO ()
writeFile (Index -> [Char]
timestampFile Index
index) (forall a. Pretty a => a -> [Char]
prettyShow RepoIndexState
st)

-- | Read out the "current" index timestamp, i.e., what
-- timestamp you would use to revert to this version
currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp
currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp
currentIndexTimestamp Verbosity
verbosity RepoContext
repoCtxt Repo
r = do
    Maybe RepoIndexState
mb_is <- Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp Verbosity
verbosity (RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
r)
    case Maybe RepoIndexState
mb_is of
      Just (IndexStateTime Timestamp
ts) -> forall (m :: * -> *) a. Monad m => a -> m a
return Timestamp
ts
      Maybe RepoIndexState
_ -> do
        (PackageIndex UnresolvedSourcePackage
_,[Dependency]
_,IndexStateInfo
isi) <- Verbosity
-> RepoContext
-> Repo
-> RepoIndexState
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
readRepoIndex Verbosity
verbosity RepoContext
repoCtxt Repo
r RepoIndexState
IndexStateHead
        forall (m :: * -> *) a. Monad m => a -> m a
return (IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi)

-- | Read the 'IndexState' from the filesystem
readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp Verbosity
verbosity Index
index
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Parsec a => [Char] -> Maybe a
simpleParsec ([Char] -> IO [Char]
readFile (Index -> [Char]
timestampFile Index
index))
        forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e ->
            if IOException -> Bool
isDoesNotExistError IOException
e
                then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                else do
                   Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [Char]
"Warning: could not read current index timestamp: " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> [Char]
displayException IOException
e
                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Optimise sharing of equal values inside 'Cache'
--
-- c.f. https://en.wikipedia.org/wiki/Hash_consing
hashConsCache :: Cache -> Cache
hashConsCache :: Cache -> Cache
hashConsCache Cache
cache0
    = Cache
cache0 { cacheEntries :: [IndexCacheEntry]
cacheEntries = Map PackageName PackageName
-> Map Version Version -> [IndexCacheEntry] -> [IndexCacheEntry]
go forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (Cache -> [IndexCacheEntry]
cacheEntries Cache
cache0) }
  where
    -- TODO/NOTE:
    --
    -- If/when we redo the binary serialisation via e.g. CBOR and we
    -- are able to use incremental decoding, we may want to move the
    -- hash-consing into the incremental deserialisation, or
    -- alternatively even do something like
    -- http://cbor.schmorp.de/value-sharing
    --
    go :: Map PackageName PackageName
-> Map Version Version -> [IndexCacheEntry] -> [IndexCacheEntry]
go Map PackageName PackageName
_ Map Version Version
_ [] = []
    -- for now we only optimise only CachePackageIds since those
    -- represent the vast majority
    go !Map PackageName PackageName
pns !Map Version Version
pvs (CachePackageId PackageId
pid BlockNo
bno Timestamp
ts : [IndexCacheEntry]
rest)
        = PackageId -> BlockNo -> Timestamp -> IndexCacheEntry
CachePackageId PackageId
pid' BlockNo
bno Timestamp
ts forall a. a -> [a] -> [a]
: Map PackageName PackageName
-> Map Version Version -> [IndexCacheEntry] -> [IndexCacheEntry]
go Map PackageName PackageName
pns' Map Version Version
pvs' [IndexCacheEntry]
rest
      where
        !pid' :: PackageId
pid' = PackageName -> Version -> PackageId
PackageIdentifier PackageName
pn' Version
pv'
        (!PackageName
pn',!Map PackageName PackageName
pns') = forall k. Ord k => k -> Map k k -> (k, Map k k)
mapIntern PackageName
pn Map PackageName PackageName
pns
        (!Version
pv',!Map Version Version
pvs') = forall k. Ord k => k -> Map k k -> (k, Map k k)
mapIntern Version
pv Map Version Version
pvs
        PackageIdentifier PackageName
pn Version
pv = PackageId
pid

    go Map PackageName PackageName
pns Map Version Version
pvs (IndexCacheEntry
x:[IndexCacheEntry]
xs) = IndexCacheEntry
x forall a. a -> [a] -> [a]
: Map PackageName PackageName
-> Map Version Version -> [IndexCacheEntry] -> [IndexCacheEntry]
go Map PackageName PackageName
pns Map Version Version
pvs [IndexCacheEntry]
xs

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

-- | Cabal caches various information about the Hackage index
data Cache = Cache
    { Cache -> Timestamp
cacheHeadTs  :: Timestamp
      -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the
      -- invariant of 'cacheEntries' being in chronological order is
      -- violated, this corresponds to the last (seen) 'Timestamp' in
      -- 'cacheEntries'
    , Cache -> [IndexCacheEntry]
cacheEntries :: [IndexCacheEntry]
    }
  deriving (Int -> Cache -> [Char] -> [Char]
[Cache] -> [Char] -> [Char]
Cache -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Cache] -> [Char] -> [Char]
$cshowList :: [Cache] -> [Char] -> [Char]
show :: Cache -> [Char]
$cshow :: Cache -> [Char]
showsPrec :: Int -> Cache -> [Char] -> [Char]
$cshowsPrec :: Int -> Cache -> [Char] -> [Char]
Show, forall x. Rep Cache x -> Cache
forall x. Cache -> Rep Cache x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Cache x -> Cache
$cfrom :: forall x. Cache -> Rep Cache x
Generic)

instance NFData Cache where
    rnf :: Cache -> ()
rnf = forall a. NFData a => a -> ()
rnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache -> [IndexCacheEntry]
cacheEntries

-- | Cache format for 'file+noindex' repositories
newtype NoIndexCache = NoIndexCache
    { NoIndexCache -> [NoIndexCacheEntry]
noIndexCacheEntries :: [NoIndexCacheEntry]
    }
  deriving (Int -> NoIndexCache -> [Char] -> [Char]
[NoIndexCache] -> [Char] -> [Char]
NoIndexCache -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [NoIndexCache] -> [Char] -> [Char]
$cshowList :: [NoIndexCache] -> [Char] -> [Char]
show :: NoIndexCache -> [Char]
$cshow :: NoIndexCache -> [Char]
showsPrec :: Int -> NoIndexCache -> [Char] -> [Char]
$cshowsPrec :: Int -> NoIndexCache -> [Char] -> [Char]
Show, forall x. Rep NoIndexCache x -> NoIndexCache
forall x. NoIndexCache -> Rep NoIndexCache x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NoIndexCache x -> NoIndexCache
$cfrom :: forall x. NoIndexCache -> Rep NoIndexCache x
Generic)

instance NFData NoIndexCache where
    rnf :: NoIndexCache -> ()
rnf = forall a. NFData a => a -> ()
rnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoIndexCache -> [NoIndexCacheEntry]
noIndexCacheEntries

-- | Tar files are block structured with 512 byte blocks. Every header and file
-- content starts on a block boundary.
--
type BlockNo = Word32 -- Tar.TarEntryOffset

data IndexCacheEntry
    = CachePackageId PackageId !BlockNo !Timestamp
    | CachePreference Dependency !BlockNo !Timestamp
    | CacheBuildTreeRef !BuildTreeRefType !BlockNo
      -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build
  deriving (IndexCacheEntry -> IndexCacheEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexCacheEntry -> IndexCacheEntry -> Bool
$c/= :: IndexCacheEntry -> IndexCacheEntry -> Bool
== :: IndexCacheEntry -> IndexCacheEntry -> Bool
$c== :: IndexCacheEntry -> IndexCacheEntry -> Bool
Eq,Int -> IndexCacheEntry -> [Char] -> [Char]
[IndexCacheEntry] -> [Char] -> [Char]
IndexCacheEntry -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [IndexCacheEntry] -> [Char] -> [Char]
$cshowList :: [IndexCacheEntry] -> [Char] -> [Char]
show :: IndexCacheEntry -> [Char]
$cshow :: IndexCacheEntry -> [Char]
showsPrec :: Int -> IndexCacheEntry -> [Char] -> [Char]
$cshowsPrec :: Int -> IndexCacheEntry -> [Char] -> [Char]
Show,forall x. Rep IndexCacheEntry x -> IndexCacheEntry
forall x. IndexCacheEntry -> Rep IndexCacheEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IndexCacheEntry x -> IndexCacheEntry
$cfrom :: forall x. IndexCacheEntry -> Rep IndexCacheEntry x
Generic)

data NoIndexCacheEntry
    = CacheGPD GenericPackageDescription !BSS.ByteString
    | NoIndexCachePreference [Dependency]
  deriving (NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
$c/= :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
== :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
$c== :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
Eq,Int -> NoIndexCacheEntry -> [Char] -> [Char]
[NoIndexCacheEntry] -> [Char] -> [Char]
NoIndexCacheEntry -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [NoIndexCacheEntry] -> [Char] -> [Char]
$cshowList :: [NoIndexCacheEntry] -> [Char] -> [Char]
show :: NoIndexCacheEntry -> [Char]
$cshow :: NoIndexCacheEntry -> [Char]
showsPrec :: Int -> NoIndexCacheEntry -> [Char] -> [Char]
$cshowsPrec :: Int -> NoIndexCacheEntry -> [Char] -> [Char]
Show,forall x. Rep NoIndexCacheEntry x -> NoIndexCacheEntry
forall x. NoIndexCacheEntry -> Rep NoIndexCacheEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NoIndexCacheEntry x -> NoIndexCacheEntry
$cfrom :: forall x. NoIndexCacheEntry -> Rep NoIndexCacheEntry x
Generic)

instance NFData IndexCacheEntry where
    rnf :: IndexCacheEntry -> ()
rnf (CachePackageId PackageId
pkgid BlockNo
_ Timestamp
_) = forall a. NFData a => a -> ()
rnf PackageId
pkgid
    rnf (CachePreference Dependency
dep BlockNo
_ Timestamp
_) = forall a. NFData a => a -> ()
rnf Dependency
dep
    rnf (CacheBuildTreeRef BuildTreeRefType
_ BlockNo
_) = ()

instance NFData NoIndexCacheEntry where
    rnf :: NoIndexCacheEntry -> ()
rnf (CacheGPD GenericPackageDescription
gpd ByteString
bs) = forall a. NFData a => a -> ()
rnf GenericPackageDescription
gpd seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf ByteString
bs
    rnf (NoIndexCachePreference [Dependency]
dep) = forall a. NFData a => a -> ()
rnf [Dependency]
dep

cacheEntryTimestamp :: IndexCacheEntry -> Timestamp
cacheEntryTimestamp :: IndexCacheEntry -> Timestamp
cacheEntryTimestamp (CacheBuildTreeRef BuildTreeRefType
_ BlockNo
_)  = Timestamp
nullTimestamp
cacheEntryTimestamp (CachePreference Dependency
_ BlockNo
_ Timestamp
ts) = Timestamp
ts
cacheEntryTimestamp (CachePackageId PackageId
_ BlockNo
_ Timestamp
ts)  = Timestamp
ts

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

instance Binary Cache
instance Binary IndexCacheEntry
instance Binary NoIndexCache

instance Structured Cache
instance Structured IndexCacheEntry
instance Structured NoIndexCache

-- | We need to save only .cabal file contents
instance Binary NoIndexCacheEntry where
    put :: NoIndexCacheEntry -> Put
put (CacheGPD GenericPackageDescription
_ ByteString
bs) = do
        forall t. Binary t => t -> Put
put (Word8
0 :: Word8)
        forall t. Binary t => t -> Put
put ByteString
bs
    put (NoIndexCachePreference [Dependency]
dep) = do
        forall t. Binary t => t -> Put
put (Word8
1 :: Word8)
        forall t. Binary t => t -> Put
put [Dependency]
dep

    get :: Get NoIndexCacheEntry
get = do
        Word8
t :: Word8 <- forall t. Binary t => Get t
get
        case Word8
t of
          Word8
0 -> do
            ByteString
bs <- forall t. Binary t => Get t
get
            case ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
bs of
                Just GenericPackageDescription
gpd -> forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription -> ByteString -> NoIndexCacheEntry
CacheGPD GenericPackageDescription
gpd ByteString
bs)
                Maybe GenericPackageDescription
Nothing  -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Failed to parse GPD"
          Word8
1 -> do
            [Dependency]
dep <- forall t. Binary t => Get t
get
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Dependency] -> NoIndexCacheEntry
NoIndexCachePreference [Dependency]
dep
          Word8
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Failed to parse NoIndexCacheEntry"

instance Structured NoIndexCacheEntry where
    structure :: Proxy NoIndexCacheEntry -> Structure
structure = forall {k} (a :: k). Typeable a => Proxy a -> Structure
nominalStructure

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

packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
packageKey :: [Char]
packageKey = [Char]
"pkg:"
blocknoKey :: [Char]
blocknoKey = [Char]
"b#"
buildTreeRefKey :: [Char]
buildTreeRefKey     = [Char]
"build-tree-ref:"
preferredVersionKey :: [Char]
preferredVersionKey = [Char]
"pref-ver:"

-- legacy 00-index.cache format
read00IndexCache :: BSS.ByteString -> Cache
read00IndexCache :: ByteString -> Cache
read00IndexCache ByteString
bs = Cache
  { cacheHeadTs :: Timestamp
cacheHeadTs  = Timestamp
nullTimestamp
  , cacheEntries :: [IndexCacheEntry]
cacheEntries = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BSS.lines ByteString
bs
  }

read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry :: ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry = \ByteString
line ->
  case ByteString -> [ByteString]
BSS.words ByteString
line of
    [ByteString
key, ByteString
pkgnamestr, ByteString
pkgverstr, ByteString
sep, ByteString
blocknostr]
      | ByteString
key forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BSS.pack [Char]
packageKey Bool -> Bool -> Bool
&& ByteString
sep forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BSS.pack [Char]
blocknoKey ->
      case (ByteString -> Maybe PackageName
parseName ByteString
pkgnamestr, ByteString -> [Int] -> Maybe Version
parseVer ByteString
pkgverstr [],
            forall {a}. Num a => ByteString -> Maybe a
parseBlockNo ByteString
blocknostr) of
        (Just PackageName
pkgname, Just Version
pkgver, Just BlockNo
blockno)
          -> forall a. a -> Maybe a
Just (PackageId -> BlockNo -> Timestamp -> IndexCacheEntry
CachePackageId (PackageName -> Version -> PackageId
PackageIdentifier PackageName
pkgname Version
pkgver)
                                  BlockNo
blockno Timestamp
nullTimestamp)
        (Maybe PackageName, Maybe Version, Maybe BlockNo)
_ -> forall a. Maybe a
Nothing
    [ByteString
key, ByteString
typecodestr, ByteString
blocknostr] | ByteString
key forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BSS.pack [Char]
buildTreeRefKey ->
      case (ByteString -> Maybe BuildTreeRefType
parseRefType ByteString
typecodestr, forall {a}. Num a => ByteString -> Maybe a
parseBlockNo ByteString
blocknostr) of
        (Just BuildTreeRefType
refType, Just BlockNo
blockno)
          -> forall a. a -> Maybe a
Just (BuildTreeRefType -> BlockNo -> IndexCacheEntry
CacheBuildTreeRef BuildTreeRefType
refType BlockNo
blockno)
        (Maybe BuildTreeRefType, Maybe BlockNo)
_ -> forall a. Maybe a
Nothing

    (ByteString
key: [ByteString]
remainder) | ByteString
key forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BSS.pack [Char]
preferredVersionKey -> do
      Dependency
pref <- forall a. Parsec a => ByteString -> Maybe a
simpleParsecBS ([ByteString] -> ByteString
BSS.unwords [ByteString]
remainder)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dependency -> BlockNo -> Timestamp -> IndexCacheEntry
CachePreference Dependency
pref BlockNo
0 Timestamp
nullTimestamp

    [ByteString]
_  -> forall a. Maybe a
Nothing
  where
    parseName :: ByteString -> Maybe PackageName
parseName ByteString
str
      | (Char -> Bool) -> ByteString -> Bool
BSS.all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-') ByteString
str
                  = forall a. a -> Maybe a
Just ([Char] -> PackageName
mkPackageName (ByteString -> [Char]
BSS.unpack ByteString
str))
      | Bool
otherwise = forall a. Maybe a
Nothing

    parseVer :: ByteString -> [Int] -> Maybe Version
parseVer ByteString
str [Int]
vs =
      case ByteString -> Maybe (Int, ByteString)
BSS.readInt ByteString
str of
        Maybe (Int, ByteString)
Nothing        -> forall a. Maybe a
Nothing
        Just (Int
v, ByteString
str') -> case ByteString -> Maybe (Char, ByteString)
BSS.uncons ByteString
str' of
          Just (Char
'.', ByteString
str'') -> ByteString -> [Int] -> Maybe Version
parseVer ByteString
str'' (Int
vforall a. a -> [a] -> [a]
:[Int]
vs)
          Just (Char, ByteString)
_            -> forall a. Maybe a
Nothing
          Maybe (Char, ByteString)
Nothing           -> forall a. a -> Maybe a
Just ([Int] -> Version
mkVersion (forall a. [a] -> [a]
reverse (Int
vforall a. a -> [a] -> [a]
:[Int]
vs)))

    parseBlockNo :: ByteString -> Maybe a
parseBlockNo ByteString
str =
      case ByteString -> Maybe (Int, ByteString)
BSS.readInt ByteString
str of
        Just (Int
blockno, ByteString
remainder)
          | ByteString -> Bool
BSS.null ByteString
remainder -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
blockno)
        Maybe (Int, ByteString)
_                      -> forall a. Maybe a
Nothing

    parseRefType :: ByteString -> Maybe BuildTreeRefType
parseRefType ByteString
str =
      case ByteString -> Maybe (Char, ByteString)
BSS.uncons ByteString
str of
        Just (Char
typeCode, ByteString
remainder)
          | ByteString -> Bool
BSS.null ByteString
remainder Bool -> Bool -> Bool
&& Char -> Bool
Tar.isBuildTreeRefTypeCode Char
typeCode
            -> forall a. a -> Maybe a
Just (Char -> BuildTreeRefType
refTypeFromTypeCode Char
typeCode)
        Maybe (Char, ByteString)
_   -> forall a. Maybe a
Nothing

-- legacy 00-index.cache format
show00IndexCache :: Cache -> String
show00IndexCache :: Cache -> [Char]
show00IndexCache Cache{[IndexCacheEntry]
Timestamp
cacheEntries :: [IndexCacheEntry]
cacheHeadTs :: Timestamp
cacheEntries :: Cache -> [IndexCacheEntry]
cacheHeadTs :: Cache -> Timestamp
..} = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map IndexCacheEntry -> [Char]
show00IndexCacheEntry [IndexCacheEntry]
cacheEntries

show00IndexCacheEntry :: IndexCacheEntry -> String
show00IndexCacheEntry :: IndexCacheEntry -> [Char]
show00IndexCacheEntry IndexCacheEntry
entry = [[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ case IndexCacheEntry
entry of
    CachePackageId PackageId
pkgid BlockNo
b Timestamp
_ ->
        [ [Char]
packageKey
        , forall a. Pretty a => a -> [Char]
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgid)
        , forall a. Pretty a => a -> [Char]
prettyShow (forall pkg. Package pkg => pkg -> Version
packageVersion PackageId
pkgid)
        , [Char]
blocknoKey
        , forall a. Show a => a -> [Char]
show BlockNo
b
        ]
    CacheBuildTreeRef BuildTreeRefType
tr BlockNo
b ->
        [ [Char]
buildTreeRefKey
        , [BuildTreeRefType -> Char
typeCodeFromRefType BuildTreeRefType
tr]
        , forall a. Show a => a -> [Char]
show BlockNo
b
        ]
    CachePreference Dependency
dep BlockNo
_ Timestamp
_  ->
        [ [Char]
preferredVersionKey
        , forall a. Pretty a => a -> [Char]
prettyShow Dependency
dep
        ]