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

-- |
-- 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 Distribution.Client.Compat.Prelude
import 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 Distribution.Client.IndexUtils.ActiveRepos
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils.Timestamp
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types
import Distribution.Parsec (simpleParsecBS)
import Distribution.Verbosity

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

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

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

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

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

-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
getInstalledPackages
  :: Verbosity
  -> Compiler
  -> PackageDBStackCWD
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: Verbosity
-> Compiler
-> PackageDBStackCWD
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
comp PackageDBStackCWD
packageDbs ProgramDb
progdb =
  Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD ('Dir CWD))
-> PackageDBStackX (SymbolicPath CWD ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
forall from.
Verbosity
-> Compiler
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
Configure.getInstalledPackages Verbosity
verbosity' Compiler
comp Maybe (SymbolicPath CWD ('Dir CWD))
forall a. Maybe a
Nothing (PackageDBStackCWD
-> PackageDBStackX (SymbolicPath CWD ('Dir PkgDB))
coercePackageDBStack PackageDBStackCWD
packageDbs) ProgramDb
progdb
  where
    verbosity' :: Verbosity
verbosity' = Verbosity -> Verbosity
lessVerbose Verbosity
verbosity

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

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

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

-- | 'IndexStateInfo' contains meta-information about the resulting
-- filtered 'Cache' 'after applying 'filterCache' according to a
-- requested 'IndexState'.
data IndexStateInfo = IndexStateInfo
  { IndexStateInfo -> Timestamp
isiMaxTime :: !Timestamp
  -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current
  -- filtered view of the cache.
  --
  -- The following property holds
  --
  -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)
  , IndexStateInfo -> Timestamp
isiHeadTime :: !Timestamp
  -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest
  -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to
  -- 'isiMaxTime'.
  }

emptyStateInfo :: IndexStateInfo
emptyStateInfo :: IndexStateInfo
emptyStateInfo = Timestamp -> Timestamp -> IndexStateInfo
IndexStateInfo Timestamp
NoTimestamp Timestamp
NoTimestamp

-- | 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
isiMaxTime :: Timestamp
isiHeadTime :: Timestamp
isiMaxTime :: Timestamp
isiHeadTime :: Timestamp
..})
  where
    isiMaxTime :: Timestamp
isiMaxTime = Cache -> Timestamp
cacheHeadTs Cache
cache
    isiHeadTime :: Timestamp
isiHeadTime = Cache -> Timestamp
cacheHeadTs Cache
cache
filterCache (IndexStateTime Timestamp
ts0) Cache
cache0 = (Cache
cache, IndexStateInfo{Timestamp
isiMaxTime :: Timestamp
isiHeadTime :: Timestamp
isiHeadTime :: Timestamp
isiMaxTime :: Timestamp
..})
  where
    cache :: Cache
cache = Cache{cacheEntries :: [IndexCacheEntry]
cacheEntries = [IndexCacheEntry]
ents, cacheHeadTs :: Timestamp
cacheHeadTs = Timestamp
isiMaxTime}
    isiHeadTime :: Timestamp
isiHeadTime = Cache -> Timestamp
cacheHeadTs Cache
cache0
    isiMaxTime :: Timestamp
isiMaxTime = [Timestamp] -> Timestamp
maximumTimestamp ((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 a. [a] -> 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 -> [Char] -> IO ()
warn (Verbosity -> Verbosity
verboseUnmarkOutput Verbosity
verbosity) ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char]
"No remote package servers have been specified. Usually "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"you would have one specified in the config file."
      (SourcePackageDb, TotalIndexState, ActiveRepos)
-> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( 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 -> [Char]
describeState RepoIndexState
IndexStateHead = [Char]
"most recent state"
      describeState (IndexStateTime Timestamp
time) = [Char]
"historical state as of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Timestamp -> [Char]
forall a. Pretty a => a -> [Char]
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 -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"Reading available packages of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"...")

    RepoIndexState
idxState <- case Maybe TotalIndexState
mb_idxState of
      Just TotalIndexState
totalIdxState -> do
        let idxState :: RepoIndexState
idxState = RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState RepoName
rname TotalIndexState
totalIdxState
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"Using "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoIndexState -> [Char]
describeState RepoIndexState
idxState
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" as explicitly requested (via command line / project configuration)"
        RepoIndexState -> IO RepoIndexState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
idxState
      Maybe TotalIndexState
Nothing -> do
        Maybe RepoIndexState
mb_idxState' <- Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp Verbosity
verbosity (RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
r)
        case Maybe RepoIndexState
mb_idxState' of
          Maybe RepoIndexState
Nothing -> do
            Verbosity -> [Char] -> IO ()
info Verbosity
verbosity [Char]
"Using most recent state (could not read timestamp file)"
            RepoIndexState -> IO RepoIndexState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RepoIndexState
IndexStateHead
          Just RepoIndexState
idxState -> do
            Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
              [Char]
"Using "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoIndexState -> [Char]
describeState RepoIndexState
idxState
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" specified from most recent cabal update"
            RepoIndexState -> IO RepoIndexState
forall a. a -> IO a
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 -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
"index-state ignored for file+noindex repositories"
        RepoRemote{} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char]
"index-state ignored for old-format (remote repository '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"')")
        RepoSecure{} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

    case RepoIndexState
idxState' of
      RepoIndexState
IndexStateHead -> do
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"index-state(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Timestamp -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi))
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      IndexStateTime Timestamp
ts0 ->
        -- isiMaxTime is the latest timestamp in the filtered view returned by
        -- `readRepoIndex` above. It is always true that isiMaxTime is less or
        -- equal to a requested IndexStateTime. When `isiMaxTime isi /= ts0` (or
        -- equivalently `isiMaxTime isi < ts0`) it means that ts0 falls between
        -- two timestamps in the index.
        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
$
          let commonMsg :: [Char]
commonMsg =
                [Char]
"There is no index-state for '"
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' exactly at the requested timestamp ("
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Timestamp -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Timestamp
ts0
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"). "
           in if Maybe UTCTime -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe UTCTime -> Bool) -> Maybe UTCTime -> Bool
forall a b. (a -> b) -> a -> b
$ Timestamp -> Maybe UTCTime
timestampToUTCTime (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi)
                then
                  Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
commonMsg
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Also, there are no index-states before the one requested, so the repository '"
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName RepoName
rname
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' will be empty."
                else
                  Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char]
commonMsg
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Falling back to the previous index-state that exists: "
                      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Timestamp -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi)
    RepoData -> IO RepoData
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      RepoData
        { rdRepoName :: RepoName
rdRepoName = RepoName
rname
        , rdTimeStamp :: Timestamp
rdTimeStamp = IndexStateInfo -> Timestamp
isiMaxTime IndexStateInfo
isi
        , rdIndex :: PackageIndex UnresolvedSourcePackage
rdIndex = PackageIndex UnresolvedSourcePackage
pis
        , rdPreferences :: [Dependency]
rdPreferences = [Dependency]
deps
        }

  let activeRepos :: ActiveRepos
      activeRepos :: ActiveRepos
activeRepos = 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 [Char] [(RepoData, CombineStrategy)]
forall a.
ActiveRepos
-> (a -> RepoName) -> [a] -> Either [Char] [(a, CombineStrategy)]
organizeByRepos ActiveRepos
activeRepos RepoData -> RepoName
rdRepoName [RepoData]
pkgss of
    Right [(RepoData, CombineStrategy)]
x -> [(RepoData, CombineStrategy)] -> IO [(RepoData, CombineStrategy)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(RepoData, CombineStrategy)]
x
    Left [Char]
err -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity [Char]
err IO ()
-> IO [(RepoData, CombineStrategy)]
-> IO [(RepoData, CombineStrategy)]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(RepoData, CombineStrategy)] -> IO [(RepoData, CombineStrategy)]
forall a. a -> IO a
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
NoTimestamp
            ]

  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 b a. (b -> a -> b) -> b -> [a] -> b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( SourcePackageDb
        { packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex = PackageIndex UnresolvedSourcePackage
pkgs
        , packagePreferences :: Map PackageName VersionRange
packagePreferences = Map PackageName VersionRange
prefs
        }
    , TotalIndexState
totalIndexState
    , ActiveRepos
activeRepos'
    )

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

