{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Pantry.Hackage
  ( updateHackageIndex
  , forceUpdateHackageIndex
  , DidUpdateOccur (..)
  , RequireHackageIndex (..)
  , hackageIndexTarballL
  , getHackageTarball
  , getHackageTarballKey
  , getHackageCabalFile
  , getHackagePackageVersions
  , getHackagePackageVersionRevisions
  , getHackageTypoCorrections
  , UsePreferredVersions (..)
  , HackageTarballResult(..)
  ) where

import           Conduit
                   ( ZipSink (..), (.|), getZipSink, runConduit, sinkLazy
                   , sinkList, sourceHandle, takeC, takeCE
                   )
import           Data.Aeson
                   ( FromJSON (..), Value (..),  (.:), eitherDecode'
                   , withObject
                   )
import           Data.Conduit.Tar
                   ( FileInfo (..), FileType (..), untar )
import qualified Data.List.NonEmpty as NE
import           Data.Text.Metrics (damerauLevenshtein)
import           Data.Text.Unsafe ( unsafeTail )
import           Data.Time ( getCurrentTime )
import           Database.Persist.Sql ( SqlBackend )
import           Distribution.PackageDescription ( GenericPackageDescription )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.Text
import           Distribution.Types.Version (versionNumbers)
import           Distribution.Types.VersionRange (withinRange)
import qualified Hackage.Security.Client as HS
import qualified Hackage.Security.Client.Repository.Cache as HS
import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS
import qualified Hackage.Security.Client.Repository.Remote as HS
import qualified Hackage.Security.Util.Path as HS
import qualified Hackage.Security.Util.Pretty as HS
import           Network.URI ( parseURI )
import           Pantry.Archive ( getArchive )
import           Pantry.Casa ( casaLookupKey )
import qualified Pantry.SHA256 as SHA256
import           Pantry.Storage
                   ( CachedTree (..), TreeId, BlobId, clearHackageRevisions
                   , countHackageCabals, getBlobKey, loadBlobById, loadBlobBySHA
                   , loadHackagePackageVersion, loadHackagePackageVersions
                   , loadHackageTarballInfo, loadHackageTree, loadHackageTreeKey
                   , loadLatestCacheUpdate, loadPreferredVersion
                   , sinkHackagePackageNames, storeBlob, storeCacheUpdate
                   , storeHackageRevision, storeHackageTarballInfo
                   , storeHackageTree, storePreferredVersion, storeTree
                   , unCachedTree, withStorage
                   )
import           Pantry.Tree ( rawParseGPD )
import           Pantry.Types
                   ( ArchiveLocation (..), BlobKey (..), BuildFile (..)
                   , CabalFileInfo (..), FileSize (..), FuzzyResults (..)
                   , HackageSecurityConfig (..), HasPantryConfig (..)
                   , Mismatch (..), Package (..), PackageCabal (..)
                   , PackageIdentifier (..), PackageIdentifierRevision (..)
                   , PackageIndexConfig (..), PackageName, PantryConfig (..)
                   , PantryException (..), RawArchive (..)
                   , RawPackageLocationImmutable (..), RawPackageMetadata (..)
                   , Revision, SHA256, Storage (..), TreeEntry (..), TreeKey
                   , Version, cabalFileName, packageNameString, parsePackageName
                   , unSafeFilePath
                   )
import           Path
                   ( Abs, Dir, File, Path, Rel, (</>), parseRelDir, parseRelFile
                   , toFilePath
                   )
import           RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import qualified RIO.Map as Map
import           RIO.Process ( HasProcessContext )
import qualified RIO.Text as T
#if !MIN_VERSION_rio(0,1,16)
-- Now provided by RIO from the rio package. Resolvers before lts-15.16

-- (GHC 8.8.3) had rio < 0.1.16.

import           System.IO ( SeekMode (..) )
#endif

hackageRelDir :: Path Rel Dir
hackageRelDir :: Path Rel Dir
hackageRelDir = (SomeException -> Path Rel Dir)
-> (Path Rel Dir -> Path Rel Dir)
-> Either SomeException (Path Rel Dir)
-> Path Rel Dir
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Path Rel Dir
forall e a. Exception e => e -> a
impureThrow Path Rel Dir -> Path Rel Dir
forall a. a -> a
id (Either SomeException (Path Rel Dir) -> Path Rel Dir)
-> Either SomeException (Path Rel Dir) -> Path Rel Dir
forall a b. (a -> b) -> a -> b
$ FilePath -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir FilePath
"hackage"

hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirL :: forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirL = (PantryConfig -> Const r PantryConfig) -> env -> Const r env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const r PantryConfig) -> env -> Const r env)
-> ((Path Abs Dir -> Const r (Path Abs Dir))
    -> PantryConfig -> Const r PantryConfig)
-> (Path Abs Dir -> Const r (Path Abs Dir))
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Path Abs Dir)
-> SimpleGetter PantryConfig (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to ((Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
hackageRelDir) (Path Abs Dir -> Path Abs Dir)
-> (PantryConfig -> Path Abs Dir) -> PantryConfig -> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PantryConfig -> Path Abs Dir
pcRootDir)

-- | The name of the tar file that is part of the local cache of the package

-- index is determined by this package's use of 'HS.cabalCacheLayout' as the

-- layout of the local cache.

indexRelFile :: Path Rel File
indexRelFile :: Path Rel File
indexRelFile = (SomeException -> Path Rel File)
-> (Path Rel File -> Path Rel File)
-> Either SomeException (Path Rel File)
-> Path Rel File
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Path Rel File
forall e a. Exception e => e -> a
impureThrow Path Rel File -> Path Rel File
forall a. a -> a
id (Either SomeException (Path Rel File) -> Path Rel File)
-> Either SomeException (Path Rel File) -> Path Rel File
forall a b. (a -> b) -> a -> b
$ FilePath -> Either SomeException (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
indexTar
 where
  indexTar' :: CachePath
indexTar' = CacheLayout -> CachePath
HS.cacheLayoutIndexTar CacheLayout
HS.cabalCacheLayout
  indexTar :: FilePath
indexTar = Path Unrooted -> FilePath
HS.toUnrootedFilePath (Path Unrooted -> FilePath) -> Path Unrooted -> FilePath
forall a b. (a -> b) -> a -> b
$ CachePath -> Path Unrooted
forall root. Path root -> Path Unrooted
HS.unrootPath CachePath
indexTar'

-- | Where does pantry download its 01-index.tar file from Hackage?

--

-- @since 0.1.0.0

hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL :: forall env. HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL = Getting r env (Path Abs Dir)
forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
SimpleGetter env (Path Abs Dir)
hackageDirLGetting r env (Path Abs Dir)
-> ((Path Abs File -> Const r (Path Abs File))
    -> Path Abs Dir -> Const r (Path Abs Dir))
-> (Path Abs File -> Const r (Path Abs File))
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Path Abs Dir -> Path Abs File)
-> SimpleGetter (Path Abs Dir) (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
indexRelFile)

-- | Did an update occur when running 'updateHackageIndex'?

--

-- @since 0.1.0.0

data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred


-- | Information returned by `getHackageTarball`

--

-- @since 0.1.0.0

data HackageTarballResult = HackageTarballResult
  { HackageTarballResult -> Package
htrPackage :: !Package
    -- ^ Package that was loaded from Hackage tarball

  , HackageTarballResult -> Maybe (GenericPackageDescription, TreeId)
htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId))
    -- ^ This information is only available whenever package was just loaded

    -- into pantry.

  }

