{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Pantry.Hackage
  ( updateHackageIndex
  , forceUpdateHackageIndex
  , DidUpdateOccur (..)
  , RequireHackageIndex (..)
  , hackageIndexTarballL
  , getHackageTarball
  , getHackageTarballKey
  , getHackageCabalFile
  , getHackagePackageVersions
  , getHackagePackageVersionRevisions
  , getHackageTypoCorrections
  , UsePreferredVersions (..)
  , HackageTarballResult(..)
  ) where

import RIO
import RIO.Process
import Pantry.Casa
import Data.Aeson
import Conduit
import Data.Conduit.Tar
import qualified RIO.Text as T
import qualified RIO.Map as Map
import Data.Text.Unsafe (unsafeTail)
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import Pantry.Archive
import Pantry.Types hiding (FileType (..))
import Pantry.Storage hiding (TreeEntry, PackageName, Version)
import Pantry.Tree
import qualified Pantry.SHA256 as SHA256
import Network.URI (parseURI)
import Data.Time (getCurrentTime)
import Path ((</>), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile)
import qualified Distribution.Text
import qualified Distribution.PackageDescription as Cabal
import qualified Data.List.NonEmpty as NE
import Data.Text.Metrics (damerauLevenshtein)
import System.IO (SeekMode (..)) -- Needed on GHC 8.6
import Distribution.PackageDescription (GenericPackageDescription)
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.Remote as HS
import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS
import qualified Hackage.Security.Util.Path as HS
import qualified Hackage.Security.Util.Pretty as HS

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 :: SimpleGetter env (Path Abs Dir)
hackageDirL = (PantryConfig -> Const r PantryConfig) -> env -> Const r env
forall env. HasPantryConfig env => 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)

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
"00-index.tar"

-- | 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 :: SimpleGetter env (Path Abs File)
hackageIndexTarballL = Getting r env (Path Abs Dir)
forall env. HasPantryConfig env => 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 :: 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 :: 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 :: Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndexInternal Bool
forceUpdate Maybe Utf8Builder
mreason = do
  Storage
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
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
  RIO env () -> RIO env DidUpdateOccur
forall (m :: * -> *) s b.
(MonadReader s m, HasPantryConfig s, MonadUnliftIO m) =>
m b -> m DidUpdateOccur
gateUpdate (RIO env () -> RIO env DidUpdateOccur)
-> RIO env () -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Storage -> forall env a. HasLogFunc env => RIO env a -> RIO env a
withWriteLock_ Storage
storage (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe Utf8Builder -> (Utf8Builder -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Utf8Builder
mreason Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
    PantryConfig
pc <- Getting PantryConfig env PantryConfig -> RIO env PantryConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PantryConfig env PantryConfig
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
    let HackageSecurityConfig [Text]
keyIds Int
threshold Text
url Bool
ignoreExpiry = PantryConfig -> HackageSecurityConfig
pcHackageSecurity PantryConfig
pc
    Path Abs Dir
root <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirL
    Path Abs File
tarball <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL
    URI
baseURI <-
        case FilePath -> Maybe URI
parseURI (FilePath -> Maybe URI) -> FilePath -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
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 (m :: * -> *) a. Monad m => a -> m a
return URI
x
    RIO env () -> IO ()
run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    let logTUF :: LogMessage -> IO ()
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 :: (Repository RemoteTemp -> IO a) -> IO a
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
            Cache :: Path Absolute -> CacheLayout -> Cache
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
    HasUpdates
didUpdate <- IO HasUpdates -> RIO env HasUpdates
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HasUpdates -> RIO env HasUpdates)
-> IO HasUpdates -> RIO env HasUpdates
forall a b. (a -> b) -> a -> b
$ (Repository RemoteTemp -> IO HasUpdates) -> IO HasUpdates
forall a. (Repository RemoteTemp -> IO a) -> IO a
withRepo ((Repository RemoteTemp -> IO HasUpdates) -> IO HasUpdates)
-> (Repository RemoteTemp -> IO HasUpdates) -> IO HasUpdates
forall a b. (a -> b) -> a -> b
$ \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
        Bool
needBootstrap <- Repository RemoteTemp -> IO Bool
forall (down :: * -> *). Repository down -> IO Bool
HS.requiresBootstrap Repository RemoteTemp
repo
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBootstrap (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Repository RemoteTemp -> [KeyId] -> KeyThreshold -> IO ()
forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError) =>
Repository down -> [KeyId] -> KeyThreshold -> IO ()
HS.bootstrap
                Repository RemoteTemp
repo
                ((Text -> KeyId) -> [Text] -> [KeyId]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> KeyId
HS.KeyId (FilePath -> KeyId) -> (Text -> FilePath) -> Text -> KeyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) [Text]
keyIds)
                (Int54 -> KeyThreshold
HS.KeyThreshold (Int54 -> KeyThreshold) -> Int54 -> KeyThreshold
forall a b. (a -> b) -> a -> b
$ Int -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
threshold)
        Maybe UTCTime
