{-# LANGUAGE CPP #-}
{-# 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)
#if !MIN_VERSION_rio(0,1,16)
-- Now provided by RIO from the rio package. Resolvers before lts-15.16

-- (GHC 8.8.3) had rio < 0.1.16.

import System.IO (SeekMode (..))
#endif
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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> a
impureThrow forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir FilePath
"hackage"

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

indexRelFile :: Path Rel File
indexRelFile :: Path Rel File
indexRelFile = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> a
impureThrow forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ 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 :: forall env. HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL = forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
indexRelFile)

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

--

-- @since 0.1.0.0

data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred


-- | Information returned by `getHackageTarball`

--

-- @since 0.1.0.0

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

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

  }

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

-- update the database tables.

--

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

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

--

-- @since 0.1.0.0

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

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

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

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

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

--

-- @since 0.1.0.0

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


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

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

  -> RIO env DidUpdateOccur
updateHackageIndexInternal :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndexInternal Bool
forceUpdate Maybe Utf8Builder
mreason = do
  Storage
storage <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Storage
pcStorage
  forall {m :: * -> *} {s} {b}.
(MonadReader s m, HasPantryConfig s, MonadUnliftIO m) =>
m b -> m DidUpdateOccur
gateUpdate forall a b. (a -> b) -> a -> b
$ Storage -> forall env a. HasLogFunc env => RIO env a -> RIO env a
withWriteLock_ Storage
storage forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Utf8Builder
mreason forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
    PantryConfig
pc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
    let PackageIndexConfig Text
url (HackageSecurityConfig [Text]
keyIds Int
threshold Bool
ignoreExpiry) = PantryConfig -> PackageIndexConfig
pcPackageIndex PantryConfig
pc
    Path Abs Dir
root <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirL
    Path Abs File
tarball <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL
    URI
baseURI <-
        case FilePath -> Maybe URI
parseURI forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
url of
            Maybe URI
Nothing -> forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid Hackage Security base URL: " forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
url
            Just URI
x -> forall (m :: * -> *) a. Monad m => a -> m a
return URI
x
    RIO env () -> IO ()
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    let logTUF :: LogMessage -> IO ()
logTUF = RIO env () -> IO ()
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> FilePath
HS.pretty
        withRepo :: (Repository RemoteTemp -> IO a) -> IO a
withRepo = forall a.
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
HS.withRepository
            HttpLib
HS.httpLib
            [URI
baseURI]
            RepoOpts
HS.defaultRepoOpts
            HS.Cache
                { cacheRoot :: Path Absolute
HS.cacheRoot = FilePath -> Path Absolute
HS.fromAbsoluteFilePath forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {a}. (Repository RemoteTemp -> IO a) -> IO a
withRepo forall a b. (a -> b) -> a -> b
$ \Repository RemoteTemp
repo -> forall a.
((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO a)
-> IO a
HS.uncheckClientErrors forall a b. (a -> b) -> a -> b
$ do
        Bool
needBootstrap <- forall (down :: * -> *). Repository down -> IO Bool
HS.requiresBootstrap Repository RemoteTemp
repo
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBootstrap forall a b. (a -> b) -> a -> b
$ do
            forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError) =>
Repository down -> [KeyId] -> KeyThreshold -> IO ()
HS.bootstrap
                Repository RemoteTemp
repo
                (forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> KeyId
HS.KeyId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) [Text]
keyIds)
                (Int54 -> KeyThreshold
HS.KeyThreshold forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
threshold)
        Maybe UTCTime
maybeNow <- if Bool
ignoreExpiry
                      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                      else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
        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
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Forced package update is initialized"
            forall {env}.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
      HasUpdates
HS.NoUpdates -> do
        Bool
x <- forall {env} {b} {t}.
(HasPantryConfig env, HasLogFunc env) =>
Path b t -> RIO env Bool
needsCacheUpdate Path Abs File
tarball
        if Bool
x
          then do
            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"
            forall {env}.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
          else 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
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Updated package index downloaded"
        forall {env}.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
    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 :: forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize Handle
h = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
max Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Integer
1024) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate
      case Maybe (FileSize, SHA256)
mres of
        Maybe (FileSize, SHA256)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        Just (FileSize Word
cachedSize, SHA256
_sha256) -> do
          Word
actualSize <- forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (forall b t. Path b t -> FilePath
toFilePath Path b t
tarball) IOMode
ReadMode forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word
cachedSize 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 = forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage 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 <- forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate
      (Word
offset, SHA256
newHash, Word
newSize) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (forall b t. Path b t -> FilePath
toFilePath Path Abs File
tarball) IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
        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 <- forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize Handle