-- | Download the most recent 01-index.tar file from Hackage and update the

-- database tables.

--

-- This function will only perform an update once per 'PantryConfig' for user

-- sanity. See the return value to find out if it happened.

--

-- @since 0.1.0.0

updateHackageIndex ::
     (HasPantryConfig env, HasLogFunc env)
  => Maybe Utf8Builder -- ^ reason for updating, if any

  -> RIO env DidUpdateOccur
updateHackageIndex :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex = Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndexInternal Bool
False

-- | Same as `updateHackageIndex`, but force the database update even if hackage

-- security tells that there is no change.  This can be useful in order to make

-- sure the database is in sync with the locally downloaded tarball

--

-- @since 0.1.0.0

forceUpdateHackageIndex ::
     (HasPantryConfig env, HasLogFunc env)
  => Maybe Utf8Builder
  -> RIO env DidUpdateOccur
forceUpdateHackageIndex :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
forceUpdateHackageIndex = Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndexInternal Bool
True


updateHackageIndexInternal ::
     (HasPantryConfig env, HasLogFunc env)
  => Bool -- ^ Force the database update.

  -> Maybe Utf8Builder -- ^ reason for updating, if any

  -> RIO env DidUpdateOccur
updateHackageIndexInternal :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndexInternal Bool
forceUpdate Maybe Utf8Builder
mreason = do
  storage <- Getting Storage env Storage -> RIO env Storage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Storage env Storage -> RIO env Storage)
-> Getting Storage env Storage -> RIO env Storage
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Storage PantryConfig)
-> env -> Const Storage env
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Storage PantryConfig)
 -> env -> Const Storage env)
-> ((Storage -> Const Storage Storage)
    -> PantryConfig -> Const Storage PantryConfig)
-> Getting Storage env Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Storage) -> SimpleGetter PantryConfig Storage
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Storage
pcStorage
  gateUpdate $ withWriteLock_ storage $ do
    for_ mreason logInfo
    pc <- view pantryConfigL
    let PackageIndexConfig url (HackageSecurityConfig keyIds threshold ignoreExpiry) = pcPackageIndex pc
    root <- view hackageDirL
    tarball <- view hackageIndexTarballL
    baseURI <-
      case parseURI $ T.unpack url of
        Maybe URI
Nothing ->
          FilePath -> RIO env URI
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString (FilePath -> RIO env URI) -> FilePath -> RIO env URI
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid Hackage Security base URL: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
url
        Just URI
x -> URI -> RIO env URI
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure URI
x
    run <- askRunInIO
    let logTUF = RIO env () -> IO ()
run (RIO env () -> IO ())
-> (LogMessage -> RIO env ()) -> LogMessage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (LogMessage -> Utf8Builder) -> LogMessage -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder)
-> (LogMessage -> FilePath) -> LogMessage -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> FilePath
forall a. Pretty a => a -> FilePath
HS.pretty
        withRepo = HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
forall a.
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
HS.withRepository
          HttpLib
HS.httpLib
          [URI
baseURI]
          RepoOpts
HS.defaultRepoOpts
          HS.Cache
            { cacheRoot :: Path Absolute
HS.cacheRoot = FilePath -> Path Absolute
HS.fromAbsoluteFilePath (FilePath -> Path Absolute) -> FilePath -> Path Absolute
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
root
            , cacheLayout :: CacheLayout
HS.cacheLayout = CacheLayout
HS.cabalCacheLayout
            }
          RepoLayout
HS.hackageRepoLayout
          IndexLayout
HS.hackageIndexLayout
          LogMessage -> IO ()
logTUF
    didUpdate <- liftIO $ withRepo $ \Repository RemoteTemp
repo -> ((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO HasUpdates)
-> IO HasUpdates
forall a.
((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO a)
-> IO a
HS.uncheckClientErrors (((Throws VerificationError, Throws SomeRemoteError,
   Throws InvalidPackageException) =>
  IO HasUpdates)
 -> IO HasUpdates)
-> ((Throws VerificationError, Throws SomeRemoteError,
     Throws InvalidPackageException) =>
    IO HasUpdates)
-> IO HasUpdates
forall a b. (a -> b) -> a -> b
$ do
      needBootstrap <- Repository RemoteTemp -> IO Bool
forall (down :: * -> *). Repository down -> IO Bool
HS.requiresBootstrap Repository RemoteTemp
repo
      when needBootstrap $ do
        HS.bootstrap
          repo
          (map (HS.KeyId . T.unpack) keyIds)
          (HS.KeyThreshold $ fromIntegral threshold)
      maybeNow <- if ignoreExpiry
                    then pure Nothing
                    else Just <$> getCurrentTime
      HS.checkForUpdates repo maybeNow

    case didUpdate of
      HasUpdates
_ | Bool
forceUpdate -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Forced package update is initialized"
            Path Abs File -> RIO env ()
forall {env}.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
      HasUpdates
HS.NoUpdates -> do
        x <- Path Abs File -> RIO env Bool
forall {env} {b} {t}.
(HasPantryConfig env, HasLogFunc env) =>
Path b t -> RIO env Bool
needsCacheUpdate Path Abs File
tarball
        if x
          then do
            logInfo "No package index update available, but didn't update cache last time, running now"
            updateCache tarball
          else logInfo "No package index update available and cache up to date"
      HasUpdates
HS.HasUpdates -> do
        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Updated package index downloaded"
        Path Abs File -> RIO env ()
forall {env}.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
    logStickyDone "Package index cache populated"
 where
  -- The size of the new index tarball, ignoring the required (by the tar spec)

  -- 1024 null bytes at the end, which will be mutated in the future by other

  -- updates.

  getTarballSize :: MonadIO m => Handle -> m Word
  getTarballSize :: forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize Handle
h = Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word) -> (Integer -> Integer) -> Integer -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
1024 (Integer -> Word) -> m Integer -> m Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> m Integer
forall (m :: * -> *). MonadIO m => Handle -> m Integer
hFileSize Handle
h

  -- Check if the size of the tarball on the disk matches the value in

  -- CacheUpdate. If not, we need to perform a cache update, even if we didn't

  -- download any new information. This can be caused by canceling an

  -- updateCache call.

  needsCacheUpdate :: Path b t -> RIO env Bool
needsCacheUpdate Path b t
tarball = do
    mres <- ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
-> RIO env (Maybe (FileSize, SHA256))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate
    case mres of
      Maybe (FileSize, SHA256)
Nothing -> Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Just (FileSize Word
cachedSize, SHA256
_sha256) -> do
        actualSize <- FilePath -> IOMode -> (Handle -> RIO env Word) -> RIO env Word
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b t
tarball) IOMode
ReadMode Handle -> RIO env Word
forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize
        pure $ cachedSize /= actualSize

  -- This is the one action in the Pantry codebase known to hold a write lock on

  -- the database for an extended period of time. To avoid failures due to

  -- SQLite locks failing, we take our own lock outside of SQLite for this

  -- action.

  --

  -- See https://github.com/commercialhaskell/stack/issues/4471

  updateCache :: Path Abs File -> RIO env ()