maybeNow <- if Bool
ignoreExpiry
                      then Maybe UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
                      else UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
        Repository RemoteTemp -> Maybe UTCTime -> IO HasUpdates
forall (down :: * -> *).
(Throws VerificationError, Throws SomeRemoteError) =>
Repository down -> Maybe UTCTime -> IO HasUpdates
HS.checkForUpdates Repository RemoteTemp
repo Maybe UTCTime
maybeNow

    case HasUpdates
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
        Bool
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 Bool
x
          then do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No package index update available, but didn't update cache last time, running now"
            Path Abs File -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
          else Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"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
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"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 :: 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
      Maybe (FileSize, SHA256)
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 Maybe (FileSize, SHA256)
mres of
        Maybe (FileSize, SHA256)
Nothing -> Bool -> RIO env Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just (FileSize Word
cachedSize, SHA256
_sha256) -> do
          Word
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
          Bool -> RIO env Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Word
cachedSize Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
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.
      Maybe (FileSize, SHA256)
minfo <- ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate
      (Word
offset, SHA256
newHash, Word
newSize) <- RIO env (Word, SHA256, Word)
-> ReaderT SqlBackend (RIO env) (Word, SHA256, Word)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env (Word, SHA256, Word)
 -> ReaderT SqlBackend (RIO env) (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word)
-> ReaderT SqlBackend (RIO env) (Word, SHA256, Word)
forall a b. (a -> b) -> a -> b
$ FilePath
-> IOMode
-> (Handle -> RIO env (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word)
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
tarball) IOMode
ReadMode ((Handle -> RIO env (Word, SHA256, Word))
 -> RIO env (Word, SHA256, Word))
-> (Handle -> RIO env (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word)
forall a b. (a -> b) -> a -> b
$ \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"

        Word
newSize <- Handle -> RIO env Word
forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize Handle
h
        let sinkSHA256 :: a -> ConduitM ByteString c m SHA256
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 ()
-> ConduitM ByteString c m SHA256 -> ConduitM ByteString c m SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString c m SHA256
forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash

        case Maybe (FileSize, SHA256)
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"
            SHA256
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) ()
-> ConduitM ByteString Void (RIO env) SHA256
-> ConduitT () Void (RIO env) SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Word -> ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) a c.
(Monad m, Integral a) =>
a -> ConduitM ByteString c m SHA256
sinkSHA256 Word
newSize
            (Word, SHA256, Word) -> RIO env (Word, SHA256, Word)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
0, SHA256
newHash, Word
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.
            (SHA256
oldHashCheck, SHA256
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) ()
-> ConduitM ByteString Void (RIO env) (SHA256, SHA256)
-> ConduitT () Void (RIO env) (SHA256, SHA256)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ZipSink ByteString (RIO env) (SHA256, SHA256)
-> ConduitM ByteString Void (RIO env) (SHA256, SHA256)
forall i (m :: * -> *) r. ZipSink i m r -> Sink i 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
<$> ConduitM ByteString Void (RIO env) SHA256
-> ZipSink ByteString (RIO env) SHA256
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Word -> ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) a c.
(Monad m, Integral a) =>
a -> ConduitM 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitM ByteString Void (RIO env) SHA256
-> ZipSink ByteString (RIO env) SHA256
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Word -> ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) a c.
(Monad m, Integral a) =>
a -> ConduitM ByteString c m SHA256
sinkSHA256 Word
newSize)
                                                                             )
            Word