-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
--
-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
readRepoIndex
  :: Verbosity
  -> RepoContext
  -> Repo
  -> RepoIndexState
  -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
readRepoIndex :: Verbosity
-> RepoContext
-> Repo
-> RepoIndexState
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
readRepoIndex Verbosity
verbosity RepoContext
repoCtxt Repo
repo RepoIndexState
idxState =
  IO
  (PackageIndex UnresolvedSourcePackage, [Dependency],
   IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
handleNotFound (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
    ret :: (PackageIndex UnresolvedSourcePackage, [Dependency],
 IndexStateInfo)
ret@(PackageIndex UnresolvedSourcePackage
_, [Dependency]
_, IndexStateInfo
isi) <-
      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
    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
$ do
      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
      IndexStateInfo -> IO ()
dieIfRequestedIdxIsNewer IndexStateInfo
isi
    (PackageIndex UnresolvedSourcePackage, [Dependency],
 IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex UnresolvedSourcePackage, [Dependency],
 IndexStateInfo)
ret
  where
    mkAvailablePackage :: PackageEntry -> UnresolvedSourcePackage
mkAvailablePackage PackageEntry
pkgEntry =
      SourcePackage
        { srcpkgPackageId :: PackageId
srcpkgPackageId = PackageId
pkgid
        , srcpkgDescription :: GenericPackageDescription
srcpkgDescription = GenericPackageDescription
pkgdesc
        , srcpkgSource :: PackageLocation (Maybe [Char])
srcpkgSource = case PackageEntry
pkgEntry of
            NormalPackage PackageId
_ GenericPackageDescription
_ ByteString
_ BlockNo
_ -> Repo -> PackageId -> Maybe [Char] -> PackageLocation (Maybe [Char])
forall local. Repo -> PackageId -> local -> PackageLocation local
RepoTarballPackage Repo
repo PackageId
pkgid Maybe [Char]
forall a. Maybe a
Nothing
            BuildTreeRef BuildTreeRefType
_ PackageId
_ GenericPackageDescription
_ [Char]
path BlockNo
_ -> [Char] -> PackageLocation (Maybe [Char])
forall local. [Char] -> PackageLocation local
LocalUnpackedPackage [Char]
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{[Char]
RemoteRepo
repoLocalDir :: Repo -> [Char]
repoRemote :: RemoteRepo
repoLocalDir :: [Char]
repoRemote :: Repo -> RemoteRepo
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ CabalInstallException -> [Char]
exceptionMessageCabalInstall (CabalInstallException -> [Char])
-> CabalInstallException -> [Char]
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> CabalInstallException
MissingPackageList RemoteRepo
repoRemote
            RepoSecure{[Char]
RemoteRepo
repoLocalDir :: Repo -> [Char]
repoRemote :: Repo -> RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ CabalInstallException -> [Char]
exceptionMessageCabalInstall (CabalInstallException -> [Char])
-> CabalInstallException -> [Char]
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> CabalInstallException
MissingPackageList RemoteRepo
repoRemote
            RepoLocalNoIndex LocalRepo
local [Char]
_ ->
              Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                [Char]
"Error during construction of file+noindex "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local)
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" repository index: "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
e
          (PackageIndex UnresolvedSourcePackage, [Dependency],
 IndexStateInfo)
-> IO
     (PackageIndex UnresolvedSourcePackage, [Dependency],
      IndexStateInfo)
forall a. a -> IO a
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
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{[Char]
RemoteRepo
repoLocalDir :: Repo -> [Char]
repoRemote :: Repo -> RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> Double -> [Char]
forall {a}. RealFrac a => RemoteRepo -> a -> [Char]
warnOutdatedPackageList RemoteRepo
repoRemote Double
dt
        RepoSecure{[Char]
RemoteRepo
repoLocalDir :: Repo -> [Char]
repoRemote :: Repo -> RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: [Char]
..} -> Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> Double -> [Char]
forall {a}. RealFrac a => RemoteRepo -> a -> [Char]
warnOutdatedPackageList RemoteRepo
repoRemote Double
dt
        RepoLocalNoIndex{} -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    dieIfRequestedIdxIsNewer :: IndexStateInfo -> IO ()
dieIfRequestedIdxIsNewer IndexStateInfo
isi =
      let latestTime :: Timestamp
latestTime = IndexStateInfo -> Timestamp
isiHeadTime IndexStateInfo
isi
       in case RepoIndexState
idxState of
            IndexStateTime Timestamp
t -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Timestamp
t Timestamp -> Timestamp -> Bool
forall a. Ord a => a -> a -> Bool
> Timestamp
latestTime) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Repo
repo of
              RepoSecure{[Char]
RemoteRepo
repoLocalDir :: Repo -> [Char]
repoRemote :: Repo -> RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: [Char]
..} ->
                Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> Timestamp -> Timestamp -> CabalInstallException
UnusableIndexState RemoteRepo
repoRemote Timestamp
latestTime Timestamp
t
              RepoRemote{} -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              RepoLocalNoIndex{} -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            RepoIndexState
IndexStateHead -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

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

-- | It is not necessary to call this, as the cache will be updated when the
-- index is read normally. However you can do the work earlier if you like.
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache Verbosity
verbosity Index
index =
  Index -> IO () -> IO ()
whenCacheOutOfDate Index
index (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 <- [Char] -> IO Bool
doesFileExist ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Index -> [Char]
cacheFile Index
index
  if Bool -> Bool
not Bool
exists
    then IO ()
action
    else
      if Index -> Bool
localNoIndex Index
index
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: don't update cache for file+noindex repositories
        else do
          ModTime
indexTime <- [Char] -> IO ModTime
getModTime ([Char] -> IO ModTime) -> [Char] -> IO ModTime
forall a b. (a -> b) -> a -> b
$ Index -> [Char]
indexFile Index
index
          ModTime
cacheTime <- [Char] -> IO ModTime
getModTime ([Char] -> IO ModTime) -> [Char] -> IO ModTime
forall a b. (a -> b) -> a -> b
$ Index -> [Char]
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
$c== :: BuildTreeRefType -> BuildTreeRefType -> Bool
== :: BuildTreeRefType -> BuildTreeRefType -> Bool
$c/= :: BuildTreeRefType -> BuildTreeRefType -> Bool
/= :: BuildTreeRefType -> BuildTreeRefType -> Bool
Eq, Int -> BuildTreeRefType -> [Char] -> [Char]
[BuildTreeRefType] -> [Char] -> [Char]
BuildTreeRefType -> [Char]
(Int -> BuildTreeRefType -> [Char] -> [Char])
-> (BuildTreeRefType -> [Char])
-> ([BuildTreeRefType] -> [Char] -> [Char])
-> Show BuildTreeRefType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> BuildTreeRefType -> [Char] -> [Char]
showsPrec :: Int -> BuildTreeRefType -> [Char] -> [Char]
$cshow :: BuildTreeRefType -> [Char]
show :: BuildTreeRefType -> [Char]
$cshowList :: [BuildTreeRefType] -> [Char] -> [Char]
showList :: [BuildTreeRefType] -> [Char] -> [Char]
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
$cfrom :: forall x. BuildTreeRefType -> Rep BuildTreeRefType x
from :: forall x. BuildTreeRefType -> Rep BuildTreeRefType x
$cto :: forall x. Rep BuildTreeRefType x -> BuildTreeRefType
to :: forall x. Rep BuildTreeRefType x -> BuildTreeRefType
Generic)

instance Binary BuildTreeRefType
instance Structured BuildTreeRefType

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

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

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

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

-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
data PackageOrDep = Pkg PackageEntry | Dep Dependency

-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files
--
-- We read the index using 'Tar.read', which gives us a lazily constructed
-- 'TarEntries'. We translate it to a list of entries using  'tarEntriesList',
-- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a
-- function over this to translate it to a list of IO actions returning
-- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of
-- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.
parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
parsePackageIndex Verbosity
verbosity = ((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 a. a -> [a]
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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PackageEntry -> PackageOrDep)
-> Maybe PackageEntry -> Maybe PackageOrDep
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe PackageOrDep -> IO (Maybe PackageOrDep)
forall a. a -> IO a
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 :: forall e. Show e => Entries e -> [(BlockNo, Entry)]
tarEntriesList = BlockNo -> GenEntries TarPath LinkTarget e -> [(BlockNo, Entry)]
forall {a}.
Show a =>
BlockNo -> GenEntries TarPath LinkTarget a -> [(BlockNo, Entry)]
go BlockNo
0
  where
    go :: BlockNo -> GenEntries TarPath LinkTarget a -> [(BlockNo, Entry)]
go !BlockNo
_ GenEntries TarPath LinkTarget a
Tar.Done = []
    go !BlockNo
_ (Tar.Fail a
e) = [Char] -> [(BlockNo, Entry)]
forall a. HasCallStack => [Char] -> a
error ([Char]
"tarEntriesList: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
e)
    go !BlockNo
n (Tar.Next Entry
e GenEntries TarPath LinkTarget a
es') = (BlockNo
n, Entry
e) (BlockNo, Entry) -> [(BlockNo, Entry)] -> [(BlockNo, Entry)]
forall a. a -> [a] -> [a]
: BlockNo -> GenEntries TarPath LinkTarget a -> [(BlockNo, Entry)]
go (Entry -> BlockNo -> BlockNo
Tar.nextEntryOffset Entry
e BlockNo
n) GenEntries TarPath LinkTarget 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 -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent Entry
entry of
  Tar.NormalFile ByteString
content FileSize
_
    | [Char] -> [Char]
takeExtension [Char]
fileName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".cabal" ->
        case [Char] -> [[Char]]
splitDirectories ([Char] -> [Char]
normalise [Char]
fileName) of
          [[Char]
pkgname, [Char]
vers, [Char]
_] -> case [Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
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 a. a -> IO a
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 ([Char] -> PackageName
mkPackageName [Char]
pkgname) Version
ver
                parsed :: Maybe GenericPackageDescription
parsed = ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe (ByteString -> ByteString
BS.toStrict ByteString
content)
                descr :: GenericPackageDescription
descr = case Maybe GenericPackageDescription
parsed of
                  Just GenericPackageDescription
d -> GenericPackageDescription
d
                  Maybe GenericPackageDescription
Nothing ->
                    [Char] -> GenericPackageDescription
forall a. HasCallStack => [Char] -> a
error ([Char] -> GenericPackageDescription)
-> [Char] -> GenericPackageDescription
forall a b. (a -> b) -> a -> b
$
                      [Char]
"Couldn't read cabal file "
                        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
fileName
            Maybe Version
_ -> Maybe (IO (Maybe PackageEntry))
forall a. Maybe a
Nothing
          [[Char]]
_ -> Maybe (IO (Maybe PackageEntry))
forall a. Maybe a
Nothing
  Tar.OtherEntryType Char
typeCode ByteString
content FileSize
_
    | Char -> Bool
Tar.isBuildTreeRefTypeCode Char
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 :: [Char]
path = ByteString -> [Char]
byteStringToFilePath ByteString
content
          Bool
dirExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
path
          if Bool -> Bool
not Bool
dirExists
            then Maybe PackageEntry -> IO (Maybe PackageEntry)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageEntry
forall a. Maybe a
Nothing
            else do
              GenericPackageDescription
descr <- Verbosity -> [Char] -> [Char] -> IO GenericPackageDescription
tryReadAddSourcePackageDesc Verbosity
verbosity [Char]
path [Char]
"Error reading package index."
              Maybe PackageEntry -> IO (Maybe PackageEntry)
forall a. a -> IO a
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
-> [Char]
-> BlockNo
-> PackageEntry
BuildTreeRef
                  (Char -> BuildTreeRefType
refTypeFromTypeCode Char
typeCode)
                  (GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
descr)
                  GenericPackageDescription
descr
                  [Char]
path
                  BlockNo
blockNo
  GenEntryContent LinkTarget
_ -> Maybe (IO (Maybe PackageEntry))
forall a. Maybe a
Nothing
  where
    fileName :: [Char]
fileName = Entry -> [Char]
forall linkTarget. GenEntry TarPath linkTarget -> [Char]
Tar.entryPath Entry
entry

extractPrefs :: Tar.Entry -> Maybe [Dependency]
extractPrefs :: Entry -> Maybe [Dependency]
extractPrefs Entry
entry = case Entry -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent Entry
entry of
  Tar.NormalFile ByteString
content FileSize
_
    | [Char] -> Bool
isPreferredVersions [Char]
entrypath ->
        [Dependency] -> Maybe [Dependency]
forall a. a -> Maybe a
Just [Dependency]
prefs
    where
      entrypath :: [Char]
entrypath = Entry -> [Char]
forall linkTarget. GenEntry TarPath linkTarget -> [Char]
Tar.entryPath Entry
entry
      prefs :: [Dependency]
prefs = ByteString -> [Dependency]
parsePreferredVersions ByteString
content
  GenEntryContent LinkTarget
_ -> 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 :: [Char]
preferredVersions = [Char]
"preferred-versions"

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

-- | Parse `preferred-versions` file, ignoring any parse failures.
--
-- To obtain parse errors, use 'parsePreferredVersionsWarnings'.
parsePreferredVersions :: ByteString -> [Dependency]
parsePreferredVersions :: ByteString -> [Dependency]
parsePreferredVersions = [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 -> [Char]
preferredVersionsParsecError :: String
  -- ^ Parser error to show to a user.
  , PreferredVersionsParseError -> [Char]
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
$cfrom :: forall x.
PreferredVersionsParseError -> Rep PreferredVersionsParseError x
from :: forall x.
PreferredVersionsParseError -> Rep PreferredVersionsParseError x
$cto :: forall x.
Rep PreferredVersionsParseError x -> PreferredVersionsParseError
to :: forall x.
Rep PreferredVersionsParseError x -> PreferredVersionsParseError
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
$creadsPrec :: Int -> ReadS PreferredVersionsParseError
readsPrec :: Int -> ReadS PreferredVersionsParseError
$creadList :: ReadS [PreferredVersionsParseError]
readList :: ReadS [PreferredVersionsParseError]
$creadPrec :: ReadPrec PreferredVersionsParseError
readPrec :: ReadPrec PreferredVersionsParseError
$creadListPrec :: ReadPrec [PreferredVersionsParseError]
readListPrec :: ReadPrec [PreferredVersionsParseError]
Read, Int -> PreferredVersionsParseError -> [Char] -> [Char]
[PreferredVersionsParseError] -> [Char] -> [Char]
PreferredVersionsParseError -> [Char]
(Int -> PreferredVersionsParseError -> [Char] -> [Char])
-> (PreferredVersionsParseError -> [Char])
-> ([PreferredVersionsParseError] -> [Char] -> [Char])
-> Show PreferredVersionsParseError
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> PreferredVersionsParseError -> [Char] -> [Char]
showsPrec :: Int -> PreferredVersionsParseError -> [Char] -> [Char]
$cshow :: PreferredVersionsParseError -> [Char]
show :: PreferredVersionsParseError -> [Char]
$cshowList :: [PreferredVersionsParseError] -> [Char] -> [Char]
showList :: [PreferredVersionsParseError] -> [Char] -> [Char]
Show, PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
(PreferredVersionsParseError
 -> PreferredVersionsParseError -> Bool)
-> (PreferredVersionsParseError
    -> PreferredVersionsParseError -> Bool)
-> Eq PreferredVersionsParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
== :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$c/= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
/= :: 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
$ccompare :: PreferredVersionsParseError
-> PreferredVersionsParseError -> Ordering
compare :: PreferredVersionsParseError
-> PreferredVersionsParseError -> Ordering
$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
>= :: PreferredVersionsParseError -> PreferredVersionsParseError -> Bool
$cmax :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
max :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
$cmin :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
min :: PreferredVersionsParseError
-> PreferredVersionsParseError -> PreferredVersionsParseError
Ord)

-- | 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 =
  ([Char] -> Either PreferredVersionsParseError Dependency)
-> [[Char]] -> [Either PreferredVersionsParseError Dependency]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Either PreferredVersionsParseError Dependency
parsePreference
    ([[Char]] -> [Either PreferredVersionsParseError Dependency])
-> (ByteString -> [[Char]])
-> ByteString
-> [Either PreferredVersionsParseError Dependency]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"--")
    ([[Char]] -> [[Char]])
-> (ByteString -> [[Char]]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines
    ([Char] -> [[Char]])
-> (ByteString -> [Char]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
fromUTF8LBS
  where
    parsePreference :: String -> Either PreferredVersionsParseError Dependency
    parsePreference :: [Char] -> Either PreferredVersionsParseError Dependency
parsePreference [Char]
s = case [Char] -> Either [Char] Dependency
forall a. Parsec a => [Char] -> Either [Char] a
eitherParsec [Char]
s of
      Left [Char]
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
            { preferredVersionsParsecError :: [Char]
preferredVersionsParsecError = [Char]
err
            , preferredVersionsOriginalDependency :: [Char]
preferredVersionsOriginalDependency = [Char]
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 :: forall a. [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 a. 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 a. 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 :: forall k v. (k -> IO (v, Maybe k)) -> k -> IO [(k, v)]
lazyUnfold k -> IO (v, Maybe k)
step = Maybe k -> IO [(k, v)]
goLazy (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 a. a -> IO a
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 a. a -> IO a
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

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

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

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

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

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

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

-- | Read the index (for the purpose of building a cache)
--
-- The callback is provided with list of cache entries, which is guaranteed to
-- be lazily constructed. This list must ONLY be used in the scope of the
-- callback; when the callback is terminated the file handle to the index will
-- be closed and further attempts to read from the list will result in (pure)
-- I/O exceptions.
--
-- In the construction of the index for a secure repo we take advantage of the
-- index built by the @hackage-security@ library to avoid reading the @.tar@
-- file as much as possible (we need to read it only to extract preferred
-- versions). This helps performance, but is also required for correctness:
-- the new @01-index.tar.gz@ may have multiple versions of preferred-versions
-- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);
-- by reading the already-built cache from the security library we will be sure
-- to only read the latest versions of all files.
--
-- TODO: It would be nicer if we actually incrementally updated @cabal@'s
-- cache, rather than reconstruct it from zero on each update. However, this
-- would require a change in the cache format.
withIndexEntries
  :: Verbosity
  -> Index
  -> ([IndexCacheEntry] -> IO a)
  -> ([NoIndexCacheEntry] -> IO a)
  -> IO a
withIndexEntries :: forall a.
Verbosity
-> Index
-> ([IndexCacheEntry] -> IO a)
-> ([NoIndexCacheEntry] -> IO a)
-> IO a
withIndexEntries Verbosity
_ (RepoIndex RepoContext
repoCtxt repo :: Repo
repo@RepoSecure{}) [IndexCacheEntry] -> IO a
callback [NoIndexCacheEntry] -> IO a
_ =
  RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo ((forall {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
Throws InvalidPackageException =>
PackageId -> IO (Trusted ByteString)
Throws InvalidPackageException => PackageId -> IO (Trusted Targets)
(Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted Hash)
(Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted FileInfo)
DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry)
forall dec. IndexFile dec -> IO (Maybe (IndexEntry dec))
forall dec. DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec)
indexLookupEntry :: DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry)
indexLookupFile :: forall dec. IndexFile dec -> IO (Maybe (IndexEntry dec))
indexLookupFileEntry :: forall dec. DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec)
indexLookupCabal :: Throws InvalidPackageException =>
PackageId -> IO (Trusted ByteString)
indexLookupMetadata :: Throws InvalidPackageException => PackageId -> IO (Trusted Targets)
indexLookupFileInfo :: (Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted FileInfo)
indexLookupHash :: (Throws InvalidPackageException, Throws VerificationError) =>
PackageId -> IO (Trusted Hash)
indexDirectory :: Directory
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
..} -> 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 =
          FileSize -> Timestamp
epochTimeToTimestamp (FileSize -> Timestamp) -> FileSize -> 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 [Char]
localDir Bool
_) [Char]
_cacheDir)) [IndexCacheEntry] -> IO a
_ [NoIndexCacheEntry] -> IO a
callback = do
  [[Char]]
dirContents <- [Char] -> IO [[Char]]
listDirectory [Char]
localDir
  let contentSet :: Set [Char]
contentSet = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList [[Char]]
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 a b. (a -> b) -> IO a -> IO b
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
$ [[Char]]
-> ([Char] -> IO (Maybe NoIndexCacheEntry))
-> IO [Maybe NoIndexCacheEntry]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [[Char]]
dirContents (([Char] -> IO (Maybe NoIndexCacheEntry))
 -> IO [Maybe NoIndexCacheEntry])
-> ([Char] -> IO (Maybe NoIndexCacheEntry))
-> IO [Maybe NoIndexCacheEntry]
forall a b. (a -> b) -> a -> b
$ \[Char]
file -> do
    case [Char] -> Maybe PackageId
isTarGz [Char]
file of
      Maybe PackageId
Nothing
        | [Char] -> Bool
isPreferredVersions [Char]
file -> do
            ByteString
contents <- [Char] -> IO ByteString
BS.readFile ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
file)
            let versionPreferencesParsed :: [Either PreferredVersionsParseError Dependency]
versionPreferencesParsed = ByteString -> [Either PreferredVersionsParseError Dependency]
parsePreferredVersionsWarnings ByteString
contents
            let ([PreferredVersionsParseError]
warnings, [Dependency]
versionPreferences) = [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 a. [a] -> 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 -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                [Char]
"withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: "
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
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 -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"* \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreferredVersionsParseError -> [Char]
preferredVersionsOriginalDependency PreferredVersionsParseError
err
                Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Parser Error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PreferredVersionsParseError -> [Char]
preferredVersionsParsecError PreferredVersionsParseError
err
            Maybe NoIndexCacheEntry -> IO (Maybe NoIndexCacheEntry)
forall a. a -> IO a
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 ([Char] -> [Char]
takeFileName [Char]
file [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"noindex.cache" Bool -> Bool -> Bool
|| [Char]
".cabal" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [Char]
file) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
                [Char]
"Skipping " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
file
            Maybe NoIndexCacheEntry -> IO (Maybe NoIndexCacheEntry)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NoIndexCacheEntry
forall a. Maybe a
Nothing
      Just PackageId
pkgid | [Char]
cabalPath [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
contentSet -> do
        ByteString
contents <- [Char] -> IO ByteString
BSS.readFile ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
cabalPath)
        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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription -> ByteString -> NoIndexCacheEntry
CacheGPD GenericPackageDescription
gpd ByteString
contents)
        where
          cabalPath :: [Char]
cabalPath = PackageId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageId
pkgid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".cabal"
      Just PackageId
pkgId -> do
        -- check for the right named .cabal file in the compressed tarball
        ByteString
tarGz <- [Char] -> IO ByteString
BS.readFile ([Char]
localDir [Char] -> [Char] -> [Char]
</> [Char]
file)
        let tar :: ByteString
tar = ByteString -> ByteString
GZip.decompress ByteString
tarGz
            entries :: Entries FormatError
entries = ByteString -> Entries FormatError
Tar.read ByteString
tar

        case (Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry)
-> Maybe NoIndexCacheEntry
-> (FormatError -> Maybe NoIndexCacheEntry)
-> Entries FormatError
-> Maybe NoIndexCacheEntry
forall tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NoIndexCacheEntry -> Maybe NoIndexCacheEntry
forall a. a -> Maybe a
Just NoIndexCacheEntry
ce)
          Maybe NoIndexCacheEntry
Nothing -> Verbosity -> CabalInstallException -> IO (Maybe NoIndexCacheEntry)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO (Maybe NoIndexCacheEntry))
-> CabalInstallException -> IO (Maybe NoIndexCacheEntry)
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalInstallException
CannotReadCabalFile [Char]
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 -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Entries in file+noindex repository " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
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 -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackageId -> [Char]
forall a. Pretty a => a -> [Char]
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 a. [a] -> 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 -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Preferred versions in file+noindex repository " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RepoName -> [Char]
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 -> [Char] -> IO ()
info Verbosity
verbosity ([Char]
"* " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Dependency -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Dependency
pref)

  [NoIndexCacheEntry] -> IO a
callback [NoIndexCacheEntry]
entries
  where
    handler :: IOException -> IO a
    handler :: forall a. IOException -> IO a
handler IOException
e = Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a) -> CabalInstallException -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> IOException -> CabalInstallException
ErrorUpdatingIndex (RepoName -> [Char]
unRepoName RepoName
name) IOException
e

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

    stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
sfx [a]
str = ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> Maybe a -> Maybe b
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
      | [Char]
filename [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Entry -> [Char]
forall linkTarget. GenEntry TarPath linkTarget -> [Char]
Tar.entryPath Entry
entry
      , Tar.NormalFile ByteString
contents FileSize
_ <- Entry -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent Entry
entry =
          let bs :: ByteString
bs = ByteString -> ByteString
BS.toStrict ByteString
contents
           in ((GenericPackageDescription -> ByteString -> NoIndexCacheEntry
`CacheGPD` ByteString
bs) (GenericPackageDescription -> NoIndexCacheEntry)
-> Maybe GenericPackageDescription -> Maybe NoIndexCacheEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe ByteString
bs)
      where
        filename :: [Char]
filename = PackageId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow PackageId
pkgId [Char] -> [Char] -> [Char]
FilePath.</> PackageName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgId) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".cabal"
    readCabalEntry PackageId
_ Entry
_ Maybe NoIndexCacheEntry
x = Maybe NoIndexCacheEntry
x
withIndexEntries Verbosity
verbosity Index
index [IndexCacheEntry] -> IO a
callback [NoIndexCacheEntry] -> IO a
_ = do
  -- non-secure repositories
  [Char] -> IOMode -> (Handle -> IO a) -> IO a
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile (Index -> [Char]
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 a b. (a -> b) -> IO a -> IO b
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
NoTimestamp
    toCache (Pkg (BuildTreeRef BuildTreeRefType
refType PackageId
_ GenericPackageDescription
_ [Char]
_ BlockNo
blockNo)) = BuildTreeRefType -> BlockNo -> IndexCacheEntry
CacheBuildTreeRef BuildTreeRefType
refType BlockNo
blockNo
    toCache (Dep Dependency
d) = Dependency -> BlockNo -> Timestamp -> IndexCacheEntry
CachePreference Dependency
d BlockNo
0 Timestamp
NoTimestamp

-- | Read package data from a repository.
-- Throws IOException if any arise while accessing the index
-- (unless the repo is local+no-index) and dies if the cache
-- is corrupted and cannot be regenerated correctly.
readPackageIndexCacheFile
  :: Package pkg
  => Verbosity
  -> (PackageEntry -> pkg)
  -> Index
  -> RepoIndexState
  -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile :: forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Index
-> RepoIndexState
-> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile Verbosity
verbosity PackageEntry -> pkg
mkPkg Index
index RepoIndexState
idxState
  | Index -> Bool
localNoIndex Index
index = do
      NoIndexCache
cache0 <- Verbosity -> Index -> IO NoIndexCache
readNoIndexCache Verbosity
verbosity Index
index
      (PackageIndex pkg
pkgs, [Dependency]
prefs) <- 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex pkg
pkgs, [Dependency]
prefs, IndexStateInfo
emptyStateInfo)
  | Bool
otherwise = do
      (Cache
cache, IndexStateInfo
isi) <- Verbosity -> Index -> RepoIndexState -> IO (Cache, IndexStateInfo)
getIndexCache Verbosity
verbosity Index
index RepoIndexState
idxState
      Handle
indexHnd <- [Char] -> IOMode -> IO Handle
openFile (Index -> [Char]
indexFile Index
index) IOMode
ReadMode
      (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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIndex pkg
pkgs, [Dependency]
deps, IndexStateInfo
isi)

-- | Read 'Cache' and 'IndexStateInfo' from the repository index file.
-- Throws IOException if any arise (e.g. the index or its cache are missing).
-- Dies if the index cache is corrupted and cannot be regenerated correctly.
getIndexCache :: Verbosity -> Index -> RepoIndexState -> IO (Cache, IndexStateInfo)
getIndexCache :: Verbosity -> Index -> RepoIndexState -> IO (Cache, IndexStateInfo)
getIndexCache Verbosity
verbosity Index
index RepoIndexState
idxState =
  RepoIndexState -> Cache -> (Cache, IndexStateInfo)
filterCache RepoIndexState
idxState (Cache -> (Cache, IndexStateInfo))
-> IO Cache -> IO (Cache, IndexStateInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Index -> IO Cache
readIndexCache Verbosity
verbosity Index
index

packageIndexFromCache
  :: Package pkg
  => Verbosity
  -> (PackageEntry -> pkg)
  -> Handle
  -> Cache
  -> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache :: forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache
cache = do
  ([pkg]
pkgs, [Dependency]
prefs) <- 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageIndex pkg
pkgIndex, [Dependency]
prefs)

packageNoIndexFromCache
  :: forall pkg
   . Package pkg
  => Verbosity
  -> (PackageEntry -> pkg)
  -> NoIndexCache
  -> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache :: forall pkg.
Package pkg =>
Verbosity
-> (PackageEntry -> pkg)
-> NoIndexCache
-> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache Verbosity
_verbosity PackageEntry -> pkg
mkPkg NoIndexCache
cache = do
  let ([pkg]
pkgs, [Dependency]
prefs) = ([pkg], [Dependency])
packageListFromNoIndexCache
  PackageIndex pkg
pkgIndex <- 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 a. a -> IO a
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 a b. (a -> b -> b) -> b -> [a] -> b
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 :: forall pkg.
Verbosity
-> (PackageEntry -> pkg)
-> Handle
-> Cache
-> IO ([pkg], [Dependency])
packageListFromCache Verbosity
verbosity PackageEntry -> pkg
mkPkg Handle
hnd Cache{[IndexCacheEntry]
Timestamp
cacheHeadTs :: Cache -> Timestamp
cacheEntries :: Cache -> [IndexCacheEntry]
cacheHeadTs :: Timestamp
cacheEntries :: [IndexCacheEntry]
..} = 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 a. a -> IO a
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 a. a -> IO a
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.
      [Char]
path <- (ByteString -> [Char]) -> IO ByteString -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> [Char]
byteStringToFilePath (IO ByteString -> IO [Char])
-> (BlockNo -> IO ByteString) -> BlockNo -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNo -> IO ByteString
getEntryContent (BlockNo -> IO [Char]) -> BlockNo -> IO [Char]
forall a b. (a -> b) -> a -> b
$ BlockNo
blockno
      GenericPackageDescription
pkg <- do
        let err :: [Char]
err = [Char]
"Error reading package index from cache."
        Verbosity -> [Char] -> [Char] -> IO GenericPackageDescription
tryReadAddSourcePackageDesc Verbosity
verbosity [Char]
path [Char]
err
      let srcpkg :: pkg
srcpkg = PackageEntry -> pkg
mkPkg (BuildTreeRefType
-> PackageId
-> GenericPackageDescription
-> [Char]
-> BlockNo
-> PackageEntry
BuildTreeRef BuildTreeRefType
refType (GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg) GenericPackageDescription
pkg [Char]
path BlockNo
blockno)
      Map PackageId pkg
-> [pkg]
-> Map PackageName Dependency
-> [IndexCacheEntry]
-> IO ([pkg], [Dependency])
accum Map PackageId pkg
srcpkgs (pkg
srcpkg pkg -> [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 -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent Entry
entry of
        Tar.NormalFile ByteString
content FileSize
_size -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
        Tar.OtherEntryType Char
typecode ByteString
content FileSize
_size
          | Char -> Bool
Tar.isBuildTreeRefTypeCode Char
typecode ->
              ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
content
        GenEntryContent LinkTarget
_ -> [Char] -> IO ByteString
forall a. [Char] -> IO a
interror [Char]
"unexpected tar entry type"

    readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription
    readPackageDescription :: PackageId -> ByteString -> IO GenericPackageDescription
readPackageDescription PackageId
pkgid ByteString
content =
      case ([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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> GenericPackageDescription
dummyPackageDescription Version
specVer)
        Left (Maybe Version, NonEmpty PError)
_ -> [Char] -> IO GenericPackageDescription
forall a. [Char] -> IO a
interror [Char]
"failed to parse .cabal file"
      where
        dummyPackageDescription :: Version -> GenericPackageDescription
        dummyPackageDescription :: Version -> GenericPackageDescription
dummyPackageDescription Version
specVer =
          GenericPackageDescription
            { packageDescription :: PackageDescription
packageDescription =
                PackageDescription
emptyPackageDescription
                  { package = pkgid
                  , synopsis = 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 :: forall a. [Char] -> IO a
interror [Char]
msg =
      Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a) -> CabalInstallException -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> CabalInstallException
InternalError [Char]
msg

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

-- | Read a repository 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
-- 'dieWithException's if it fails again).
readIndexCache :: Verbosity -> Index -> IO Cache
readIndexCache :: Verbosity -> Index -> IO Cache
readIndexCache Verbosity
verbosity Index
index = do
  Either [Char] Cache
cacheOrFail <- Index -> IO (Either [Char] Cache)
readIndexCache' Index
index
  case Either [Char] Cache
cacheOrFail of
    Left [Char]
msg -> do
      Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [Char]
"Parsing the index cache failed ("
          , [Char]
msg
          , [Char]
"). "
          , [Char]
"Trying to regenerate the index cache..."
          ]

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

      ([Char] -> IO Cache)
-> (Cache -> IO Cache) -> Either [Char] Cache -> IO Cache
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> CabalInstallException -> IO Cache
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO Cache)
-> ([Char] -> CabalInstallException) -> [Char] -> IO Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CabalInstallException
CorruptedIndexCache) (Cache -> IO Cache
forall a. a -> IO a
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 [Char] Cache -> IO Cache)
-> IO (Either [Char] Cache) -> IO Cache
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Index -> IO (Either [Char] Cache)
readIndexCache' Index
index
    Right Cache
res -> Cache -> IO Cache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache -> Cache
hashConsCache Cache
res)