updateCache Path Abs File
tarball = ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    -- Alright, here's the story. In theory, we only ever append to a tarball.

    -- Therefore, we can store the last place we populated our cache from, and

    -- fast forward to that point. But there are two issues with that:

    --

    -- 1. Hackage may rebase, in which case we need to recalculate everything

    -- from the beginning. Unfortunately, hackage-security doesn't let us know

    -- when that happens.

    --

    -- 2. Some paranoia about files on the filesystem getting modified out from

    -- under us.

    --

    -- Therefore, we store both the last read-to index, _and_ the SHA256 of all

    -- of the contents until that point. When updating the cache, we calculate

    -- the new SHA256 of the whole file, and the SHA256 of the previous read-to

    -- point. If the old hashes match, we can do an efficient fast forward.

    -- Otherwise, we clear the old cache and repopulate.

    minfo <- ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate
    (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \Handle
h -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Calculating hashes to check for hackage-security rebases or filesystem changes"

      newSize <- Handle -> RIO env Word
forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize Handle
h
      let sinkSHA256 a
len = Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len) ConduitT ByteString ByteString m ()
-> ConduitT ByteString c m SHA256 -> ConduitT ByteString c m SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString c m SHA256
forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash

      case minfo of
        Maybe (FileSize, SHA256)
Nothing -> do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No old cache found, populating cache from scratch"
          newHash <- ConduitT () Void (RIO env) SHA256 -> RIO env SHA256
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) SHA256 -> RIO env SHA256)
-> ConduitT () Void (RIO env) SHA256 -> RIO env SHA256
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString (RIO env) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) SHA256
-> ConduitT () Void (RIO env) SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Word -> ConduitT ByteString Void (RIO env) SHA256
forall {m :: * -> *} {a} {c}.
(Monad m, Integral a) =>
a -> ConduitT ByteString c m SHA256
sinkSHA256 Word
newSize
          pure (0, newHash, newSize)
        Just (FileSize Word
oldSize, SHA256
oldHash) -> do
          -- oldSize and oldHash come from the database, and tell

          -- us what we cached already. Compare against

          -- oldHashCheck, which assuming the tarball has not been

          -- rebased will be the same as oldHash. At the same

          -- time, calculate newHash, which is the hash of the new

          -- content as well.

          (oldHashCheck, newHash) <- ConduitT () Void (RIO env) (SHA256, SHA256)
-> RIO env (SHA256, SHA256)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) (SHA256, SHA256)
 -> RIO env (SHA256, SHA256))
-> ConduitT () Void (RIO env) (SHA256, SHA256)
-> RIO env (SHA256, SHA256)
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString (RIO env) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) (SHA256, SHA256)
-> ConduitT () Void (RIO env) (SHA256, SHA256)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ZipSink ByteString (RIO env) (SHA256, SHA256)
-> ConduitT ByteString Void (RIO env) (SHA256, SHA256)
forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink ((,)
            (SHA256 -> SHA256 -> (SHA256, SHA256))
-> ZipSink ByteString (RIO env) SHA256
-> ZipSink ByteString (RIO env) (SHA256 -> (SHA256, SHA256))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT ByteString Void (RIO env) SHA256
-> ZipSink ByteString (RIO env) SHA256
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (Word -> ConduitT ByteString Void (RIO env) SHA256
forall {m :: * -> *} {a} {c}.
(Monad m, Integral a) =>
a -> ConduitT ByteString c m SHA256
sinkSHA256 Word
oldSize)
            ZipSink ByteString (RIO env) (SHA256 -> (SHA256, SHA256))
-> ZipSink ByteString (RIO env) SHA256
-> ZipSink ByteString (RIO env) (SHA256, SHA256)
forall a b.
ZipSink ByteString (RIO env) (a -> b)
-> ZipSink ByteString (RIO env) a -> ZipSink ByteString (RIO env) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT ByteString Void (RIO env) SHA256
-> ZipSink ByteString (RIO env) SHA256
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (Word -> ConduitT ByteString Void (RIO env) SHA256
forall {m :: * -> *} {a} {c}.
(Monad m, Integral a) =>
a -> ConduitT ByteString c m SHA256
sinkSHA256 Word
newSize)
                                                                           )
          offset <-
            if oldHash == oldHashCheck
              then oldSize <$ logInfo "Updating preexisting cache, should be quick"
              else 0 <$ do
                logWarn $ mconcat [
                  "Package index change detected, that's pretty unusual: "
                  , "\n    Old size: " <> display oldSize
                  , "\n    Old hash (orig) : " <> display oldHash
                  , "\n    New hash (check): " <> display oldHashCheck
                  , "\n    Forcing a recache"
                  ]
          pure (offset, newHash, newSize)

    lift $ logInfo $
         "Populating cache from file size "
      <> display newSize
      <> ", hash "
      <> display newHash
    when (offset == 0) clearHackageRevisions
    populateCache tarball (fromIntegral offset) `onException`
      lift (logStickyDone "Failed populating package index cache")
    storeCacheUpdate (FileSize newSize) newHash
  gateUpdate :: m b -> m DidUpdateOccur
gateUpdate m b
inner = do
    pc <- Getting PantryConfig s PantryConfig -> m PantryConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PantryConfig s PantryConfig
forall env. HasPantryConfig env => Lens' env PantryConfig
Lens' s PantryConfig
pantryConfigL
    join $ modifyMVar (pcUpdateRef pc) $ \Bool
toUpdate -> (Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur))
-> (Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur)
forall a b. (a -> b) -> a -> b
$
      if Bool
toUpdate
        then (Bool
False, DidUpdateOccur
UpdateOccurred DidUpdateOccur -> m b -> m DidUpdateOccur
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m b
inner)
        else (Bool
False, DidUpdateOccur -> m DidUpdateOccur
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DidUpdateOccur
NoUpdateOccurred)