h
        let sinkSHA256 :: a -> ConduitT ByteString c m SHA256
sinkSHA256 a
len = forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len) forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash

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

      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Populating cache from file size " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Word
newSize forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", hash " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
newHash
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
offset forall a. Eq a => a -> a -> Bool
== Word
0) forall env. ReaderT SqlBackend (RIO env) ()
clearHackageRevisions
      forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
populateCache Path Abs File
tarball (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
offset) forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Failed populating package index cache")
      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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
      forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar (PantryConfig -> MVar Bool
pcUpdateRef PantryConfig
pc) forall a b. (a -> b) -> a -> b
$ \Bool
toUpdate -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        if Bool
toUpdate
          then (Bool
False, DidUpdateOccur
UpdateOccurred forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m b
inner)
          else (Bool
False, forall (f :: * -> *) a. Applicative f => a -> f a
pure DidUpdateOccur
NoUpdateOccurred)

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

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

  -> Integer -- ^ where to start processing from

  -> ReaderT SqlBackend (RIO env) ()
populateCache :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
populateCache Path Abs File
fp Integer
offset = forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (forall b t. Path b t -> FilePath
toFilePath Path Abs File
fp) IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Populating package index cache ..."
  IORef Int
counter <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
  forall (m :: * -> *).
MonadIO m =>
Handle -> SeekMode -> Integer -> m ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
  forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untar (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' forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
      , Just (PackageName
name, Version
version, Text
filename) <- forall {a} {b}. (Parsec a, Parsec b) => Text -> Maybe (a, b, Text)
parseNameVersionSuffix Text
path =
          if
            | Text
filename forall a. Eq a => a -> a -> Bool
== Text
"package.json" ->
                forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {env}.
HasLogFunc env =>
PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addJSON PackageName
name Version
version
            | Text
filename forall a. Eq a => a -> a -> Bool
== SafeFilePath -> Text
unSafeFilePath (PackageName -> SafeFilePath
cabalFileName PackageName
name) -> do
                (ByteString -> ByteString
BL.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {env}.
PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addCabal PackageName
name Version
version

                a
count <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
counter
                let count' :: a
count' = a
count forall a. Num a => a -> a -> a
+ a
1
                forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef a
counter a
count'
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
count' forall a. Integral a => a -> a -> a
`mod` a
400 forall a. Eq a => a -> a -> Bool
== a
0) forall a b. (a -> b) -> a -> b
$
                  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Processed " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display a
count' forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" cabal files"
            | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | FileType
FTNormal <- FileInfo -> FileType
fileType FileInfo
fi
      , Right Text
path <- ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
      , (Text
nameT, Text
"/preferred-versions") <- (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
path
      , Just PackageName
name <- FilePath -> Maybe PackageName
parsePackageName forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
nameT = do
          ByteString
lbs <- forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
          case ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
lbs of
            Left UnicodeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- maybe warning

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

      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 = forall a. Maybe a
Nothing
        | Bool
otherwise = 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 (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' <- forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
name
        b
version' <- forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
version

        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 = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"PackageDownload" forall a b. (a -> b) -> a -> b
$ \Object
o1 -> do
        Object
o2 <- Object
o1 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"signed"
        Object Object
o3 <- Object
o2 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"targets"
        Object Object
o4:[Value]
_ <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Object
o3
        Word
len <- Object
o4 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"length"
        Object
hashes <- Object
o4 forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"hashes"
        Text
sha256' <- Object
hashes forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"sha256"
        SHA256
sha256 <-
          case Text -> Either SHA256Exception SHA256
SHA256.fromHexText Text
sha256' of
            Left SHA256Exception
e -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid sha256: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show SHA256Exception
e
            Right SHA256
x -> forall (m :: * -> *) a. Monad m => a -> m a
return SHA256
x
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
_ Version
_ CabalFileInfo
cfi) = do
  BlobId
bid <- forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
  ByteString
bs <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) forall a. Eq a => a -> a -> Bool
/= FileSize
size
          shaMismatch :: Bool
shaMismatch = SHA256
sha forall a. Eq a => a -> a -> Bool
/= ByteString -> SHA256
SHA256.hashBytes ByteString
bs
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sizeMismatch Bool -> Bool -> Bool
|| Bool
shaMismatch)
        forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"getHackageCabalFile: size or SHA mismatch for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (PackageIdentifierRevision
pir, ByteString
bs)
    CabalFileInfo
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs

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

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

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

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

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

-- in the caches.

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

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

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

-- using Hackage package names. This can provide more user-friendly

-- information in error messages.

--

-- @since 0.1.0.0