-- | Read a no-index repository cache from the filesystem
--
-- If a corrupted index cache is detected this function regenerates
-- the index cache and then reattempts to read the index once (and
-- 'dieWithException's if it fails again). Throws IOException if any arise.
readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
readNoIndexCache Verbosity
verbosity Index
index = do
  Either [Char] NoIndexCache
cacheOrFail <- Verbosity -> Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Verbosity
verbosity Index
index
  case Either [Char] NoIndexCache
cacheOrFail of
    Left [Char]
msg -> do
      Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [Char]
"Parsing the index cache for repo \""
          , RepoName -> [Char]
unRepoName (Repo -> RepoName
repoName Repo
repo)
          , [Char]
"\" failed ("
          , [Char]
msg
          , [Char]
"). "
          , [Char]
"Trying to regenerate the index cache..."
          ]

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

      ([Char] -> IO NoIndexCache)
-> (NoIndexCache -> IO NoIndexCache)
-> Either [Char] NoIndexCache
-> IO NoIndexCache
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> CabalInstallException -> IO NoIndexCache
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO NoIndexCache)
-> ([Char] -> CabalInstallException) -> [Char] -> IO NoIndexCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CabalInstallException
CorruptedIndexCache) NoIndexCache -> IO NoIndexCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] NoIndexCache -> IO NoIndexCache)
-> IO (Either [Char] NoIndexCache) -> IO NoIndexCache
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Verbosity
verbosity Index
index

    -- we don't hash cons local repository cache, they are hopefully small
    Right NoIndexCache