-- | Populate the SQLite tables with Hackage index information.

populateCache ::
     (HasPantryConfig env, HasLogFunc env)
  => Path Abs File -- ^ tarball

  -> Integer -- ^ where to start processing from

  -> ReaderT SqlBackend (RIO env) ()
populateCache :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
populateCache Path Abs File
fp Integer
offset = FilePath
-> IOMode
-> (Handle -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
fp) IOMode
ReadMode ((Handle -> ReaderT SqlBackend (RIO env) ())
 -> ReaderT SqlBackend (RIO env) ())
-> (Handle -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
  RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Populating package index cache ..."
  counter <- Int -> ReaderT SqlBackend (RIO env) (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
  hSeek h AbsoluteSeek offset
  runConduit $ sourceHandle h .| untar (perFile counter)
 where
  perFile :: IORef a
-> FileInfo
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
perFile IORef a
counter FileInfo
fi
    | FileType
FTNormal <- FileInfo -> FileType
fileType FileInfo
fi
    , Right Text
path <- ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
    , Just (PackageName
name, Version
version, Text
filename) <- Text -> Maybe (PackageName, Version, Text)
forall {a} {b}. (Parsec a, Parsec b) => Text -> Maybe (a, b, Text)
parseNameVersionSuffix Text
path =
        if
          | Text
filename Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"package.json" ->
              ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
-> (ByteString
    -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b.
ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
-> (a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) b)
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. Monad m => m a -> ConduitT ByteString o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
 -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> (ByteString -> ReaderT SqlBackend (RIO env) ())
-> ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall {env}.
HasLogFunc env =>
PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addJSON PackageName
name Version
version
          | Text
filename Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== SafeFilePath -> Text
unSafeFilePath (PackageName -> SafeFilePath
cabalFileName PackageName
name) -> do
              ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
-> (ByteString
    -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b.
ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
-> (a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) b)
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. Monad m => m a -> ConduitT ByteString o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
 -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> (ByteString -> ReaderT SqlBackend (RIO env) ())
-> ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall {env}.
PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addCabal PackageName
name Version
version) (ByteString
 -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> (ByteString -> ByteString)
-> ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
              count <- IORef a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
counter
              let count' = a
count a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
              writeIORef counter count'
              when (count' `mod` 400 == 0) $
                lift $ lift $
                logSticky $ "Processed " <> display count' <> " cabal files"
          | Bool
otherwise -> () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a.
a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | FileType
FTNormal <- FileInfo -> FileType
fileType FileInfo
fi
    , Right Text
path <- ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
    , (Text
nameT, Text
"/preferred-versions") <- (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Text
path
    , Just PackageName
name <- FilePath -> Maybe PackageName
parsePackageName (FilePath -> Maybe PackageName) -> FilePath -> Maybe PackageName
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
nameT = do
        lbs <- ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
        case decodeUtf8' $ BL.toStrict lbs of
          Left UnicodeException
_ -> () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a.
a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- maybe warning

          Right Text
p -> ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. Monad m => m a -> ConduitT ByteString o m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
 -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b. (a -> b) -> a -> b
$ PackageName -> Text -> ReaderT SqlBackend (RIO env) ()
forall env. PackageName -> Text -> ReaderT SqlBackend (RIO env) ()
storePreferredVersion PackageName
name Text
p
    | Bool
otherwise = () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a.
a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  addJSON :: PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addJSON PackageName
name Version
version ByteString
lbs =
    case ByteString -> Either FilePath PackageDownload
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode' ByteString
lbs of
      Left FilePath
e -> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT SqlBackend m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"Error: [S-563]\n"
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Error processing Hackage security metadata for "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display PackageName
name) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"-"
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Version -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display Version
version) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
e
      Right (PackageDownload SHA256
sha Word
size) ->
        PackageName
-> Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName
-> Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) ()
storeHackageTarballInfo PackageName
name Version
version SHA256
sha (FileSize -> ReaderT SqlBackend (RIO env) ())
-> FileSize -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Word -> FileSize
FileSize Word
size

  addCabal :: PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addCabal PackageName
name Version
version ByteString
bs = do
    (blobTableId, _blobKey) <- ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
bs

    storeHackageRevision name version blobTableId

  breakSlash :: Text -> Maybe (Text, Text)
breakSlash Text
x
    | Text -> Bool
T.null Text
z = Maybe (Text, Text)
forall a. Maybe a
Nothing
    | Bool
otherwise = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
y, Text -> Text
unsafeTail Text
z)
   where
    (Text
y, Text
z) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Text
x

  parseNameVersionSuffix :: Text -> Maybe (a, b, Text)
parseNameVersionSuffix Text
t1 = do
    (name, t2) <- Text -> Maybe (Text, Text)
breakSlash Text
t1
    (version, filename) <- breakSlash t2

    name' <- Distribution.Text.simpleParse $ T.unpack name
    version' <- Distribution.Text.simpleParse $ T.unpack version

    Just (name', version', filename)

-- | Package download info from Hackage

data PackageDownload = PackageDownload !SHA256 !Word

instance FromJSON PackageDownload where
  parseJSON :: Value -> Parser PackageDownload
parseJSON = FilePath
-> (Object -> Parser PackageDownload)
-> Value
-> Parser PackageDownload
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"PackageDownload" ((Object -> Parser PackageDownload)
 -> Value -> Parser PackageDownload)
-> (Object -> Parser PackageDownload)
-> Value
-> Parser PackageDownload
forall a b. (a -> b) -> a -> b
$ \Object
o1 -> do
    o2 <- Object
o1 Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"signed"
    Object o3 <- o2 .: "targets"
    Object o4:_ <- pure $ toList o3
    len <- o4 .: "length"
    hashes <- o4 .: "hashes"
    sha256' <- hashes .: "sha256"
    sha256 <-
      case SHA256.fromHexText sha256' of
        Left SHA256Exception
e -> FilePath -> Parser SHA256
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser SHA256) -> FilePath -> Parser SHA256
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid sha256: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SHA256Exception -> FilePath
forall a. Show a => a -> FilePath
show SHA256Exception
e
        Right SHA256
x -> SHA256 -> Parser SHA256
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SHA256
x
    pure $ PackageDownload sha256 len

getHackageCabalFile ::
     (HasPantryConfig env, HasLogFunc env)
  => PackageIdentifierRevision
  -> RIO env ByteString
getHackageCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
_ Version
_ CabalFileInfo
cfi) = do
  bid <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
  bs <- withStorage $ loadBlobById bid
  case cfi of
    CFIHash SHA256
sha Maybe FileSize
msize -> do
      let sizeMismatch :: Bool
sizeMismatch =
            case Maybe FileSize
msize of
              Maybe FileSize
Nothing -> Bool
False
              Just FileSize
