{-# 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 -> FilePath
indexBaseName Repo
repo = Repo -> FilePath
repoLocalDir Repo
repo FilePath -> FilePath -> FilePath
</> FilePath
fn
  where
    fn :: FilePath
fn = case Repo
repo of
           RepoSecure {}       -> FilePath
"01-index"
           RepoRemote {}       -> FilePath
"00-index"
           RepoLocalNoIndex {} -> FilePath
"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 -> Timestamp -> IndexStateInfo
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 -> Timestamp -> IndexStateInfo
IndexStateInfo{Timestamp
isiMaxTime :: Timestamp
isiHeadTime :: Timestamp
isiHeadTime :: Timestamp
isiMaxTime :: Timestamp
..})
  where
    cache :: Cache
cache = Cache :: Timestamp -> [IndexCacheEntry] -> 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 ((IndexCacheEntry -> Timestamp) -> [IndexCacheEntry] -> [Timestamp]
forall a b. (a -> b) -> [a] -> [b]
map IndexCacheEntry -> Timestamp
cacheEntryTimestamp [IndexCacheEntry]
ents)
    ents :: [IndexCacheEntry]
ents = (IndexCacheEntry -> Bool) -> [IndexCacheEntry] -> [IndexCacheEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
<= Timestamp
ts0) (Timestamp -> Bool)
-> (IndexCacheEntry -> Timestamp) -> IndexCacheEntry -> Bool
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 =
    (SourcePackageDb, TotalIndexState, ActiveRepos) -> SourcePackageDb
forall a b c. (a, b, c) -> a
fstOf3 ((SourcePackageDb, TotalIndexState, ActiveRepos)
 -> SourcePackageDb)
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
-> IO SourcePackageDb
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 Maybe TotalIndexState
forall a. Maybe a
Nothing Maybe ActiveRepos
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
_
  | [Repo] -> Bool
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 -> FilePath -> IO ()
warn (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"No remote package servers have been specified. Usually " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        FilePath
"you would have one specified in the config file."
      (SourcePackageDb, TotalIndexState, ActiveRepos)
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
forall (m :: * -> *) a. Monad m => a -> m a
return (SourcePackageDb :: PackageIndex UnresolvedSourcePackage
-> Map PackageName VersionRange -> SourcePackageDb
SourcePackageDb {
        packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex       = PackageIndex UnresolvedSourcePackage
forall a. Monoid a => a
mempty,
        packagePreferences :: Map PackageName VersionRange
packagePreferences = Map PackageName VersionRange
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 -> FilePath
describeState RepoIndexState
IndexStateHead        = FilePath
"most recent state"
      describeState (IndexStateTime Timestamp
time) = FilePath
"historical state as of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Timestamp
time

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

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

      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 -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Using " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoIndexState -> FilePath
describeState RepoIndexState
idxState FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
            FilePath
" as explicitly requested (via command line / project configuration)"
          RepoIndexState -> IO RepoIndexState
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 -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"Using most recent state (could not read timestamp file)"
              RepoIndexState -> IO RepoIndexState
forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
IndexStateHead
            Just RepoIndexState
idxState -> do
              Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Using " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoIndexState -> FilePath
describeState RepoIndexState
idxState FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                FilePath
" specified from most recent cabal update"
              RepoIndexState -> IO RepoIndexState
forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
idxState

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoIndexState
idxState RepoIndexState -> RepoIndexState -> Bool
forall a. Eq a => a -> a -> Bool
== RepoIndexState
IndexStateHead) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          case Repo
r of
            RepoLocalNoIndex {} -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
"index-state ignored for file+noindex repositories"
            RepoRemote {} -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"index-state ignored for old-format (remote repository '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName RepoName
rname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"')")
            RepoSecure {} -> () -> IO ()
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 -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"index-state("FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName RepoName
rname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
") = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi))
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IndexStateTime Timestamp
ts0 -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
/= Timestamp
ts0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                if Timestamp
ts0 Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
> IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi
                    then Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   FilePath
"Requested index-state " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Timestamp
ts0
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is newer than '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName RepoName
rname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'!"
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" Falling back to older state ("
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")."
                    else Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   FilePath
"Requested index-state " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Timestamp
ts0
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" does not exist in '"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName RepoName
rname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"'!"
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" Falling back to older state ("
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")."
            Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"index-state("FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName RepoName
rname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
") = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                              Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (HEAD = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                              Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")")

      RepoData -> IO RepoData
forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoData :: RepoName
-> Timestamp
-> PackageIndex UnresolvedSourcePackage
-> [Dependency]
-> RepoData
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 = ActiveRepos -> Maybe ActiveRepos -> ActiveRepos
forall a. a -> Maybe a -> a
fromMaybe ActiveRepos
defaultActiveRepos Maybe ActiveRepos
mb_activeRepos

  [(RepoData, CombineStrategy)]
pkgss' <- case ActiveRepos
-> (RepoData -> RepoName)
-> [RepoData]
-> Either FilePath [(RepoData, CombineStrategy)]
forall a.
ActiveRepos
-> (a -> RepoName) -> [a] -> Either FilePath [(a, CombineStrategy)]
organizeByRepos ActiveRepos
activeRepos RepoData -> RepoName
rdRepoName [RepoData]
pkgss of
    Right [(RepoData, CombineStrategy)]
x  -> [(RepoData, CombineStrategy)] -> IO [(RepoData, CombineStrategy)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(RepoData, CombineStrategy)]
x
    Left FilePath
err -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
err IO ()
-> IO [(RepoData, CombineStrategy)]
-> IO [(RepoData, CombineStrategy)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(RepoData, CombineStrategy)] -> IO [(RepoData, CombineStrategy)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((RepoData -> (RepoData, CombineStrategy))
-> [RepoData] -> [(RepoData, CombineStrategy)]
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 (Map RepoName RepoIndexState -> TotalIndexState)
-> Map RepoName RepoIndexState -> TotalIndexState
forall a b. (a -> b) -> a -> b
$ [(RepoName, RepoIndexState)] -> Map RepoName RepoIndexState
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 Timestamp -> Timestamp -> Bool
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)    = PackageIndex UnresolvedSourcePackage
-> PackageIndex UnresolvedSourcePackage
-> PackageIndex UnresolvedSourcePackage
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) = PackageIndex UnresolvedSourcePackage
-> PackageIndex UnresolvedSourcePackage
-> PackageIndex UnresolvedSourcePackage
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 = (PackageIndex UnresolvedSourcePackage
 -> (RepoData, CombineStrategy)
 -> PackageIndex UnresolvedSourcePackage)
-> PackageIndex UnresolvedSourcePackage
-> [(RepoData, CombineStrategy)]
-> PackageIndex UnresolvedSourcePackage
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PackageIndex UnresolvedSourcePackage
-> (RepoData, CombineStrategy)
-> PackageIndex UnresolvedSourcePackage
addIndex PackageIndex UnresolvedSourcePackage
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 = (VersionRange -> VersionRange -> VersionRange)
-> [(PackageName, VersionRange)] -> Map PackageName VersionRange
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
_ <- PackageIndex UnresolvedSourcePackage
-> IO (PackageIndex UnresolvedSourcePackage)
forall a. a -> IO a
evaluate PackageIndex UnresolvedSourcePackage
pkgs
  Map PackageName VersionRange