res -> NoIndexCache -> IO NoIndexCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NoIndexCache
res
  where
    RepoIndex RepoContext
_ctxt Repo
repo = Index
index

-- | Read the 'Index' cache from the filesystem. Throws IO exceptions
-- if any arise and returns Left on invalid input.
readIndexCache' :: Index -> IO (Either String Cache)
readIndexCache' :: Index -> IO (Either [Char] Cache)
readIndexCache' Index
index
  | Index -> Bool
is01Index Index
index =
      [Char] -> IO (Either [Char] Cache)
forall a.
(Binary a, Structured a) =>
[Char] -> IO (Either [Char] a)
structuredDecodeFileOrFail (Index -> [Char]
cacheFile Index
index)
  | Bool
otherwise =
      Cache -> Either [Char] Cache
forall a b. b -> Either a b
Right (Cache -> Either [Char] Cache)
-> (ByteString -> Cache) -> ByteString -> Either [Char] Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Cache
read00IndexCache (ByteString -> Either [Char] Cache)
-> IO ByteString -> IO (Either [Char] Cache)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
BSS.readFile (Index -> [Char]
cacheFile Index
index)

readNoIndexCache' :: Verbosity -> Index -> IO (Either String NoIndexCache)
readNoIndexCache' :: Verbosity -> Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Verbosity
verbosity Index
index = do
  Bool