size -> Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSize
size
          shaMismatch :: Bool
shaMismatch = SHA256
sha SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> SHA256
SHA256.hashBytes ByteString
bs
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sizeMismatch Bool -> Bool -> Bool
|| Bool
shaMismatch)
        (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> RIO env ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath
"getHackageCabalFile: size or SHA mismatch for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (PackageIdentifierRevision, ByteString) -> FilePath
forall a. Show a => a -> FilePath
show (PackageIdentifierRevision
pir, ByteString
bs)
    CabalFileInfo
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  pure bs

resolveCabalFileInfo ::
     (HasPantryConfig env, HasLogFunc env)
  => PackageIdentifierRevision
  -> RIO env BlobId
resolveCabalFileInfo :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
cfi) = do
  mres <- RIO env (Maybe BlobId)
inner
  case mres of
    Just BlobId
res -> BlobId -> RIO env BlobId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
    Maybe BlobId
Nothing -> do
      updated <- Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just
        (Utf8Builder -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$  Utf8Builder
"Cabal file info not found for "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
      mres' <-
        case updated of
          DidUpdateOccur
UpdateOccurred -> RIO env (Maybe BlobId)
inner
          DidUpdateOccur
NoUpdateOccurred -> Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
      case mres' of
        Maybe BlobId
Nothing -> PackageName -> Version -> RIO env FuzzyResults
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> Version -> RIO env FuzzyResults
fuzzyLookupCandidates PackageName
name Version
ver RIO env FuzzyResults
-> (FuzzyResults -> RIO env BlobId) -> RIO env BlobId
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PantryException -> RIO env BlobId
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env BlobId)
-> (FuzzyResults -> PantryException)
-> FuzzyResults
-> RIO env BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifierRevision -> FuzzyResults -> PantryException
UnknownHackagePackage PackageIdentifierRevision
pir
        Just BlobId
res -> BlobId -> RIO env BlobId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
 where
  inner :: RIO env (Maybe BlobId)
inner =
    case CabalFileInfo
cfi of
      CFIHash SHA256
sha Maybe FileSize
msize -> PackageIdentifierRevision
-> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
forall a env.
(Display a, HasPantryConfig env, HasLogFunc env) =>
a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA PackageIdentifierRevision
pir SHA256
sha Maybe FileSize
msize
      CFIRevision Revision
rev ->
        ((BlobId, BlobKey) -> BlobId)
-> Maybe (BlobId, BlobKey) -> Maybe BlobId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlobId, BlobKey) -> BlobId
forall a b. (a, b) -> a
fst (Maybe (BlobId, BlobKey) -> Maybe BlobId)
-> (Map Revision (BlobId, BlobKey) -> Maybe (BlobId, BlobKey))
-> Map Revision (BlobId, BlobKey)
-> Maybe BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Revision
-> Map Revision (BlobId, BlobKey) -> Maybe (BlobId, BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Revision
rev (Map Revision (BlobId, BlobKey) -> Maybe BlobId)
-> RIO env (Map Revision (BlobId, BlobKey))
-> RIO env (Maybe BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> RIO env (Map Revision (BlobId, BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
ver)
      CabalFileInfo
CFILatest ->
        (((BlobId, BlobKey), Map Revision (BlobId, BlobKey)) -> BlobId)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> Maybe BlobId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlobId, BlobKey) -> BlobId
forall a b. (a, b) -> a
fst ((BlobId, BlobKey) -> BlobId)
-> (((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
    -> (BlobId, BlobKey))
-> ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> (BlobId, BlobKey)
forall a b. (a, b) -> a
fst) (Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
 -> Maybe BlobId)
-> (Map Revision (BlobId, BlobKey)
    -> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey)))
-> Map Revision (BlobId, BlobKey)
-> Maybe BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Revision (BlobId, BlobKey)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView (Map Revision (BlobId, BlobKey) -> Maybe BlobId)
-> RIO env (Map Revision (BlobId, BlobKey))
-> RIO env (Maybe BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> RIO env (Map Revision (BlobId, BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
ver)

-- | Load or download a blob by its SHA.

loadOrDownloadBlobBySHA ::
     (Display a, HasPantryConfig env, HasLogFunc env)
  => a
  -> SHA256
  -> Maybe FileSize
  -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA :: forall a env.
(Display a, HasPantryConfig env, HasLogFunc env) =>
a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA a
label SHA256
sha256 Maybe FileSize
msize = do
  mresult <- RIO env (Maybe BlobId)
byDB
  case mresult of
    Maybe BlobId
Nothing -> do
      case Maybe FileSize
msize of
        Maybe FileSize
Nothing -> do
          Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
        Just FileSize
size -> do
          mblob <- BlobKey -> RIO env (Maybe ByteString)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
BlobKey -> RIO env (Maybe ByteString)
casaLookupKey (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha256 FileSize
size)
          case mblob of
            Maybe ByteString
Nothing -> do
              Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
            Just {} -> do
              result <- RIO env (Maybe BlobId)
byDB
              case result of
                Just BlobId
blobId -> do
                  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Pulled blob from Casa for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
label)
                  Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobId -> Maybe BlobId
forall a. a -> Maybe a
Just BlobId
blobId)
                Maybe BlobId
Nothing -> do
                  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
                    (Utf8Builder
"Bug? Blob pulled from Casa not in database for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                     a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
label)
                  Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
    Just BlobId
blobId -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Got blob from Pantry database for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
label)
      Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobId -> Maybe BlobId
forall a. a -> Maybe a
Just BlobId
blobId)
 where
  byDB :: RIO env (Maybe BlobId)
byDB = ReaderT SqlBackend (RIO env) (Maybe BlobId)
-> RIO env (Maybe BlobId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe BlobId)
 -> RIO env (Maybe BlobId))
-> ReaderT SqlBackend (RIO env) (Maybe BlobId)
-> RIO env (Maybe BlobId)
forall a b. (a -> b) -> a -> b
$ SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
forall env. SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA SHA256
sha256

-- | Given package identifier and package caches, return list of packages with

-- the same name and the same two first version number components found in the

-- caches.

fuzzyLookupCandidates ::
     (HasPantryConfig env, HasLogFunc env)
  => PackageName
  -> Version
  -> RIO env FuzzyResults
fuzzyLookupCandidates :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> Version -> RIO env FuzzyResults
fuzzyLookupCandidates PackageName
name Version
ver0 = do
  m <- RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
YesRequireHackageIndex UsePreferredVersions
UsePreferredVersions PackageName
name
  if Map.null m
    then FRNameNotFound <$> getHackageTypoCorrections name
    else
      case Map.lookup ver0 m of
        Maybe (Map Revision BlobKey)
Nothing -> do
          let withVers :: NonEmpty (Version, Map k BlobKey) -> f FuzzyResults