_ <- Map PackageName VersionRange -> IO (Map PackageName VersionRange)
forall a. a -> IO a
evaluate Map PackageName VersionRange
prefs
  TotalIndexState
_ <- TotalIndexState -> IO TotalIndexState
forall a. a -> IO a
evaluate TotalIndexState
totalIndexState
  (SourcePackageDb, TotalIndexState, ActiveRepos)
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
forall (m :: * -> *) a. Monad m => a -> m a
return (SourcePackageDb :: PackageIndex UnresolvedSourcePackage
-> Map PackageName VersionRange -> SourcePackageDb
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 (IO
   (PackageIndex UnresolvedSourcePackage, [Dependency],
    IndexStateInfo)
 -> IO
      (PackageIndex UnresolvedSourcePackage, [Dependency],
       IndexStateInfo))
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Repo -> Bool
isRepoRemote Repo
repo) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> IO ()
warnIfIndexIsOld (Double -> IO ()) -> IO Double -> IO ()
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) IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO`
       (\IOException
e -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"unable to update the repo index cache -- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e)
    Verbosity
-> (PackageEntry -> UnresolvedSourcePackage)
-> Index
-> RepoIndexState
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
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 :: forall loc.
PackageId
-> GenericPackageDescription
-> loc
-> PackageDescriptionOverride
-> SourcePackage loc
SourcePackage
      { srcpkgPackageId :: PackageId
srcpkgPackageId   = PackageId
pkgid
      , srcpkgDescription :: GenericPackageDescription
srcpkgDescription = GenericPackageDescription
pkgdesc
      , srcpkgSource :: PackageLocation (Maybe FilePath)
srcpkgSource      = case PackageEntry
pkgEntry of
          NormalPackage PackageId
_ GenericPackageDescription
_ ByteString
_ BlockNo
_       -> Repo
-> PackageId -> Maybe FilePath -> PackageLocation (Maybe FilePath)
forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid Maybe FilePath
forall a. Maybe a
Nothing
          BuildTreeRef  BuildTreeRefType
_  PackageId
_ GenericPackageDescription
_ FilePath
path BlockNo
_ -> FilePath -> PackageLocation (Maybe FilePath)
forall local. FilePath -> PackageLocation local
LocalUnpackedPackage FilePath
path
      , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = case PackageEntry
pkgEntry of
          NormalPackage PackageId
_ GenericPackageDescription
_ ByteString
pkgtxt BlockNo
_ -> ByteString -> PackageDescriptionOverride
forall a. a -> Maybe a
Just ByteString
pkgtxt
          PackageEntry
_                          -> PackageDescriptionOverride
forall a. Maybe a
Nothing
      }
      where
        pkgdesc :: GenericPackageDescription
pkgdesc = PackageEntry -> GenericPackageDescription
packageDesc PackageEntry
pkgEntry
        pkgid :: PackageId
pkgid = PackageEntry -> PackageId
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 = IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
-> (IOException
    -> IO
         (PackageIndex UnresolvedSourcePackage, [Dependency],
          IndexStateInfo))
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
action ((IOException
  -> IO
       (PackageIndex UnresolvedSourcePackage, [Dependency],
        IndexStateInfo))
 -> IO
      (PackageIndex UnresolvedSourcePackage, [Dependency],
       IndexStateInfo))
-> (IOException
    -> IO
         (PackageIndex UnresolvedSourcePackage, [Dependency],
          IndexStateInfo))
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall a b. (a -> b) -> a -> b
$ \IOException
e -> if IOException -> Bool
isDoesNotExistError IOException
e
      then do
        case Repo
repo of
          RepoRemote{FilePath
RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: FilePath
repoRemote :: RemoteRepo
repoLocalDir :: Repo -> FilePath
..} -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> FilePath
errMissingPackageList RemoteRepo
repoRemote
          RepoSecure{FilePath
RemoteRepo
repoLocalDir :: FilePath
repoRemote :: RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> FilePath
..} -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> FilePath
errMissingPackageList RemoteRepo
repoRemote
          RepoLocalNoIndex LocalRepo
local FilePath
_ -> Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"Error during construction of local+noindex "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" repository index: "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e
        (PackageIndex UnresolvedSourcePackage, [Dependency],
 IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIndex UnresolvedSourcePackage
forall a. Monoid a => a
mempty,[Dependency]
forall a. Monoid a => a
mempty,IndexStateInfo
emptyStateInfo)
      else IOException
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall a. IOException -> IO a
ioError IOException
e

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

    errMissingPackageList :: RemoteRepo -> FilePath
errMissingPackageList RemoteRepo
repoRemote =
         FilePath
"The package list for '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repoRemote)
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' does not exist. Run 'cabal update' to download it."
    errOutdatedPackageList :: RemoteRepo -> a -> FilePath
errOutdatedPackageList RemoteRepo
repoRemote a
dt =
         FilePath
"The package list for '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repoRemote)
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' is " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
shows (a -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor a
dt :: Int) FilePath
" days old.\nRun "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'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 = FilePath -> IO Double
getFileAge (FilePath -> IO Double) -> FilePath -> IO Double
forall a b. (a -> b) -> a -> b
$ Repo -> FilePath
indexBaseName Repo
repo FilePath -> FilePath -> FilePath
<.> FilePath
"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] -> [FilePath]
getSourcePackagesMonitorFiles [Repo]
repos =
    [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ Repo -> FilePath
indexBaseName Repo
repo FilePath -> FilePath -> FilePath
<.> FilePath
"cache"
             , Repo -> FilePath
indexBaseName Repo
repo FilePath -> FilePath -> FilePath
<.> FilePath
"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 (IO () -> IO ()) -> IO () -> IO ()
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 <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ Index -> FilePath
cacheFile Index
index
  if Bool -> Bool
not Bool
exists
  then IO ()
action
  else if Index -> Bool
localNoIndex Index
index
      then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: don't update cache for local+noindex repositories
      else do
          ModTime
indexTime <- FilePath -> IO ModTime
getModTime (FilePath -> IO ModTime) -> FilePath -> IO ModTime
forall a b. (a -> b) -> a -> b
$ Index -> FilePath
indexFile Index
index
          ModTime
cacheTime <- FilePath -> IO ModTime
getModTime (FilePath -> IO ModTime) -> FilePath -> IO ModTime
forall a b. (a -> b) -> a -> b
$ Index -> FilePath
cacheFile Index
index
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModTime
indexTime ModTime -> ModTime -> Bool
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
(BuildTreeRefType -> BuildTreeRefType -> Bool)
-> (BuildTreeRefType -> BuildTreeRefType -> Bool)
-> Eq BuildTreeRefType
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 -> FilePath -> FilePath
[BuildTreeRefType] -> FilePath -> FilePath
BuildTreeRefType -> FilePath
(Int -> BuildTreeRefType -> FilePath -> FilePath)
-> (BuildTreeRefType -> FilePath)
-> ([BuildTreeRefType] -> FilePath -> FilePath)
-> Show BuildTreeRefType
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [BuildTreeRefType] -> FilePath -> FilePath
$cshowList :: [BuildTreeRefType] -> FilePath -> FilePath
show :: BuildTreeRefType -> FilePath
$cshow :: BuildTreeRefType -> FilePath
showsPrec :: Int -> BuildTreeRefType -> FilePath -> FilePath
$cshowsPrec :: Int -> BuildTreeRefType -> FilePath -> FilePath
Show,(forall x. BuildTreeRefType -> Rep BuildTreeRefType x)
-> (forall x. Rep BuildTreeRefType x -> BuildTreeRefType)
-> Generic BuildTreeRefType
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 :: TypeCode -> BuildTreeRefType
refTypeFromTypeCode TypeCode
t
  | TypeCode
t TypeCode -> TypeCode -> Bool
forall a. Eq a => a -> a -> Bool
== TypeCode
Tar.buildTreeRefTypeCode      = BuildTreeRefType
LinkRef
  | TypeCode
t TypeCode -> TypeCode -> Bool
forall a. Eq a => a -> a -> Bool
== TypeCode
Tar.buildTreeSnapshotTypeCode = BuildTreeRefType
SnapshotRef
  | Bool
otherwise                          =
    FilePath -> BuildTreeRefType
forall a. HasCallStack => FilePath -> a
error FilePath
"Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"

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

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

packageDesc :: PackageEntry -> GenericPackageDescription
packageDesc :: PackageEntry -> GenericPackageDescription
packageDesc (NormalPackage  PackageId
_ GenericPackageDescription
descr ByteString
_ BlockNo
_) = GenericPackageDescription
descr
packageDesc (BuildTreeRef BuildTreeRefType
_ PackageId
_ GenericPackageDescription
descr FilePath
_ 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 = ((BlockNo, Entry) -> [IO (Maybe PackageOrDep)])
-> [(BlockNo, Entry)] -> [IO (Maybe PackageOrDep)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((BlockNo -> Entry -> [IO (Maybe PackageOrDep)])
-> (BlockNo, Entry) -> [IO (Maybe PackageOrDep)]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry BlockNo -> Entry -> [IO (Maybe PackageOrDep)]
extract) ([(BlockNo, Entry)] -> [IO (Maybe PackageOrDep)])
-> (ByteString -> [(BlockNo, Entry)])
-> ByteString
-> [IO (Maybe PackageOrDep)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries FormatError -> [(BlockNo, Entry)]
forall e. Show e => Entries e -> [(BlockNo, Entry)]
tarEntriesList (Entries FormatError -> [(BlockNo, Entry)])
-> (ByteString -> Entries FormatError)
-> ByteString
-> [(BlockNo, Entry)]
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 [IO (Maybe PackageOrDep)]
-> [IO (Maybe PackageOrDep)] -> [IO (Maybe PackageOrDep)]
forall a. [a] -> [a] -> [a]
++ [IO (Maybe PackageOrDep)]
tryExtractPrefs
      where
        tryExtractPkg :: [IO (Maybe PackageOrDep)]
tryExtractPkg = do
          IO (Maybe PackageEntry)
mkPkgEntry <- Maybe (IO (Maybe PackageEntry)) -> [IO (Maybe PackageEntry)]
forall a. Maybe a -> [a]
maybeToList (Maybe (IO (Maybe PackageEntry)) -> [IO (Maybe PackageEntry)])
-> Maybe (IO (Maybe PackageEntry)) -> [IO (Maybe PackageEntry)]
forall a b. (a -> b) -> a -> b
$ Verbosity -> Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
extractPkg Verbosity
verbosity Entry
entry BlockNo
blockNo
          IO (Maybe PackageOrDep) -> [IO (Maybe PackageOrDep)]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe PackageOrDep) -> [IO (Maybe PackageOrDep)])
-> IO (Maybe PackageOrDep) -> [IO (Maybe PackageOrDep)]
forall a b. (a -> b) -> a -> b
$ (Maybe PackageEntry -> Maybe PackageOrDep)
-> IO (Maybe PackageEntry) -> IO (Maybe PackageOrDep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PackageEntry -> PackageOrDep)
-> Maybe PackageEntry -> Maybe PackageOrDep
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' <- Maybe [Dependency] -> [[Dependency]]
forall a. Maybe a -> [a]
maybeToList (Maybe [Dependency] -> [[Dependency]])
-> Maybe [Dependency] -> [[Dependency]]
forall a b. (a -> b) -> a -> b
$ Entry -> Maybe [Dependency]
extractPrefs Entry
entry
          (Dependency -> IO (Maybe PackageOrDep))
-> [Dependency] -> [IO (Maybe PackageOrDep)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe PackageOrDep -> IO (Maybe PackageOrDep)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageOrDep -> IO (Maybe PackageOrDep))
-> (Dependency -> Maybe PackageOrDep)
-> Dependency
-> IO (Maybe PackageOrDep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageOrDep -> Maybe PackageOrDep
forall a. a -> Maybe a
Just (PackageOrDep -> Maybe PackageOrDep)
-> (Dependency -> PackageOrDep) -> Dependency -> Maybe PackageOrDep
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 :: Entries e -> [(BlockNo, Entry)]
tarEntriesList = BlockNo -> Entries e -> [(BlockNo, Entry)]
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)     = FilePath -> [(BlockNo, Entry)]
forall a. HasCallStack => FilePath -> a
error (FilePath
"tarEntriesList: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
e)
    go !BlockNo
n (Tar.Next Entry
e Entries a
es') = (BlockNo
n, Entry
e) (BlockNo, Entry) -> [(BlockNo, Entry)] -> [(BlockNo, Entry)]
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
_
     | FilePath -> FilePath
takeExtension FilePath
fileName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal"
    -> case FilePath -> [FilePath]
splitDirectories (FilePath -> FilePath
normalise FilePath
fileName) of
        [FilePath
pkgname,FilePath
vers,FilePath
_] -> case FilePath -> Maybe Version
forall a. Parsec a => FilePath -> Maybe a
simpleParsec FilePath
vers of
          Just Version
ver -> IO (Maybe PackageEntry) -> Maybe (IO (Maybe PackageEntry))
forall a. a -> Maybe a
Just (IO (Maybe PackageEntry) -> Maybe (IO (Maybe PackageEntry)))
-> (Maybe PackageEntry -> IO (Maybe PackageEntry))
-> Maybe PackageEntry
-> Maybe (IO (Maybe PackageEntry))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PackageEntry -> IO (Maybe PackageEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageEntry -> Maybe (IO (Maybe PackageEntry)))
-> Maybe PackageEntry -> Maybe (IO (Maybe PackageEntry))
forall a b. (a -> b) -> a -> b
$ PackageEntry -> Maybe PackageEntry
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 (FilePath -> PackageName
mkPackageName FilePath
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 -> FilePath -> GenericPackageDescription
forall a. HasCallStack => FilePath -> a
error (FilePath -> GenericPackageDescription)
-> FilePath -> GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't read cabal file "
                                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
fileName
          Maybe Version
_ -> Maybe (IO (Maybe PackageEntry))
forall a. Maybe a
Nothing
        [FilePath]
_ -> Maybe (IO (Maybe PackageEntry))
forall a. Maybe a
Nothing

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

  EntryContent
_ -> Maybe (IO (Maybe PackageEntry))
forall a. Maybe a
Nothing

  where
    fileName :: FilePath
fileName = Entry -> FilePath
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
_
     | FilePath -> Bool
isPreferredVersions FilePath
entrypath
    -> [Dependency] -> Maybe [Dependency]
forall a. a -> Maybe a
Just [Dependency]
prefs
    where
      entrypath :: FilePath
entrypath = Entry -> FilePath
Tar.entryPath Entry
entry
      prefs :: [Dependency]
prefs     = ByteString -> [Dependency]
parsePreferredVersions ByteString
content
  EntryContent
_ -> Maybe [Dependency]
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 :: FilePath
preferredVersions = FilePath
"preferred-versions"

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

-- | Parse `preferred-versions` file, ignoring any parse failures.
--
-- To obtain parse errors, use 'parsePreferredVersionsWarnings'.
parsePreferredVersions :: ByteString -> [Dependency]
parsePreferredVersions :: ByteString -> [Dependency]
parsePreferredVersions = [Either PreferredVersionsParseError Dependency] -> [Dependency]
forall a b. [Either a b] -> [b]
rights ([Either PreferredVersionsParseError Dependency] -> [Dependency])
-> (ByteString -> [Either PreferredVersionsParseError Dependency])
-> ByteString
-> [Dependency]
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 -> FilePath
preferredVersionsParsecError :: String
    -- ^ Parser error to show to a user.
    , PreferredVersionsParseError -> FilePath
preferredVersionsOriginalDependency :: String
    -- ^ Original input that produced the parser error.
    }
  deriving ((forall x.
 PreferredVersionsParseError -> Rep PreferredVersionsParseError x)
-> (forall x.
    Rep PreferredVersionsParseError x -> PreferredVersionsParseError)
-> Generic PreferredVersionsParseError
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]
(Int -> ReadS PreferredVersionsParseError)
-> ReadS [PreferredVersionsParseError]
-> ReadPrec PreferredVersionsParseError
-> ReadPrec [PreferredVersionsParseError]
-> Read 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 -> FilePath -> FilePath
[PreferredVersionsParseError] -> FilePath -> FilePath
PreferredVersionsParseError -> FilePath
(Int -> PreferredVersionsParseError -> FilePath -> FilePath)
-> (PreferredVersionsParseError -> FilePath)
-> ([PreferredVersionsParseError] -> FilePath -> FilePath)
-> Show PreferredVersionsParseError
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [PreferredVersionsParseError] -> FilePath -> FilePath
$cshowList :: [PreferredVersionsParseError] -> FilePath -> FilePath
show :: PreferredVersionsParseError -> FilePath
$cshow :: PreferredVersionsParseError -> FilePath
showsPrec :: Int -> PreferredVersionsParseError -> FilePath -> FilePath
$cshowsPrec :: Int -> PreferredVersionsParseError -> FilePath -> FilePath
Show, PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
(PreferredVersionsParseError
 -> PreferredVersionsParseError -> Bool)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Bool)
-> Eq PreferredVersionsParseError
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
Eq PreferredVersionsParseError
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Ordering)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Bool)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Bool)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Bool)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Bool)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> PreferredVersionsParseError)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> PreferredVersionsParseError)
-> Ord 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
$cp1Ord :: Eq PreferredVersionsParseError
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 =
  (FilePath -> Either PreferredVersionsParseError Dependency)
-> [FilePath] -> [Either PreferredVersionsParseError Dependency]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either PreferredVersionsParseError Dependency
parsePreference
  ([FilePath] -> [Either PreferredVersionsParseError Dependency])
-> (ByteString -> [FilePath])
-> ByteString
-> [Either PreferredVersionsParseError Dependency]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"--")
  ([FilePath] -> [FilePath])
-> (ByteString -> [FilePath]) -> ByteString -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines
  (FilePath -> [FilePath])
-> (ByteString -> FilePath) -> ByteString -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
fromUTF8LBS
    where
      parsePreference :: String -> Either PreferredVersionsParseError Dependency
      parsePreference :: FilePath -> Either PreferredVersionsParseError Dependency
parsePreference FilePath
s = case FilePath -> Either FilePath Dependency
forall a. Parsec a => FilePath -> Either FilePath a
eitherParsec FilePath
s of
          Left FilePath
err -> PreferredVersionsParseError
-> Either PreferredVersionsParseError Dependency
forall a b. a -> Either a b
Left (PreferredVersionsParseError
 -> Either PreferredVersionsParseError Dependency)
-> PreferredVersionsParseError
-> Either PreferredVersionsParseError Dependency
forall a b. (a -> b) -> a -> b
$ PreferredVersionsParseError :: FilePath -> FilePath -> PreferredVersionsParseError
PreferredVersionsParseError
              { preferredVersionsParsecError :: FilePath
preferredVersionsParsecError = FilePath
err
              , preferredVersionsOriginalDependency :: FilePath
preferredVersionsOriginalDependency = FilePath
s
              }
          Right Dependency
dep -> Dependency -> Either PreferredVersionsParseError Dependency
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 :: [IO a] -> IO [a]
lazySequence = IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [a] -> IO [a]) -> ([IO a] -> IO [a]) -> [IO a] -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO a] -> IO [a]
forall a. [IO a] -> IO [a]
go
  where
    go :: [IO a] -> IO [a]
go []     = [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (IO a
x:[IO a]
xs) = do a
x'  <- IO a
x
                   [a]
xs' <- [IO a] -> IO [a]
forall a. [IO a] -> IO [a]
lazySequence [IO a]
xs
                   [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x' a -> [a] -> [a]
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 :: (k -> IO (v, Maybe k)) -> k -> IO [(k, v)]
lazyUnfold k -> IO (v, Maybe k)
step = Maybe k -> IO [(k, v)]
goLazy (Maybe k -> IO [(k, v)]) -> (k -> Maybe k) -> k -> IO [(k, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Maybe k
forall a. a -> Maybe a
Just
  where
    goLazy :: Maybe k -> IO [(k, v)]
goLazy Maybe k
s = IO [(k, v)] -> IO [(k, v)]
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  = [(k, v)] -> IO [(k, v)]
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'
        [(k, v)] -> IO [(k, v)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((k
k,v
v)(k, v) -> [(k, v)] -> [(k, 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 -> FilePath
indexFile (RepoIndex RepoContext
_ctxt Repo
repo) = Repo -> FilePath
indexBaseName Repo
repo FilePath -> FilePath -> FilePath
<.> FilePath
"tar"
indexFile (SandboxIndex FilePath
index)   = FilePath
index

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

timestampFile :: Index -> FilePath
timestampFile :: Index -> FilePath
timestampFile (RepoIndex RepoContext
_ctxt Repo
repo) = Repo -> FilePath
indexBaseName Repo
repo FilePath -> FilePath -> FilePath
<.> FilePath
"timestamp"
timestampFile (SandboxIndex FilePath
index)   = FilePath
index FilePath -> FilePath -> FilePath
`replaceExtension` FilePath
"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 FilePath
_)   = Bool
False


updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index = do
    Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Updating index cache file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Index -> FilePath
cacheFile Index
index FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" ...")
    Verbosity
-> Index
-> ([IndexCacheEntry] -> IO ())
-> ([NoIndexCacheEntry] -> IO ())
-> IO ()
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 ((IndexCacheEntry -> Timestamp) -> [IndexCacheEntry] -> [Timestamp]
forall a b. (a -> b) -> [a] -> [b]
map IndexCacheEntry -> Timestamp
cacheEntryTimestamp [IndexCacheEntry]
entries)
            cache :: Cache
cache = Cache :: Timestamp -> [IndexCacheEntry] -> Cache
Cache { cacheHeadTs :: Timestamp
cacheHeadTs  = Timestamp
maxTs
                          , cacheEntries :: [IndexCacheEntry]
cacheEntries = [IndexCacheEntry]
entries
                          }
        Index -> Cache -> IO ()
writeIndexCache Index
index Cache
cache
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Index cache updated to index-state "
                        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Timestamp -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (Cache -> Timestamp
cacheHeadTs Cache
cache))

    callbackNoIndex :: [NoIndexCacheEntry] -> IO ()
callbackNoIndex [NoIndexCacheEntry]
entries = do
        Verbosity -> Index -> NoIndexCache -> IO ()
writeNoIndexCache Verbosity
verbosity Index
index (NoIndexCache -> IO ()) -> NoIndexCache -> IO ()
forall a b. (a -> b) -> a -> b
$ [NoIndexCacheEntry] -> NoIndexCache
NoIndexCache [NoIndexCacheEntry]
entries
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"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 :: 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
-> Repo
-> (forall (down :: * -> *). Repository down -> IO a)
-> IO a
RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo ((forall (down :: * -> *). Repository down -> IO a) -> IO a)
-> (forall (down :: * -> *). Repository down -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Repository down
repoSecure ->
      Repository down -> (IndexCallbacks -> IO a) -> IO a
forall (down :: * -> *) a.
Repository down -> (IndexCallbacks -> IO a) -> IO a
Sec.withIndex Repository down
repoSecure ((IndexCallbacks -> IO a) -> IO a)
-> (IndexCallbacks -> IO a) -> IO a
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 <- (DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry))
-> DirectoryEntry -> IO [(DirectoryEntry, Some IndexEntry)]
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 IndexEntry a -> Maybe (IndexFile a)
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)     -> [IndexCacheEntry] -> [IndexCacheEntry]
forall a. NFData a => a -> a
force
              [PackageId -> BlockNo -> Timestamp -> IndexCacheEntry
CachePackageId PackageId
pkgId BlockNo
blockNo Timestamp
timestamp]
          Just (Sec.IndexPkgPrefs PackageName
_pkgName)  -> [IndexCacheEntry] -> [IndexCacheEntry]
forall a. NFData a => a -> a
force
              [ Dependency -> BlockNo -> Timestamp -> IndexCacheEntry
CachePreference Dependency
dep BlockNo
blockNo Timestamp
timestamp
              | Dependency
dep <- ByteString -> [Dependency]
parsePreferredVersions (IndexEntry a -> ByteString
forall dec. IndexEntry dec -> ByteString
Sec.indexEntryContent IndexEntry a
sie)
              ]
      where
        blockNo :: BlockNo
blockNo = DirectoryEntry -> BlockNo
Sec.directoryEntryBlockNo DirectoryEntry
dirEntry
        timestamp :: Timestamp
timestamp = Timestamp -> Maybe Timestamp -> Timestamp
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Timestamp
forall a. HasCallStack => FilePath -> a
error FilePath
"withIndexEntries: invalid timestamp") (Maybe Timestamp -> Timestamp) -> Maybe Timestamp -> Timestamp
forall a b. (a -> b) -> a -> b
$
                              FileSize -> Maybe Timestamp
epochTimeToTimestamp (FileSize -> Maybe Timestamp) -> FileSize -> Maybe Timestamp
forall a b. (a -> b) -> a -> b
$ IndexEntry a -> FileSize
forall dec. IndexEntry dec -> FileSize
Sec.indexEntryTime IndexEntry a
sie

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

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

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

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

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

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

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

    stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
sfx [a]
str = ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
sfx) ([a] -> [a]
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
        | FilePath
filename FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Entry -> FilePath
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 (GenericPackageDescription -> NoIndexCacheEntry)
-> Maybe GenericPackageDescription -> Maybe NoIndexCacheEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\GenericPackageDescription
gpd -> GenericPackageDescription -> ByteString -> NoIndexCacheEntry
CacheGPD GenericPackageDescription
gpd ByteString
bs) (Maybe GenericPackageDescription -> Maybe NoIndexCacheEntry)
-> Maybe GenericPackageDescription -> Maybe NoIndexCacheEntry
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
bs
      where
        filename :: FilePath
filename =  PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgId FilePath -> FilePath -> FilePath
FilePath.Posix.</> PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgId) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".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
    FilePath -> IOMode -> (Handle -> IO a) -> IO a
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile (Index -> FilePath
indexFile Index
index) IOMode
ReadMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      ByteString
bs          <- ByteString -> ByteString
maybeDecompress (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle -> IO ByteString
BS.hGetContents Handle
h
      [Maybe PackageOrDep]
pkgsOrPrefs <- [IO (Maybe PackageOrDep)] -> IO [Maybe PackageOrDep]
forall a. [IO a] -> IO [a]
lazySequence ([IO (Maybe PackageOrDep)] -> IO [Maybe PackageOrDep])
-> [IO (Maybe PackageOrDep)] -> IO [Maybe PackageOrDep]
forall a b. (a -> b) -> a -> b
$ Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex Verbosity
verbosity ByteString
bs
      [IndexCacheEntry] -> IO a
callback ([IndexCacheEntry] -> IO a) -> [IndexCacheEntry] -> IO a
forall a b. (a -> b) -> a -> b
$ (PackageOrDep -> IndexCacheEntry)
-> [PackageOrDep] -> [IndexCacheEntry]
forall a b. (a -> b) -> [a] -> [b]
map PackageOrDep -> IndexCacheEntry
toCache ([Maybe PackageOrDep] -> [PackageOrDep]
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
_ FilePath
_ 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 :: 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) <- Verbosity
-> (PackageEntry -> pkg)
-> NoIndexCache
-> IO (PackageIndex pkg, [Dependency])
forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> NoIndexCache
-> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg NoIndexCache
cache0
        (PackageIndex pkg, [Dependency], IndexStateInfo)
-> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
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 <- FilePath -> IOMode -> IO Handle
openFile (Index -> FilePath
indexFile Index
index) IOMode
ReadMode
        let (Cache
cache,IndexStateInfo
isi) = RepoIndexState -> Cache -> (Cache, IndexStateInfo)
filterCache RepoIndexState
idxState Cache
cache0
        (PackageIndex pkg
pkgs,[Dependency]
deps) <- Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO (PackageIndex pkg, [Dependency])
forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
indexHnd Cache
cache
        (PackageIndex pkg, [Dependency], IndexStateInfo)
-> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
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 :: Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache
cache = do
     ([pkg]
pkgs, [Dependency]
prefs) <- Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO ([pkg], [Dependency])
forall pkg.
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO ([pkg], [Dependency])
packageListFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache
cache
     PackageIndex pkg
pkgIndex <- PackageIndex pkg -> IO (PackageIndex pkg)
forall a. a -> IO a
evaluate (PackageIndex pkg -> IO (PackageIndex pkg))
-> PackageIndex pkg -> IO (PackageIndex pkg)
forall a b. (a -> b) -> a -> b
$ [pkg] -> PackageIndex pkg
forall pkg. Package pkg => [pkg] -> PackageIndex pkg
PackageIndex.fromList [pkg]
pkgs
     (PackageIndex pkg, [Dependency])
-> IO (PackageIndex pkg, [Dependency])
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 :: 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 <- PackageIndex pkg -> IO (PackageIndex pkg)
forall a. a -> IO a
evaluate (PackageIndex pkg -> IO (PackageIndex pkg))
-> PackageIndex pkg -> IO (PackageIndex pkg)
forall a b. (a -> b) -> a -> b
$ [pkg] -> PackageIndex pkg
forall pkg. Package pkg => [pkg] -> PackageIndex pkg
PackageIndex.fromList [pkg]
pkgs
    (PackageIndex pkg, [Dependency])
-> IO (PackageIndex pkg, [Dependency])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex pkg
pkgIndex, [Dependency]
prefs)
  where
    packageListFromNoIndexCache :: ([pkg], [Dependency])
    packageListFromNoIndexCache :: ([pkg], [Dependency])
packageListFromNoIndexCache = (NoIndexCacheEntry
 -> ([pkg], [Dependency]) -> ([pkg], [Dependency]))
-> ([pkg], [Dependency])
-> [NoIndexCacheEntry]
-> ([pkg], [Dependency])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])
go ([pkg], [Dependency])
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 (PackageDescription -> PackageId)
-> PackageDescription -> PackageId
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) pkg -> [pkg] -> [pkg]
forall a. a -> [a] -> [a]
: [pkg]
pkgs, [Dependency]
prefs)
    go (NoIndexCachePreference [Dependency]
deps) ([pkg]
pkgs, [Dependency]
prefs) =
        ([pkg]
pkgs, [Dependency]
deps [Dependency] -> [Dependency] -> [Dependency]
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 :: 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 Map PackageId pkg
forall a. Monoid a => a
mempty [] Map PackageName Dependency
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 [] = ([pkg], [Dependency]) -> IO ([pkg], [Dependency])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageId pkg -> [pkg]
forall k a. Map k a -> [a]
Map.elems Map PackageId pkg
srcpkgs [pkg] -> [pkg] -> [pkg]
forall a. [a] -> [a] -> [a]
++ [pkg]
btrs, Map PackageName Dependency -> [Dependency]
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) <- IO (GenericPackageDescription, ByteString)
-> IO (GenericPackageDescription, ByteString)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (GenericPackageDescription, ByteString)
 -> IO (GenericPackageDescription, ByteString))
-> IO (GenericPackageDescription, ByteString)
-> IO (GenericPackageDescription, ByteString)
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
        (GenericPackageDescription, ByteString)
-> IO (GenericPackageDescription, ByteString)
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 (PackageId -> pkg -> Map PackageId pkg -> Map PackageId pkg
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.
      FilePath
path <- (ByteString -> FilePath) -> IO ByteString -> IO FilePath
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> FilePath
byteStringToFilePath (IO ByteString -> IO FilePath)
-> (BlockNo -> IO ByteString) -> BlockNo -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNo -> IO ByteString
getEntryContent (BlockNo -> IO FilePath) -> BlockNo -> IO FilePath
forall a b. (a -> b) -> a -> b
$ BlockNo
blockno
      GenericPackageDescription
pkg  <- do let err :: FilePath
err = FilePath
"Error reading package index from cache."
                 FilePath
file <- Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindAddSourcePackageDesc Verbosity
verbosity FilePath
path FilePath
err
                 Verbosity -> FilePath -> IO GenericPackageDescription
PackageDesc.Parse.readGenericPackageDescription Verbosity
normal FilePath
file
      let srcpkg :: pkg
srcpkg = PackageEntry -> pkg
mkPkg (BuildTreeRefType
-> PackageId
-> GenericPackageDescription
-> FilePath
-> BlockNo
-> PackageEntry
BuildTreeRef BuildTreeRefType
refType (GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg) GenericPackageDescription
pkg FilePath
path BlockNo
blockno)
      Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum Map PackageId pkg
srcpkgs (pkg
srcpkgpkg -> [pkg] -> [pkg]
forall 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 (PackageName
-> Dependency
-> Map PackageName Dependency
-> Map PackageName Dependency
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 -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
        Tar.OtherEntryType TypeCode
typecode ByteString
content FileSize
_size
          | TypeCode -> Bool
Tar.isBuildTreeRefTypeCode TypeCode
typecode
          -> ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
        EntryContent
_ -> FilePath -> IO ByteString
forall a. FilePath -> IO a
interror FilePath
"unexpected tar entry type"

    readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription
    readPackageDescription :: PackageId -> ByteString -> IO GenericPackageDescription
readPackageDescription PackageId
pkgid ByteString
content =
      case ([PWarning],
 Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
forall a b. (a, b) -> b
snd (([PWarning],
  Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
 -> Either
      (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
-> Either
     (Maybe Version, NonEmpty PError) GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a.
ParseResult a
-> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
PackageDesc.Parse.runParseResult (ParseResult GenericPackageDescription
 -> ([PWarning],
     Either (Maybe Version, NonEmpty PError) GenericPackageDescription))
-> ParseResult GenericPackageDescription
-> ([PWarning],
    Either (Maybe Version, NonEmpty PError) GenericPackageDescription)
forall a b. (a -> b) -> a -> b
$ ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription (ByteString -> ParseResult GenericPackageDescription)
-> ByteString -> ParseResult GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
content of
        Right GenericPackageDescription
gpd                                           -> GenericPackageDescription -> IO GenericPackageDescription
forall (m :: * -> *) a. Monad m => a -> m a
return GenericPackageDescription
gpd
        Left (Just Version
specVer, NonEmpty PError
_) | Version
specVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
2,Int
2] -> GenericPackageDescription -> IO GenericPackageDescription
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> GenericPackageDescription
dummyPackageDescription Version
specVer)
        Left (Maybe Version, NonEmpty PError)
_                                              -> FilePath -> IO GenericPackageDescription
forall a. FilePath -> IO a
interror FilePath
"failed to parse .cabal file"
      where
        dummyPackageDescription :: Version -> GenericPackageDescription
        dummyPackageDescription :: Version -> GenericPackageDescription
dummyPackageDescription Version
specVer = GenericPackageDescription :: PackageDescription
-> Maybe Version
-> [PackageFlag]
-> Maybe (CondTree ConfVar [Dependency] Library)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] ForeignLib)]
-> [(UnqualComponentName,
     CondTree ConfVar [Dependency] Executable)]
-> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-> GenericPackageDescription
GenericPackageDescription
            { packageDescription :: PackageDescription
packageDescription = PackageDescription
emptyPackageDescription
                                   { package :: PackageId
package     = PackageId
pkgid
                                   , synopsis :: ShortText
synopsis    = ShortText
dummySynopsis
                                   }
            , gpdScannedVersion :: Maybe Version
gpdScannedVersion = Version -> Maybe Version
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      = Maybe (CondTree ConfVar [Dependency] Library)
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 :: FilePath -> IO a
interror FilePath
msg = Verbosity -> FilePath -> IO a
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"internal error when reading package index: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg
                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"The package index or index cache is probably "
                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"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 FilePath Cache
cacheOrFail <- Index -> IO (Either FilePath Cache)
readIndexCache' Index
index
    case Either FilePath Cache
cacheOrFail of
      Left FilePath
msg -> do
          Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ FilePath
"Parsing the index cache failed (", FilePath
msg, FilePath
"). "
              , FilePath
"Trying to regenerate the index cache..."
              ]

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

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

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

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

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

      -- we don't hash cons local repository cache, they are hopefully small
      Right NoIndexCache
res -> NoIndexCache -> IO NoIndexCache
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 FilePath Cache)
readIndexCache' Index
index
  | Index -> Bool
is01Index Index
index = FilePath -> IO (Either FilePath Cache)
forall a.
(Binary a, Structured a) =>
FilePath -> IO (Either FilePath a)
structuredDecodeFileOrFail (Index -> FilePath
cacheFile Index
index)
  | Bool
otherwise       = (ByteString -> Either FilePath Cache)
-> IO ByteString -> IO (Either FilePath Cache)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Cache -> Either FilePath Cache
forall a b. b -> Either a b
Right (Cache -> Either FilePath Cache)
-> (ByteString -> Cache) -> ByteString -> Either FilePath Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ByteString -> Cache
read00IndexCache) (IO ByteString -> IO (Either FilePath Cache))
-> IO ByteString -> IO (Either FilePath Cache)
forall a b. (a -> b) -> a -> b
$
                      FilePath -> IO ByteString
BSS.readFile (Index -> FilePath
cacheFile Index
index)

readNoIndexCache' :: Index -> IO (Either String NoIndexCache)
readNoIndexCache' :: Index -> IO (Either FilePath NoIndexCache)
readNoIndexCache' Index
index = FilePath -> IO (Either FilePath NoIndexCache)
forall a.
(Binary a, Structured a) =>
FilePath -> IO (Either FilePath a)
structuredDecodeFileOrFail (Index -> FilePath
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 = FilePath -> Cache -> IO ()
forall a. (Binary a, Structured a) => FilePath -> a -> IO ()
structuredEncodeFile (Index -> FilePath
cacheFile Index
index) Cache
cache
  | Bool
otherwise       = FilePath -> FilePath -> IO ()
writeFile (Index -> FilePath
cacheFile Index
index) (Cache -> FilePath
show00IndexCache Cache
cache)

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

-- | Write the 'IndexState' to the filesystem
writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
writeIndexTimestamp Index
index RepoIndexState
st
  = FilePath -> FilePath -> IO ()
writeFile (Index -> FilePath
timestampFile Index
index) (RepoIndexState -> FilePath
forall a. Pretty a => a -> FilePath
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) -> Timestamp -> IO Timestamp
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
        Timestamp -> IO Timestamp
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
  = (FilePath -> Maybe RepoIndexState)
-> IO FilePath -> IO (Maybe RepoIndexState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe RepoIndexState
forall a. Parsec a => FilePath -> Maybe a
simpleParsec (FilePath -> IO FilePath
readFile (Index -> FilePath
timestampFile Index
index))
        IO (Maybe RepoIndexState)
-> (IOException -> IO (Maybe RepoIndexState))
-> IO (Maybe RepoIndexState)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e ->
            if IOException -> Bool
isDoesNotExistError IOException
e
                then Maybe RepoIndexState -> IO (Maybe RepoIndexState)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RepoIndexState
forall a. Maybe a
Nothing
                else do
                   Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Warning: could not read current index timestamp: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall e. Exception e => e -> FilePath
displayException IOException
e
                   Maybe RepoIndexState -> IO (Maybe RepoIndexState)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RepoIndexState
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 Map PackageName PackageName
forall a. Monoid a => a
mempty Map Version Version
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 IndexCacheEntry -> [IndexCacheEntry] -> [IndexCacheEntry]
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') = PackageName
-> Map PackageName PackageName
-> (PackageName, Map PackageName PackageName)
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') = Version -> Map Version Version -> (Version, Map Version Version)
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 IndexCacheEntry -> [IndexCacheEntry] -> [IndexCacheEntry]
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 :: k -> Map k k -> (k, Map k k)
mapIntern k
k Map k k
m = (k, Map k k) -> (k -> (k, Map k k)) -> Maybe k -> (k, Map k k)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (k
k,k -> k -> Map k k -> Map 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)) (k -> Map k k -> Maybe k
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 -> FilePath -> FilePath
[Cache] -> FilePath -> FilePath
Cache -> FilePath
(Int -> Cache -> FilePath -> FilePath)
-> (Cache -> FilePath)
-> ([Cache] -> FilePath -> FilePath)
-> Show Cache
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Cache] -> FilePath -> FilePath
$cshowList :: [Cache] -> FilePath -> FilePath
show :: Cache -> FilePath
$cshow :: Cache -> FilePath
showsPrec :: Int -> Cache -> FilePath -> FilePath
$cshowsPrec :: Int -> Cache -> FilePath -> FilePath
Show, (forall x. Cache -> Rep Cache x)
-> (forall x. Rep Cache x -> Cache) -> Generic Cache
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 = [IndexCacheEntry] -> ()
forall a. NFData a => a -> ()
rnf ([IndexCacheEntry] -> ())
-> (Cache -> [IndexCacheEntry]) -> Cache -> ()
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 -> FilePath -> FilePath
[NoIndexCache] -> FilePath -> FilePath
NoIndexCache -> FilePath
(Int -> NoIndexCache -> FilePath -> FilePath)
-> (NoIndexCache -> FilePath)
-> ([NoIndexCache] -> FilePath -> FilePath)
-> Show NoIndexCache
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [NoIndexCache] -> FilePath -> FilePath
$cshowList :: [NoIndexCache] -> FilePath -> FilePath
show :: NoIndexCache -> FilePath
$cshow :: NoIndexCache -> FilePath
showsPrec :: Int -> NoIndexCache -> FilePath -> FilePath
$cshowsPrec :: Int -> NoIndexCache -> FilePath -> FilePath
Show, (forall x. NoIndexCache -> Rep NoIndexCache x)
-> (forall x. Rep NoIndexCache x -> NoIndexCache)
-> Generic NoIndexCache
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 = [NoIndexCacheEntry] -> ()
forall a. NFData a => a -> ()
rnf ([NoIndexCacheEntry] -> ())
-> (NoIndexCache -> [NoIndexCacheEntry]) -> NoIndexCache -> ()
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
(IndexCacheEntry -> IndexCacheEntry -> Bool)
-> (IndexCacheEntry -> IndexCacheEntry -> Bool)
-> Eq IndexCacheEntry
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 -> FilePath -> FilePath
[IndexCacheEntry] -> FilePath -> FilePath
IndexCacheEntry -> FilePath
(Int -> IndexCacheEntry -> FilePath -> FilePath)
-> (IndexCacheEntry -> FilePath)
-> ([IndexCacheEntry] -> FilePath -> FilePath)
-> Show IndexCacheEntry
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [IndexCacheEntry] -> FilePath -> FilePath
$cshowList :: [IndexCacheEntry] -> FilePath -> FilePath
show :: IndexCacheEntry -> FilePath
$cshow :: IndexCacheEntry -> FilePath
showsPrec :: Int -> IndexCacheEntry -> FilePath -> FilePath
$cshowsPrec :: Int -> IndexCacheEntry -> FilePath -> FilePath
Show,(forall x. IndexCacheEntry -> Rep IndexCacheEntry x)
-> (forall x. Rep IndexCacheEntry x -> IndexCacheEntry)
-> Generic IndexCacheEntry
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
(NoIndexCacheEntry -> NoIndexCacheEntry -> Bool)
-> (NoIndexCacheEntry -> NoIndexCacheEntry -> Bool)
-> Eq NoIndexCacheEntry
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 -> FilePath -> FilePath
[NoIndexCacheEntry] -> FilePath -> FilePath
NoIndexCacheEntry -> FilePath
(Int -> NoIndexCacheEntry -> FilePath -> FilePath)
-> (NoIndexCacheEntry -> FilePath)
-> ([NoIndexCacheEntry] -> FilePath -> FilePath)
-> Show NoIndexCacheEntry
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [NoIndexCacheEntry] -> FilePath -> FilePath
$cshowList :: [NoIndexCacheEntry] -> FilePath -> FilePath
show :: NoIndexCacheEntry -> FilePath
$cshow :: NoIndexCacheEntry -> FilePath
showsPrec :: Int -> NoIndexCacheEntry -> FilePath -> FilePath
$cshowsPrec :: Int -> NoIndexCacheEntry -> FilePath -> FilePath
Show,(forall x. NoIndexCacheEntry -> Rep NoIndexCacheEntry x)
-> (forall x. Rep NoIndexCacheEntry x -> NoIndexCacheEntry)
-> Generic NoIndexCacheEntry
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
_) = PackageId -> ()
forall a. NFData a => a -> ()
rnf PackageId
pkgid
    rnf (CachePreference Dependency
dep BlockNo
_ Timestamp
_) = Dependency -> ()
forall a. NFData a => a -> ()
rnf Dependency
dep
    rnf (CacheBuildTreeRef BuildTreeRefType
_ BlockNo
_) = ()

instance NFData NoIndexCacheEntry where
    rnf :: NoIndexCacheEntry -> ()
rnf (CacheGPD GenericPackageDescription
gpd ByteString
bs) = GenericPackageDescription -> ()
forall a. NFData a => a -> ()
rnf GenericPackageDescription
gpd () -> () -> ()
`seq` ByteString -> ()
forall a. NFData a => a -> ()
rnf ByteString
bs
    rnf (NoIndexCachePreference [Dependency]
dep) = [Dependency] -> ()
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
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
0 :: Word8)
        ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
bs
    put (NoIndexCachePreference [Dependency]
dep) = do
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8
1 :: Word8)
        [Dependency] -> Put
forall t. Binary t => t -> Put
put [Dependency]
dep

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

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

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

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

-- legacy 00-index.cache format
read00IndexCache :: BSS.ByteString -> Cache
read00IndexCache :: ByteString -> Cache
read00IndexCache ByteString
bs = Cache :: Timestamp -> [IndexCacheEntry] -> Cache
Cache
  { cacheHeadTs :: Timestamp
cacheHeadTs  = Timestamp
nullTimestamp
  , cacheEntries :: [IndexCacheEntry]
cacheEntries = (ByteString -> Maybe IndexCacheEntry)
-> [ByteString] -> [IndexCacheEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry ([ByteString] -> [IndexCacheEntry])
-> [ByteString] -> [IndexCacheEntry]
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 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> ByteString
BSS.pack FilePath
packageKey Bool -> Bool -> Bool
&& ByteString
sep ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> ByteString
BSS.pack FilePath
blocknoKey ->
      case (ByteString -> Maybe PackageName
parseName ByteString
pkgnamestr, ByteString -> [Int] -> Maybe Version
parseVer ByteString
pkgverstr [],
            ByteString -> Maybe BlockNo
forall a. Num a => ByteString -> Maybe a
parseBlockNo ByteString
blocknostr) of
        (Just PackageName
pkgname, Just Version
pkgver, Just BlockNo
blockno)
          -> IndexCacheEntry -> Maybe IndexCacheEntry
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)
_ -> Maybe IndexCacheEntry
forall a. Maybe a
Nothing
    [ByteString
key, ByteString
typecodestr, ByteString
blocknostr] | ByteString
key ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> ByteString
BSS.pack FilePath
buildTreeRefKey ->
      case (ByteString -> Maybe BuildTreeRefType
parseRefType ByteString
typecodestr, ByteString -> Maybe BlockNo
forall a. Num a => ByteString -> Maybe a
parseBlockNo ByteString
blocknostr) of
        (Just BuildTreeRefType
refType, Just BlockNo
blockno)
          -> IndexCacheEntry -> Maybe IndexCacheEntry
forall a. a -> Maybe a
Just (BuildTreeRefType -> BlockNo -> IndexCacheEntry
CacheBuildTreeRef BuildTreeRefType
refType BlockNo
blockno)
        (Maybe BuildTreeRefType, Maybe BlockNo)
_ -> Maybe IndexCacheEntry
forall a. Maybe a
Nothing

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

    [ByteString]
_  -> Maybe IndexCacheEntry
forall a. Maybe a
Nothing
  where
    parseName :: ByteString -> Maybe PackageName
parseName ByteString
str
      | (TypeCode -> Bool) -> ByteString -> Bool
BSS.all (\TypeCode
c -> TypeCode -> Bool
isAlphaNum TypeCode
c Bool -> Bool -> Bool
|| TypeCode
c TypeCode -> TypeCode -> Bool
forall a. Eq a => a -> a -> Bool
== TypeCode
'-') ByteString
str
                  = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just (FilePath -> PackageName
mkPackageName (ByteString -> FilePath
BSS.unpack ByteString
str))
      | Bool
otherwise = Maybe PackageName
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        -> Maybe Version
forall a. Maybe a
Nothing
        Just (Int
v, ByteString
str') -> case ByteString -> Maybe (TypeCode, ByteString)
BSS.uncons ByteString
str' of
          Just (TypeCode
'.', ByteString
str'') -> ByteString -> [Int] -> Maybe Version
parseVer ByteString
str'' (Int
vInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
vs)
          Just (TypeCode, ByteString)
_            -> Maybe Version
forall a. Maybe a
Nothing
          Maybe (TypeCode, ByteString)
Nothing           -> Version -> Maybe Version
forall a. a -> Maybe a
Just ([Int] -> Version
mkVersion ([Int] -> [Int]
forall a. [a] -> [a]
reverse (Int
vInt -> [Int] -> [Int]
forall 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 -> a -> Maybe a
forall a. a -> Maybe a
Just (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
blockno)
        Maybe (Int, ByteString)
_                      -> Maybe a
forall a. Maybe a
Nothing

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

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

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