exists <- [Char] -> IO Bool
doesFileExist (Index -> [Char]
cacheFile Index
index)
  if Bool
exists
    then [Char] -> IO (Either [Char] NoIndexCache)
forall a.
(Binary a, Structured a) =>
[Char] -> IO (Either [Char] a)
structuredDecodeFileOrFail (Index -> [Char]
cacheFile Index
index)
    else Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index IO ()
-> IO (Either [Char] NoIndexCache)
-> IO (Either [Char] NoIndexCache)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Verbosity -> Index -> IO (Either [Char] NoIndexCache)
readNoIndexCache' Verbosity
verbosity 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 = [Char] -> Cache -> IO ()
forall a. (Binary a, Structured a) => [Char] -> a -> IO ()
structuredEncodeFile (Index -> [Char]
cacheFile Index
index) Cache
cache
  | Bool
otherwise = [Char] -> [Char] -> IO ()
writeFile (Index -> [Char]
cacheFile Index
index) (Cache -> [Char]
show00IndexCache Cache
cache)

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

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

-- | Read out the "current" index timestamp, i.e., what
-- timestamp you would use to revert to this version.
--
-- Note: this is not the same as 'readIndexTimestamp'!
-- This resolves HEAD to the index's 'isiHeadTime', i.e.
-- the index latest known timestamp.
--
-- Return NoTimestamp if the index has never been updated.
currentIndexTimestamp :: Verbosity -> Index -> IO Timestamp
currentIndexTimestamp :: Verbosity -> Index -> IO Timestamp
currentIndexTimestamp Verbosity
verbosity Index
index = do
  Maybe RepoIndexState