withVers NonEmpty (Version, Map k BlobKey)
vers = FuzzyResults -> f FuzzyResults
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyResults -> f FuzzyResults) -> FuzzyResults -> f FuzzyResults
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageIdentifierRevision -> FuzzyResults
FRVersionNotFound (NonEmpty PackageIdentifierRevision -> FuzzyResults)
-> NonEmpty PackageIdentifierRevision -> FuzzyResults
forall a b. (a -> b) -> a -> b
$ (((Version, Map k BlobKey) -> PackageIdentifierRevision)
 -> NonEmpty (Version, Map k BlobKey)
 -> NonEmpty PackageIdentifierRevision)
-> NonEmpty (Version, Map k BlobKey)
-> ((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty PackageIdentifierRevision
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty (Version, Map k BlobKey)
-> NonEmpty PackageIdentifierRevision
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map NonEmpty (Version, Map k BlobKey)
vers (((Version, Map k BlobKey) -> PackageIdentifierRevision)
 -> NonEmpty PackageIdentifierRevision)
-> ((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty PackageIdentifierRevision
forall a b. (a -> b) -> a -> b
$ \(Version
ver, Map k BlobKey
revs) ->
                case Map k BlobKey -> Maybe (BlobKey, Map k BlobKey)
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map k BlobKey
revs of
                  Maybe (BlobKey, Map k BlobKey)
Nothing -> FilePath -> PackageIdentifierRevision
forall a. HasCallStack => FilePath -> a
error FilePath
"fuzzyLookupCandidates: no revisions"
                  Just (BlobKey SHA256
sha FileSize
size, Map k BlobKey
_) ->
                    PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size))
          case [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(Version, Map Revision BlobKey)]
 -> Maybe (NonEmpty (Version, Map Revision BlobKey)))
-> [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ ((Version, Map Revision BlobKey) -> Bool)
-> [(Version, Map Revision BlobKey)]
-> [(Version, Map Revision BlobKey)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> Bool
sameMajor (Version -> Bool)
-> ((Version, Map Revision BlobKey) -> Version)
-> (Version, Map Revision BlobKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, Map Revision BlobKey) -> Version
forall a b. (a, b) -> a
fst) ([(Version, Map Revision BlobKey)]
 -> [(Version, Map Revision BlobKey)])
-> [(Version, Map Revision BlobKey)]
-> [(Version, Map Revision BlobKey)]
forall a b. (a -> b) -> a -> b
$ Map Version (Map Revision BlobKey)
-> [(Version, Map Revision BlobKey)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Version (Map Revision BlobKey)
m of
            Just NonEmpty (Version, Map Revision BlobKey)
vers -> NonEmpty (Version, Map Revision BlobKey) -> RIO env FuzzyResults
forall {f :: * -> *} {k}.
Applicative f =>
NonEmpty (Version, Map k BlobKey) -> f FuzzyResults
withVers NonEmpty (Version, Map Revision BlobKey)
vers
            Maybe (NonEmpty (Version, Map Revision BlobKey))
Nothing ->
              case [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(Version, Map Revision BlobKey)]
 -> Maybe (NonEmpty (Version, Map Revision BlobKey)))
-> [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ Map Version (Map Revision BlobKey)
-> [(Version, Map Revision BlobKey)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Version (Map Revision BlobKey)
m of
                Maybe (NonEmpty (Version, Map Revision BlobKey))
Nothing -> FilePath -> RIO env FuzzyResults
forall a. HasCallStack => FilePath -> a
error FilePath
"fuzzyLookupCandidates: no versions"
                Just NonEmpty (Version, Map Revision BlobKey)
vers -> NonEmpty (Version, Map Revision BlobKey) -> RIO env FuzzyResults
forall {f :: * -> *} {k}.
Applicative f =>
NonEmpty (Version, Map k BlobKey) -> f FuzzyResults
withVers NonEmpty (Version, Map Revision BlobKey)
vers
        Just Map Revision BlobKey
revisions ->
          let pirs :: [PackageIdentifierRevision]
pirs = (BlobKey -> PackageIdentifierRevision)
-> [BlobKey] -> [PackageIdentifierRevision]
forall a b. (a -> b) -> [a] -> [b]
map
                (\(BlobKey SHA256
sha FileSize
size) ->
                  PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver0 (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)))
                (Map Revision BlobKey -> [BlobKey]
forall k a. Map k a -> [a]
Map.elems Map Revision BlobKey
revisions)
           in case [PackageIdentifierRevision]
-> Maybe (NonEmpty PackageIdentifierRevision)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageIdentifierRevision]
pirs of
                Maybe (NonEmpty PackageIdentifierRevision)
Nothing -> FilePath -> RIO env FuzzyResults
forall a. HasCallStack => FilePath -> a
error FilePath
"fuzzyLookupCandidates: no revisions"
                Just NonEmpty PackageIdentifierRevision
pirs' -> FuzzyResults -> RIO env FuzzyResults
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyResults -> RIO env FuzzyResults)
-> FuzzyResults -> RIO env FuzzyResults
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageIdentifierRevision -> FuzzyResults
FRRevisionNotFound NonEmpty PackageIdentifierRevision
pirs'
 where
  sameMajor :: Version -> Bool
sameMajor Version
v = Version -> [Int]
toMajorVersion Version
v [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> [Int]
toMajorVersion Version
ver0

toMajorVersion :: Version -> [Int]
toMajorVersion :: Version -> [Int]
toMajorVersion Version
v =
  case Version -> [Int]
versionNumbers Version
v of
    []    -> [Int
0, Int
0]
    [Int
a]   -> [Int
a, Int
0]
    Int
a:Int
b:[Int]
_ -> [Int
a, Int
b]

-- | Try to come up with typo corrections for given package identifier using

-- Hackage package names. This can provide more user-friendly information in

-- error messages.

--

-- @since 0.1.0.0

getHackageTypoCorrections ::
     (HasPantryConfig env, HasLogFunc env)
  => PackageName
  -> RIO env [PackageName]
getHackageTypoCorrections :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name1 =
  ReaderT SqlBackend (RIO env) [PackageName] -> RIO env [PackageName]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) [PackageName]
 -> RIO env [PackageName])
-> ReaderT SqlBackend (RIO env) [PackageName]
-> RIO env [PackageName]
forall a b. (a -> b) -> a -> b
$ (PackageName -> Bool)
-> ConduitT
     PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