offset <-
              if SHA256
oldHash SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256
oldHashCheck
                then Word
oldSize Word -> RIO env () -> RIO env Word
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Updating preexisting cache, should be quick"
                else Word
0 Word -> RIO env () -> RIO env Word
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
                  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat [
                    Utf8Builder
"Package index change detected, that's pretty unusual: "
                    , Utf8Builder
"\n    Old size: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word
oldSize
                    , Utf8Builder
"\n    Old hash (orig) : " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
oldHash
                    , Utf8Builder
"\n    New hash (check): " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
oldHashCheck
                    , Utf8Builder
"\n    Forcing a recache"
                    ]
            (Word, SHA256, Word) -> RIO env (Word, SHA256, Word)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
offset, SHA256
newHash, Word
newSize)

      RIO env () -> ReaderT SqlBackend (RIO env) ()
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 -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Populating cache from file size " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word
newSize Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", hash " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
newHash
      Bool
-> ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
offset Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0) ReaderT SqlBackend (RIO env) ()
forall env. ReaderT SqlBackend (RIO env) ()
clearHackageRevisions
      Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
populateCache Path Abs File
tarball (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
offset) ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
        RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Failed populating package index cache")
      FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
forall env. FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
storeCacheUpdate (Word -> FileSize
FileSize Word
newSize) SHA256
newHash
    gateUpdate :: m b -> m DidUpdateOccur