getHackageTypoCorrections
  :: (HasPantryConfig env, HasLogFunc env)
  => PackageName
  -> RIO env [PackageName]
getHackageTypoCorrections :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name1 =
    forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> a -> Bool
< Int
4)
      (forall (m :: * -> *) a. Monad m => Int -> ConduitT a a m ()
takeC Int
10 forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList)
    where
      distance :: PackageName -> PackageName -> Int
distance = Text -> Text -> Int
damerauLevenshtein forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FilePath -> Text
T.pack 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 -> ShowS
[UsePreferredVersions] -> ShowS
UsePreferredVersions -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [UsePreferredVersions] -> ShowS
$cshowList :: [UsePreferredVersions] -> ShowS
show :: UsePreferredVersions -> FilePath
$cshow :: UsePreferredVersions -> FilePath
showsPrec :: Int -> UsePreferredVersions -> ShowS
$cshowsPrec :: Int -> UsePreferredVersions -> ShowS
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 -> ShowS
[RequireHackageIndex] -> ShowS
RequireHackageIndex -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RequireHackageIndex] -> ShowS
$cshowList :: [RequireHackageIndex] -> ShowS
show :: RequireHackageIndex -> FilePath
$cshow :: RequireHackageIndex -> FilePath
showsPrec :: Int -> RequireHackageIndex -> ShowS
$cshowsPrec :: Int -> RequireHackageIndex -> ShowS
Show

initializeIndex
  :: (HasPantryConfig env, HasLogFunc env)
  => RequireHackageIndex
  -> RIO env ()
initializeIndex :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
NoRequireHackageIndex = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
initializeIndex RequireHackageIndex
YesRequireHackageIndex = do
  Int
cabalCount <- forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall env. ReaderT SqlBackend (RIO env) Int
countHackageCabals
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cabalCount forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
usePreferred PackageName
name = do
  forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
req
  forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
    Maybe Text
mpreferred <-
      case UsePreferredVersions
usePreferred of
        UsePreferredVersions
UsePreferredVersions -> forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
loadPreferredVersion PackageName
name
        UsePreferredVersions
IgnorePreferredVersions -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    let predicate :: Version -> Map Revision BlobKey -> Bool
        predicate :: Version -> Map Revision BlobKey -> Bool
predicate = forall a. a -> Maybe a -> a
fromMaybe (\Version
_ Map Revision BlobKey
_ -> Bool
True) 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 forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
name) Text
preferredT1
          VersionRange
vr <- forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
preferredT2
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \Version
v Map Revision BlobKey
_ -> Version -> VersionRange -> Bool
withinRange Version
v VersionRange
vr
    forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Version -> Map Revision BlobKey -> Bool
predicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version = do
  forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
req
  forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$
    forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
version

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

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

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

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

          }
        RawPackageMetadata
          { rpmName :: Maybe PackageName
rpmName = forall a. a -> Maybe a
Just PackageName
name
          , rpmVersion :: Maybe Version
rpmVersion = forall a. a -> Maybe a
Just Version
ver
          , rpmTreeKey :: Maybe TreeKey
rpmTreeKey = 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
_ -> 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) <-
          forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$ do
            let BlobKey SHA256
sha' FileSize
_ = BlobKey
cabalFileKey
            Maybe BlobId
mcabalBS <- forall env. SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA SHA256
sha'
            case Maybe BlobId
mcabalBS of
              Maybe BlobId
Nothing ->
                forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$
                FilePath
"Invariant violated, cabal file key: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show BlobKey
cabalFileKey
              Just BlobId
bid -> (, BlobId
bid) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById BlobId
bid
        let tree' :: CachedTree
tree' = Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
CachedTreeMap forall a b. (a -> b) -> a -> b
$ 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) <- forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (forall a b. a -> Either a b
Left RawPackageLocationImmutable
rpli) ByteString
cabalBS
        let gpdIdent :: PackageIdentifier
gpdIdent = PackageDescription -> PackageIdentifier
Cabal.package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
/= PackageIdentifier
gpdIdent) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
          PackageIdentifierRevision
-> Mismatch PackageIdentifier -> PantryException
MismatchedCabalFileForHackage
            PackageIdentifierRevision
pir
            Mismatch {mismatchExpected :: PackageIdentifier
mismatchExpected = PackageIdentifier
ident, mismatchActual :: PackageIdentifier
mismatchActual = PackageIdentifier
gpdIdent}
        (TreeId
tid, TreeKey
treeKey') <-
          forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage forall a b. (a -> b) -> a -> b
$
          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)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          HackageTarballResult
            { htrPackage :: Package
htrPackage =
                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 = forall a. a -> Maybe a
Just (GenericPackageDescription
gpd, TreeId
tid)
            }