-> ReaderT SqlBackend (RIO env) [PackageName]
forall env a.
(PackageName -> Bool)
-> ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a
-> ReaderT SqlBackend (RIO env) a
sinkHackagePackageNames
    (\PackageName
name2 -> PackageName
name1 PackageName -> PackageName -> Int
`distance` PackageName
name2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4)
    (Int
-> ConduitT
     PackageName PackageName (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. Monad m => Int -> ConduitT a a m ()
takeC Int
10 ConduitT PackageName PackageName (ReaderT SqlBackend (RIO env)) ()
-> ConduitT
     PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
-> ConduitT
     PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList)
 where
  distance :: PackageName -> PackageName -> Int
distance = Text -> Text -> Int
damerauLevenshtein (Text -> Text -> Int)
-> (PackageName -> Text) -> PackageName -> PackageName -> Int
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FilePath -> Text
T.pack (FilePath -> Text)
-> (PackageName -> FilePath) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString)

-- | Should we pay attention to Hackage's preferred versions?

--

-- @since 0.1.0.0

data UsePreferredVersions
  = UsePreferredVersions
  | IgnorePreferredVersions
  deriving Int -> UsePreferredVersions -> FilePath -> FilePath
[UsePreferredVersions] -> FilePath -> FilePath
UsePreferredVersions -> FilePath
(Int -> UsePreferredVersions -> FilePath -> FilePath)
-> (UsePreferredVersions -> FilePath)
-> ([UsePreferredVersions] -> FilePath -> FilePath)
-> Show UsePreferredVersions
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> UsePreferredVersions -> FilePath -> FilePath
showsPrec :: Int -> UsePreferredVersions -> FilePath -> FilePath
$cshow :: UsePreferredVersions -> FilePath
show :: UsePreferredVersions -> FilePath
$cshowList :: [UsePreferredVersions] -> FilePath -> FilePath
showList :: [UsePreferredVersions] -> FilePath -> FilePath
Show

-- | Require that the Hackage index is populated.

--

-- @since 0.1.0.0

data RequireHackageIndex
  = YesRequireHackageIndex
    -- ^ If there is nothing in the Hackage index, then perform an update

  | NoRequireHackageIndex
    -- ^ Do not perform an update

  deriving Int -> RequireHackageIndex -> FilePath -> FilePath
[RequireHackageIndex] -> FilePath -> FilePath
RequireHackageIndex -> FilePath
(Int -> RequireHackageIndex -> FilePath -> FilePath)
-> (RequireHackageIndex -> FilePath)
-> ([RequireHackageIndex] -> FilePath -> FilePath)
-> Show RequireHackageIndex
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> RequireHackageIndex -> FilePath -> FilePath
showsPrec :: Int -> RequireHackageIndex -> FilePath -> FilePath
$cshow :: RequireHackageIndex -> FilePath
show :: RequireHackageIndex -> FilePath
$cshowList :: [RequireHackageIndex] -> FilePath -> FilePath
showList :: [RequireHackageIndex] -> FilePath -> FilePath
Show

initializeIndex ::
     (HasPantryConfig env, HasLogFunc env)
  => RequireHackageIndex
  -> RIO env ()
initializeIndex :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
NoRequireHackageIndex = () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
initializeIndex RequireHackageIndex
YesRequireHackageIndex = do
  cabalCount <- ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage ReaderT SqlBackend (RIO env) Int
forall env. ReaderT SqlBackend (RIO env) Int
countHackageCabals
  when (cabalCount == 0) $ void $
    updateHackageIndex $ Just "No information from Hackage index, updating"

-- | Returns the versions of the package available on Hackage.

--

-- @since 0.1.0.0

getHackagePackageVersions ::
     (HasPantryConfig env, HasLogFunc env)
  => RequireHackageIndex
  -> UsePreferredVersions
  -> PackageName -- ^ package name

  -> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
usePreferred PackageName
name = do
  RequireHackageIndex -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
req
  ReaderT SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
 -> RIO env (Map Version (Map Revision BlobKey)))
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ do
    mpreferred <-
      case UsePreferredVersions
usePreferred of
        UsePreferredVersions
UsePreferredVersions -> PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
loadPreferredVersion PackageName
name
        UsePreferredVersions
IgnorePreferredVersions -> Maybe Text -> ReaderT SqlBackend (RIO env) (Maybe Text)
forall a. a -> ReaderT SqlBackend (RIO env) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    let predicate :: Version -> Map Revision BlobKey -> Bool
        predicate = (Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
-> Version
-> Map Revision BlobKey
-> Bool
forall a. a -> Maybe a -> a
fromMaybe (\Version
_ Map Revision BlobKey
_ -> Bool
True) (Maybe (Version -> Map Revision BlobKey -> Bool)
 -> Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
-> Version
-> Map Revision BlobKey
-> Bool
forall a b. (a -> b) -> a -> b
$ do
          preferredT1 <- Maybe Text
mpreferred
          preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1
          vr <- Distribution.Text.simpleParse $ T.unpack preferredT2
          Just $ \Version
v Map Revision BlobKey
_ -> Version -> VersionRange -> Bool
withinRange Version
v VersionRange
vr
    Map.filterWithKey predicate <$> loadHackagePackageVersions name

-- | Returns the versions of the package available on Hackage.

--

-- @since 0.1.0.0

getHackagePackageVersionRevisions ::
     (HasPantryConfig env, HasLogFunc env)
  => RequireHackageIndex
  -> PackageName -- ^ package name

  -> Version -- ^ package version

  -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version = do
  RequireHackageIndex -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
req
  ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
-> RIO env (Map Revision BlobKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
 -> RIO env (Map Revision BlobKey))
-> ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
-> RIO env (Map Revision BlobKey)
forall a b. (a -> b) -> a -> b
$
    ((BlobId, BlobKey) -> BlobKey)
-> Map Revision (BlobId, BlobKey) -> Map Revision BlobKey
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (BlobId, BlobKey) -> BlobKey
forall a b. (a, b) -> b
snd (Map Revision (BlobId, BlobKey) -> Map Revision BlobKey)
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
version

withCachedTree ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => RawPackageLocationImmutable
  -> PackageName
  -> Version
  -> BlobId -- ^ cabal file contents

  -> RIO env HackageTarballResult
  -> RIO env HackageTarballResult
withCachedTree :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
withCachedTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid RIO env HackageTarballResult
inner = do
  mres <- ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe Package)
 -> RIO env (Maybe Package))
-> ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
loadHackageTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid
  case mres of
    Just Package
package -> HackageTarballResult -> RIO env HackageTarballResult
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageTarballResult -> RIO env HackageTarballResult)
-> HackageTarballResult -> RIO env HackageTarballResult
forall a b. (a -> b) -> a -> b
$ Package
-> Maybe (GenericPackageDescription, TreeId)
-> HackageTarballResult
HackageTarballResult Package
package Maybe (GenericPackageDescription, TreeId)
forall a. Maybe a
Nothing
    Maybe Package
Nothing -> do
      htr <- RIO env HackageTarballResult
inner
      withStorage $
        storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr
      pure htr

getHackageTarballKey ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageIdentifierRevision
  -> RIO env TreeKey