gateUpdate m b
inner = do
      PantryConfig
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
pantryConfigL
      m (m DidUpdateOccur) -> m DidUpdateOccur
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m DidUpdateOccur) -> m DidUpdateOccur)
-> m (m DidUpdateOccur) -> m DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ MVar Bool
-> (Bool -> m (Bool, m DidUpdateOccur)) -> m (m DidUpdateOccur)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar (PantryConfig -> MVar Bool
pcUpdateRef PantryConfig
pc) ((Bool -> m (Bool, m DidUpdateOccur)) -> m (m DidUpdateOccur))
-> (Bool -> m (Bool, m DidUpdateOccur)) -> m (m DidUpdateOccur)
forall a b. (a -> b) -> a -> b
$ \Bool
toUpdate -> (Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur)
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m b
inner)
          else (Bool
False, DidUpdateOccur -> m DidUpdateOccur
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 :: 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 (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 ..."
  IORef Int
counter <- Int -> ReaderT SqlBackend (RIO env) (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
  Handle -> SeekMode -> Integer -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> SeekMode -> Integer -> m ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
  ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
-> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
 -> ReaderT SqlBackend (RIO env) ())
-> ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (ReaderT SqlBackend (RIO env)) ()
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ()
-> ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (FileInfo
 -> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ())
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untar (IORef Int
-> FileInfo
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ()
forall a env o.
(Integral a, HasLogFunc env, Display a) =>
IORef a
-> FileInfo
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
perFile IORef Int
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
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
                (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
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

                a
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
count a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
                IORef a
-> a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef a
counter a
count'
                Bool
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
count' a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
400 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0) (ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
 -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b. (a -> b) -> a -> b
$
                  ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
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
$ RIO env () -> ReaderT SqlBackend (RIO env) ()
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, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Processed " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
count' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" cabal files"
            | Bool
otherwise -> () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
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
          ByteString
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 ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
lbs of
            Left UnicodeException
_ -> () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
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 (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 (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 (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 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
      (BlobId
blobTableId, BlobKey
_blobKey) <- ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
bs

      PackageName -> Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName -> Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
storeHackageRevision PackageName
name Version
version BlobId
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
        (Text
name, Text
t2) <- Text -> Maybe (Text, Text)
breakSlash Text
t1
        (Text
version, Text
filename) <- Text -> Maybe (Text, Text)
breakSlash Text
t2

        a
name' <- FilePath -> Maybe a
forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse (FilePath -> Maybe a) -> FilePath -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
name
        b
version' <- FilePath -> Maybe b
forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse (FilePath -> Maybe b) -> FilePath -> Maybe b
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
version

        (a, b, Text) -> Maybe (a, b, Text)
forall a. a -> Maybe a
Just (a
name', b
version', Text
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
        Object
o2 <- Object
o1 Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"signed"
        Object Object
o3 <- Object
o2 Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"targets"
        Object Object
o4:[Value]
_ <- [Value] -> Parser [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value] -> Parser [Value]) -> [Value] -> Parser [Value]
forall a b. (a -> b) -> a -> b
$ Object -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Object
o3
        Word
len <- Object
o4 Object -> Text -> Parser Word
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"length"
        Object
hashes <- Object
o4 Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"hashes"
        Text
sha256' <- Object
hashes Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"sha256"
        SHA256
sha256 <-
          case Text -> Either SHA256Exception SHA256
SHA256.fromHexText Text
sha256' of
            Left SHA256Exception
e -> FilePath -> Parser SHA256
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 (m :: * -> *) a. Monad m => a -> m a
return SHA256
x
        PackageDownload -> Parser PackageDownload
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDownload -> Parser PackageDownload)
-> PackageDownload -> Parser PackageDownload
forall a b. (a -> b) -> a -> b
$ SHA256 -> Word -> PackageDownload
PackageDownload SHA256
sha256 Word
len

getHackageCabalFile
  :: (HasPantryConfig env, HasLogFunc env)
  => PackageIdentifierRevision
  -> RIO env ByteString
getHackageCabalFile :: PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
_ Version
_ CabalFileInfo
cfi) = do
  BlobId
bid <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
  ByteString
bs <- ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString)
-> ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ BlobId -> ReaderT SqlBackend (RIO env) ByteString
forall env. BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById BlobId
bid
  case CabalFileInfo
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

resolveCabalFileInfo
  :: (HasPantryConfig env, HasLogFunc env)
  => PackageIdentifierRevision
  -> RIO env BlobId
resolveCabalFileInfo :: PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
cfi) = do
  Maybe BlobId
mres <- RIO env (Maybe BlobId)
inner
  case Maybe BlobId
mres of
    Just BlobId
res -> BlobId -> RIO env BlobId
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
    Maybe BlobId
Nothing -> do
      DidUpdateOccur
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"
      Maybe BlobId
mres' <-
        case DidUpdateOccur
updated of
          DidUpdateOccur
UpdateOccurred -> RIO env (Maybe BlobId)
inner
          DidUpdateOccur
NoUpdateOccurred -> Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
      case Maybe BlobId
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 (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 (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 (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 (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 :: a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA a
label SHA256
sha256 Maybe FileSize
msize = do
  Maybe BlobId
mresult <- RIO env (Maybe BlobId)
byDB
  case Maybe BlobId
mresult of
    Maybe BlobId
Nothing -> do
      case Maybe FileSize
msize of
        Maybe FileSize
Nothing -> do
          Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
        Just FileSize
size -> do
          Maybe ByteString
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 Maybe ByteString
mblob of
            Maybe ByteString
Nothing -> do
              Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
            Just {} -> do
              Maybe BlobId
result <- RIO env (Maybe BlobId)
byDB
              case Maybe BlobId
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 (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 (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 (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 :: PackageName -> Version -> RIO env FuzzyResults
fuzzyLookupCandidates PackageName
name Version
ver0 = do
  Map Version (Map Revision BlobKey)
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 Version (Map Revision BlobKey) -> Bool
forall k a. Map k a -> Bool
Map.null Map Version (Map Revision BlobKey)
m
    then [PackageName] -> FuzzyResults
FRNameNotFound ([PackageName] -> FuzzyResults)
-> RIO env [PackageName] -> RIO env FuzzyResults
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> RIO env [PackageName]
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name
    else
      case Version
-> Map Version (Map Revision BlobKey)
-> Maybe (Map Revision BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Version
ver0 Map Version (Map Revision BlobKey)
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 (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 (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 :: 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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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
showList :: [UsePreferredVersions] -> FilePath -> FilePath
$cshowList :: [UsePreferredVersions] -> FilePath -> FilePath
show :: UsePreferredVersions -> FilePath
$cshow :: UsePreferredVersions -> FilePath
showsPrec :: Int -> UsePreferredVersions -> FilePath -> FilePath
$cshowsPrec :: Int -> 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
showList :: [RequireHackageIndex] -> FilePath -> FilePath
$cshowList :: [RequireHackageIndex] -> FilePath -> FilePath
show :: RequireHackageIndex -> FilePath
$cshow :: RequireHackageIndex -> FilePath
showsPrec :: Int -> RequireHackageIndex -> FilePath -> FilePath
$cshowsPrec :: Int -> RequireHackageIndex -> FilePath -> FilePath
Show

initializeIndex
  :: (HasPantryConfig env, HasLogFunc env)
  => RequireHackageIndex
  -> RIO env ()
initializeIndex :: RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
NoRequireHackageIndex = () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
initializeIndex RequireHackageIndex
YesRequireHackageIndex = do
  Int
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
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cabalCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RIO env DidUpdateOccur -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env DidUpdateOccur -> RIO env ())
-> RIO env DidUpdateOccur -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    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
"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 :: 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
    Maybe Text
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 (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
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
          Text
preferredT1 <- Maybe Text
mpreferred
          Text
preferredT2 <- Text -> Text -> Maybe Text
T.stripPrefix (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
name) Text
preferredT1
          VersionRange
vr <- FilePath -> Maybe VersionRange
forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse (FilePath -> Maybe VersionRange) -> FilePath -> Maybe VersionRange
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
preferredT2
          (Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
forall a. a -> Maybe a
Just ((Version -> Map Revision BlobKey -> Bool)
 -> Maybe (Version -> Map Revision BlobKey -> Bool))
-> (Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
forall a b. (a -> b) -> a -> b
$ \Version
v Map Revision BlobKey
_ -> Version -> VersionRange -> Bool
withinRange Version
v VersionRange
vr
    (Version -> Map Revision BlobKey -> Bool)
-> Map Version (Map Revision BlobKey)
-> Map Version (Map Revision BlobKey)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Version -> Map Revision BlobKey -> Bool
predicate (Map Version (Map Revision BlobKey)
 -> Map Version (Map Revision BlobKey))
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
forall env.
PackageName
-> ReaderT
     SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
loadHackagePackageVersions PackageName
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 :: 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 :: RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
withCachedTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid RIO env HackageTarballResult
inner = do
  Maybe Package
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 Maybe Package
mres of
    Just Package
package -> HackageTarballResult -> RIO env HackageTarballResult
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
      HackageTarballResult
htr <- RIO env HackageTarballResult
inner
      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
$
        PackageName
-> Version -> BlobId -> TreeKey -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName
-> Version -> BlobId -> TreeKey -> ReaderT SqlBackend (RIO env) ()
storeHackageTree PackageName
name Version
ver BlobId
bid (TreeKey -> ReaderT SqlBackend (RIO env) ())
-> TreeKey -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Package -> TreeKey
packageTreeKey (Package -> TreeKey) -> Package -> TreeKey
forall a b. (a -> b) -> a -> b
$ HackageTarballResult -> Package
htrPackage HackageTarballResult
htr
      HackageTarballResult -> RIO env HackageTarballResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageTarballResult
htr

getHackageTarballKey
  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageIdentifierRevision
  -> RIO env TreeKey
getHackageTarballKey :: PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
name Version
ver (CFIHash SHA256
sha Maybe FileSize
_msize)) = do
  Maybe TreeKey
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 Maybe TreeKey
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 (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 :: PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
mtreeKey = do
  let PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
_cfi = PackageIdentifierRevision
pir
  BlobId
cabalFile <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
  let rpli :: RawPackageLocationImmutable
rpli = PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtreeKey
  RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
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
cabalFile (RIO env HackageTarballResult -> RIO env HackageTarballResult)
-> RIO env HackageTarballResult -> RIO env HackageTarballResult
forall a b. (a -> b) -> a -> b
$ do
    BlobKey
cabalFileKey <- ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey)
-> ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
forall a b. (a -> b) -> a -> b
$ BlobId -> ReaderT SqlBackend (RIO env) BlobKey
forall env. BlobId -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey BlobId
cabalFile
    Maybe (SHA256, FileSize)
mpair <- 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
    (SHA256
sha, FileSize
size) <-
      case Maybe (SHA256, FileSize)
mpair of
        Just (SHA256, FileSize)
pair -> (SHA256, FileSize) -> RIO env (SHA256, FileSize)
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
          DidUpdateOccur
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"
          Maybe (SHA256, FileSize)
mpair2 <-
            case DidUpdateOccur
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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SHA256, FileSize)
forall a. Maybe a
Nothing
          case Maybe (SHA256, FileSize)
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 (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize)
pair2
    PantryConfig
pc <- Getting PantryConfig env PantryConfig -> RIO env PantryConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PantryConfig env PantryConfig
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
    let urlPrefix :: Text
urlPrefix = HackageSecurityConfig -> Text
hscDownloadPrefix (HackageSecurityConfig -> Text) -> HackageSecurityConfig -> Text
forall a b. (a -> b) -> a -> b
$ PantryConfig -> HackageSecurityConfig
pcHackageSecurity PantryConfig
pc
        url :: Text
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"
            ]
    (SHA256
_, FileSize
_, Package
package, CachedTree
cachedTree) <-
      RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive
        RawPackageLocationImmutable
rpli
        RawArchive :: ArchiveLocation
-> Maybe SHA256 -> Maybe FileSize -> Text -> RawArchive
RawArchive
          { raLocation :: ArchiveLocation
raLocation = Text -> ArchiveLocation
ALUrl Text
url
          , raHash :: Maybe SHA256
raHash = SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
sha
          , raSize :: Maybe FileSize
raSize = FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size
          , raSubdir :: Text
raSubdir = Text
T.empty -- no subdirs on Hackage
          }
        RawPackageMetadata :: Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata
          { rpmName :: Maybe PackageName
rpmName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name
          , rpmVersion :: Maybe Version
rpmVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
ver
          , rpmTreeKey :: Maybe TreeKey
rpmTreeKey = Maybe TreeKey
forall a. Maybe a
Nothing -- with a revision cabal file will differ giving a different tree
          }
    case CachedTree
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
        (ByteString
cabalBS, BlobId
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
            Maybe BlobId
mcabalBS <- SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
forall env. SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA SHA256
sha'
            case Maybe BlobId
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' :: CachedTree
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 :: PackageIdentifier
ident = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
ver
        ([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
rpli) ByteString
cabalBS
        let gpdIdent :: PackageIdentifier
gpdIdent = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageIdentifier
gpdIdent) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          PackageIdentifierRevision
-> Mismatch PackageIdentifier -> PantryException
MismatchedCabalFileForHackage
            PackageIdentifierRevision
pir
            Mismatch :: forall a. a -> a -> Mismatch a
Mismatch {mismatchExpected :: PackageIdentifier
mismatchExpected = PackageIdentifier
ident, mismatchActual :: PackageIdentifier
mismatchActual = PackageIdentifier
gpdIdent}
        (TreeId
tid, TreeKey
treeKey') <-
          ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
 -> RIO env (TreeId, TreeKey))
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey)
forall a b. (a -> b) -> a -> b
$
          RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree RawPackageLocationImmutable
rpli PackageIdentifier
ident CachedTree
tree' (SafeFilePath -> TreeEntry -> BuildFile
BFCabal (PackageName -> SafeFilePath
cabalFileName PackageName
name) TreeEntry
cabalEntry)
        HackageTarballResult -> RIO env HackageTarballResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          HackageTarballResult :: Package
-> Maybe (GenericPackageDescription, TreeId)
-> HackageTarballResult
HackageTarballResult
            { htrPackage :: Package
htrPackage =
                Package :: TreeKey -> Tree -> PackageCabal -> PackageIdentifier -> Package
Package
                  { packageTreeKey :: TreeKey
packageTreeKey = TreeKey
treeKey'
                  , packageTree :: Tree
packageTree = CachedTree -> Tree
unCachedTree CachedTree
tree'
                  , packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
ident
                  , packageCabalEntry :: PackageCabal
packageCabalEntry = TreeEntry -> PackageCabal
PCCabalFile TreeEntry
cabalEntry
                  }
            , htrFreshPackageInfo :: Maybe (GenericPackageDescription, TreeId)
htrFreshPackageInfo = (GenericPackageDescription, TreeId)
-> Maybe (GenericPackageDescription, TreeId)
forall a. a -> Maybe a
Just (GenericPackageDescription
gpd, TreeId
tid)
            }