mb_is <- Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp Verbosity
verbosity Index
index
  case Maybe RepoIndexState
mb_is of
    -- If the index timestamp file specifies an index state time, use that
    Just (IndexStateTime Timestamp
ts) ->
      Timestamp -> IO Timestamp
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Timestamp
ts
    -- Otherwise used the head time as stored in the index cache
    Maybe RepoIndexState
_otherwise ->
      ((Cache, IndexStateInfo) -> Timestamp)
-> IO (Cache, IndexStateInfo) -> IO Timestamp
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IndexStateInfo -> Timestamp
isiHeadTime (IndexStateInfo -> Timestamp)
-> ((Cache, IndexStateInfo) -> IndexStateInfo)
-> (Cache, IndexStateInfo)
-> Timestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cache, IndexStateInfo) -> IndexStateInfo
forall a b. (a, b) -> b
snd) (Verbosity -> Index -> RepoIndexState -> IO (Cache, IndexStateInfo)
getIndexCache Verbosity
verbosity Index
index RepoIndexState
IndexStateHead)
        IO Timestamp -> (IOException -> IO Timestamp) -> IO Timestamp
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e ->
          if IOException -> Bool
isDoesNotExistError IOException
e
            then Timestamp -> IO Timestamp
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Timestamp
NoTimestamp
            else IOException -> IO Timestamp