getHackageTarballKey :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
name Version
ver (CFIHash SHA256
sha Maybe FileSize
_msize)) = do
  mres <- ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe TreeKey)
 -> RIO env (Maybe TreeKey))
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey)
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
forall env.
PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
loadHackageTreeKey PackageName
name Version
ver SHA256
sha
  case mres of
    Maybe TreeKey
Nothing -> Package -> TreeKey
packageTreeKey (Package -> TreeKey)
-> (HackageTarballResult -> Package)
-> HackageTarballResult
-> TreeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageTarballResult -> Package
htrPackage (HackageTarballResult -> TreeKey)
-> RIO env HackageTarballResult -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing
    Just TreeKey
key -> TreeKey -> RIO env TreeKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
key
getHackageTarballKey PackageIdentifierRevision
pir =
  Package -> TreeKey
packageTreeKey (Package -> TreeKey)
-> (HackageTarballResult -> Package)
-> HackageTarballResult
-> TreeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageTarballResult -> Package
htrPackage (HackageTarballResult -> TreeKey)
-> RIO env HackageTarballResult -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing

getHackageTarball ::
     (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageIdentifierRevision
  -> Maybe TreeKey
  -> RIO env HackageTarballResult
getHackageTarball :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
mtreeKey = do
  let PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
_cfi = PackageIdentifierRevision
pir
  cabalFile <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
  let rpli = PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtreeKey
  withCachedTree rpli name ver cabalFile $ do
    cabalFileKey <- withStorage $ getBlobKey cabalFile
    mpair <- withStorage $ loadHackageTarballInfo name ver
    (sha, size) <-
      case mpair of
        Just (SHA256, FileSize)
pair -> (SHA256, FileSize) -> RIO env (SHA256, FileSize)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize)
pair
        Maybe (SHA256, FileSize)
Nothing -> do
          let exc :: PantryException
exc = PackageIdentifier -> PantryException
NoHackageCryptographicHash (PackageIdentifier -> PantryException)
-> PackageIdentifier -> PantryException
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
ver
          updated <- Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just (Utf8Builder -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$ PantryException -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PantryException
exc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
          mpair2 <-
            case updated of
              DidUpdateOccur
UpdateOccurred -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
 -> RIO env (Maybe (SHA256, FileSize)))
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize))
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
loadHackageTarballInfo PackageName
name Version
ver
              DidUpdateOccur
NoUpdateOccurred -> Maybe (SHA256, FileSize) -> RIO env (Maybe (SHA256, FileSize))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SHA256, FileSize)
forall a. Maybe a
Nothing
          case mpair2 of
            Maybe (SHA256, FileSize)
Nothing -> PantryException -> RIO env (SHA256, FileSize)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
            Just (SHA256, FileSize)
pair2 -> (SHA256, FileSize) -> RIO env (SHA256, FileSize)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize)
pair2
    pc <- view pantryConfigL
    let urlPrefix = PackageIndexConfig -> Text
picDownloadPrefix (PackageIndexConfig -> Text) -> PackageIndexConfig -> Text
forall a b. (a -> b) -> a -> b
$ PantryConfig -> PackageIndexConfig
pcPackageIndex PantryConfig
pc
        url =
          [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
urlPrefix
            , Text
"package/"
            , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display PackageName
name
            , Text
"-"
            , FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Version -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display Version
ver
            , Text
".tar.gz"
            ]
    (_, _, package, cachedTree) <-
      getArchive
        rpli
        RawArchive
          { raLocation = ALUrl url
          , raHash = Just sha
          , raSize = Just size
          , raSubdir = T.empty -- no subdirs on Hackage

          }
        RawPackageMetadata
          { rpmName = Just name
          , rpmVersion = Just ver
          , rpmTreeKey = Nothing -- with a revision cabal file will differ

                                 -- giving a different tree

          }
    case cachedTree of
      CachedTreeMap Map SafeFilePath (TreeEntry, BlobId)
m -> do
        let ft :: FileType
ft =
              case Package -> PackageCabal
packageCabalEntry Package
package of
                PCCabalFile (TreeEntry BlobKey
_ FileType
ft') -> FileType
ft'
                PackageCabal
_ -> FilePath -> FileType
forall a. HasCallStack => FilePath -> a
error FilePath
"Impossible: Hackage does not support hpack"
            cabalEntry :: TreeEntry
cabalEntry = BlobKey -> FileType -> TreeEntry
TreeEntry BlobKey
cabalFileKey FileType
ft
        (cabalBS, cabalBlobId) <-
          ReaderT SqlBackend (RIO env) (ByteString, BlobId)
-> RIO env (ByteString, BlobId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (ByteString, BlobId)
 -> RIO env (ByteString, BlobId))
-> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
-> RIO env (ByteString, BlobId)
forall a b. (a -> b) -> a -> b
$ do
            let BlobKey SHA256
sha' FileSize
_ = BlobKey
cabalFileKey
            mcabalBS <- SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
forall env. SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA SHA256
sha'
            case mcabalBS of
              Maybe BlobId
Nothing ->
                FilePath -> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
forall a. HasCallStack => FilePath -> a
error (FilePath -> ReaderT SqlBackend (RIO env) (ByteString, BlobId))
-> FilePath -> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
forall a b. (a -> b) -> a -> b
$
                FilePath
"Invariant violated, cabal file key: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ BlobKey -> FilePath
forall a. Show a => a -> FilePath
show BlobKey
cabalFileKey
              Just BlobId
bid -> (, BlobId
bid) (ByteString -> (ByteString, BlobId))
-> ReaderT SqlBackend (RIO env) ByteString
-> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlobId -> ReaderT SqlBackend (RIO env) ByteString
forall env. BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById BlobId
bid
        let tree' = Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
CachedTreeMap (Map SafeFilePath (TreeEntry, BlobId) -> CachedTree)
-> Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
forall a b. (a -> b) -> a -> b
$
                      SafeFilePath
-> (TreeEntry, BlobId)
-> Map SafeFilePath (TreeEntry, BlobId)
-> Map SafeFilePath (TreeEntry, BlobId)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PackageName -> SafeFilePath
cabalFileName PackageName
name) (TreeEntry
cabalEntry, BlobId
cabalBlobId) Map SafeFilePath (TreeEntry, BlobId)
m
            ident = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
ver
        (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS
        let gpdIdent = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd
        when (ident /= gpdIdent) $
          throwIO $
          MismatchedCabalFileForHackage
            pir
            Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent}
        (tid, treeKey') <-
          withStorage $
          storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry)
        pure
          HackageTarballResult
            { htrPackage =
                Package
                  { packageTreeKey = treeKey'
                  , packageTree = unCachedTree tree'
                  , packageIdent = ident
                  , packageCabalEntry = PCCabalFile cabalEntry
                  }
            , htrFreshPackageInfo = Just (gpd, tid)
            }