forall a. IOException -> IO a
ioError IOException
e

-- | Read the 'IndexState' from the filesystem
readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)
readIndexTimestamp Verbosity
verbosity Index
index =
  ([Char] -> Maybe RepoIndexState)
-> IO [Char] -> IO (Maybe RepoIndexState)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Maybe RepoIndexState
forall a. Parsec a => [Char] -> Maybe a
simpleParsec ([Char] -> IO [Char]
readFile (Index -> [Char]
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RepoIndexState
forall a. Maybe a
Nothing
        else do
          Verbosity -> [Char] -> IO ()
warn Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Warning: could not read current index timestamp: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e
          Maybe RepoIndexState -> IO (Maybe RepoIndexState)
forall a. a -> IO a
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 = go mempty mempty (cacheEntries cache0)}
  where
    -- TODO/NOTE:
    --
    -- If/when we redo the binary serialisation via e.g. CBOR and we
    -- are able to use incremental decoding, we may want to move the
    -- hash-consing into the incremental deserialisation, or
    -- 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 :: forall k. Ord k => 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 -> [Char] -> [Char]
[Cache] -> [Char] -> [Char]
Cache -> [Char]
(Int -> Cache -> [Char] -> [Char])
-> (Cache -> [Char]) -> ([Cache] -> [Char] -> [Char]) -> Show Cache
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Cache -> [Char] -> [Char]
showsPrec :: Int -> Cache -> [Char] -> [Char]
$cshow :: Cache -> [Char]
show :: Cache -> [Char]
$cshowList :: [Cache] -> [Char] -> [Char]
showList :: [Cache] -> [Char] -> [Char]
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
$cfrom :: forall x. Cache -> Rep Cache x
from :: forall x. Cache -> Rep Cache x
$cto :: forall x. Rep Cache x -> Cache
to :: forall x. Rep Cache x -> Cache
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 -> [Char] -> [Char]
[NoIndexCache] -> [Char] -> [Char]
NoIndexCache -> [Char]
(Int -> NoIndexCache -> [Char] -> [Char])
-> (NoIndexCache -> [Char])
-> ([NoIndexCache] -> [Char] -> [Char])
-> Show NoIndexCache
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> NoIndexCache -> [Char] -> [Char]
showsPrec :: Int -> NoIndexCache -> [Char] -> [Char]
$cshow :: NoIndexCache -> [Char]
show :: NoIndexCache -> [Char]
$cshowList :: [NoIndexCache] -> [Char] -> [Char]
showList :: [NoIndexCache] -> [Char] -> [Char]
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
$cfrom :: forall x. NoIndexCache -> Rep NoIndexCache x
from :: forall x. NoIndexCache -> Rep NoIndexCache x
$cto :: forall x. Rep NoIndexCache x -> NoIndexCache
to :: forall x. Rep NoIndexCache x -> NoIndexCache
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
$c== :: IndexCacheEntry -> IndexCacheEntry -> Bool
== :: IndexCacheEntry -> IndexCacheEntry -> Bool
$c/= :: IndexCacheEntry -> IndexCacheEntry -> Bool
/= :: IndexCacheEntry -> IndexCacheEntry -> Bool
Eq, Int -> IndexCacheEntry -> [Char] -> [Char]
[IndexCacheEntry] -> [Char] -> [Char]
IndexCacheEntry -> [Char]
(Int -> IndexCacheEntry -> [Char] -> [Char])
-> (IndexCacheEntry -> [Char])
-> ([IndexCacheEntry] -> [Char] -> [Char])
-> Show IndexCacheEntry
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> IndexCacheEntry -> [Char] -> [Char]
showsPrec :: Int -> IndexCacheEntry -> [Char] -> [Char]
$cshow :: IndexCacheEntry -> [Char]
show :: IndexCacheEntry -> [Char]
$cshowList :: [IndexCacheEntry] -> [Char] -> [Char]
showList :: [IndexCacheEntry] -> [Char] -> [Char]
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
$cfrom :: forall x. IndexCacheEntry -> Rep IndexCacheEntry x
from :: forall x. IndexCacheEntry -> Rep IndexCacheEntry x
$cto :: forall x. Rep IndexCacheEntry x -> IndexCacheEntry
to :: forall x. Rep IndexCacheEntry x -> IndexCacheEntry
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
$c== :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
== :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
$c/= :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
/= :: NoIndexCacheEntry -> NoIndexCacheEntry -> Bool
Eq, Int -> NoIndexCacheEntry -> [Char] -> [Char]
[NoIndexCacheEntry] -> [Char] -> [Char]
NoIndexCacheEntry -> [Char]
(Int -> NoIndexCacheEntry -> [Char] -> [Char])
-> (NoIndexCacheEntry -> [Char])
-> ([NoIndexCacheEntry] -> [Char] -> [Char])
-> Show NoIndexCacheEntry
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> NoIndexCacheEntry -> [Char] -> [Char]
showsPrec :: Int -> NoIndexCacheEntry -> [Char] -> [Char]
$cshow :: NoIndexCacheEntry -> [Char]
show :: NoIndexCacheEntry -> [Char]
$cshowList :: [NoIndexCacheEntry] -> [Char] -> [Char]
showList :: [NoIndexCacheEntry] -> [Char] -> [Char]
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
$cfrom :: forall x. NoIndexCacheEntry -> Rep NoIndexCacheEntry x
from :: forall x. NoIndexCacheEntry -> Rep NoIndexCacheEntry x
$cto :: forall x. Rep NoIndexCacheEntry x -> NoIndexCacheEntry
to :: forall x. Rep NoIndexCacheEntry x -> NoIndexCacheEntry
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 () -> () -> ()
forall a b. a -> b -> b
`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
NoTimestamp
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericPackageDescription -> ByteString -> NoIndexCacheEntry
CacheGPD GenericPackageDescription
gpd ByteString
bs)
          Maybe GenericPackageDescription
Nothing -> [Char] -> Get NoIndexCacheEntry
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Failed to parse GPD"
      Word8
1 -> do
        [Dependency] -> NoIndexCacheEntry
NoIndexCachePreference ([Dependency] -> NoIndexCacheEntry)
-> Get [Dependency] -> Get NoIndexCacheEntry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [Dependency]
forall t. Binary t => Get t
get
      Word8
_ -> [Char] -> Get NoIndexCacheEntry
forall a. [Char] -> Get a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"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 :: [Char]
packageKey = [Char]
"pkg:"
blocknoKey :: [Char]
blocknoKey = [Char]
"b#"
buildTreeRefKey :: [Char]
buildTreeRefKey = [Char]
"build-tree-ref:"
preferredVersionKey :: [Char]
preferredVersionKey = [Char]
"pref-ver:"

-- legacy 00-index.cache format
read00IndexCache :: BSS.ByteString -> Cache
read00IndexCache :: ByteString -> Cache
read00IndexCache ByteString
bs =
  Cache
    { cacheHeadTs :: Timestamp
cacheHeadTs = Timestamp
NoTimestamp
    , 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
== [Char] -> ByteString
BSS.pack [Char]
packageKey Bool -> Bool -> Bool
&& ByteString
sep ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> ByteString
BSS.pack [Char]
blocknoKey ->
          case ( ByteString -> Maybe PackageName
parseName ByteString
pkgnamestr
               , ByteString -> [Int] -> Maybe Version
parseVer ByteString
pkgverstr []
               , 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
NoTimestamp
                )
            (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
== [Char] -> ByteString
BSS.pack [Char]
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
== [Char] -> ByteString
BSS.pack [Char]
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 a. a -> Maybe a
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
NoTimestamp
    [ByteString]
_ -> Maybe IndexCacheEntry
forall a. Maybe a
Nothing
  where
    parseName :: ByteString -> Maybe PackageName
parseName ByteString
str
      | (Char -> Bool) -> ByteString -> Bool
BSS.all (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') ByteString
str =
          PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just ([Char] -> PackageName
mkPackageName (ByteString -> [Char]
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 (Char, ByteString)
BSS.uncons ByteString
str' of
          Just (Char
'.', ByteString
str'') -> ByteString -> [Int] -> Maybe Version
parseVer ByteString
str'' (Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
vs)
          Just (Char, ByteString)
_ -> Maybe Version
forall a. Maybe a
Nothing
          Maybe (Char, ByteString)
Nothing -> Version -> Maybe Version
forall a. a -> Maybe a
Just ([Int] -> Version
mkVersion ([Int] -> [Int]
forall a. [a] -> [a]
reverse (Int
v Int -> [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 (Char, ByteString)
BSS.uncons ByteString
str of
        Just (Char
typeCode, ByteString
remainder)
          | ByteString -> Bool
BSS.null ByteString
remainder Bool -> Bool -> Bool
&& Char -> Bool
Tar.isBuildTreeRefTypeCode Char
typeCode ->
              BuildTreeRefType -> Maybe BuildTreeRefType
forall a. a -> Maybe a
Just (Char -> BuildTreeRefType
refTypeFromTypeCode Char
typeCode)
        Maybe (Char, ByteString)
_ -> Maybe BuildTreeRefType
forall a. Maybe a
Nothing

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

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