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

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

import           Conduit
import           Data.Aeson
import           Data.Conduit.Tar
import qualified Data.List.NonEmpty as NE
import           Data.Text.Metrics (damerauLevenshtein)
import           Data.Text.Unsafe ( unsafeTail )
import           Data.Time ( getCurrentTime )
import           Distribution.PackageDescription ( GenericPackageDescription )
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.Text
import           Distribution.Types.Version (versionNumbers)
import           Distribution.Types.VersionRange (withinRange)
import qualified Hackage.Security.Client as HS
import qualified Hackage.Security.Client.Repository.Cache as HS
import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS
import qualified Hackage.Security.Client.Repository.Remote as HS
import qualified Hackage.Security.Util.Path as HS
import qualified Hackage.Security.Util.Pretty as HS
import           Network.URI ( parseURI )
import           Pantry.Archive
import           Pantry.Casa
import qualified Pantry.SHA256 as SHA256
import           Pantry.Storage hiding
                   ( PackageName, TreeEntry, Version, findOrGenerateCabalFile )
import           Pantry.Tree
import           Pantry.Types hiding ( FileType (..) )
import           Path
                   ( Abs, Dir, File, Path, Rel, (</>), parseRelDir, parseRelFile
                   , toFilePath
                   )
import           RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import qualified RIO.Map as Map
import           RIO.Process
import qualified RIO.Text as T
#if !MIN_VERSION_rio(0,1,16)
-- Now provided by RIO from the rio package. Resolvers before lts-15.16

-- (GHC 8.8.3) had rio < 0.1.16.

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

hackageRelDir :: Path Rel Dir
hackageRelDir :: Path Rel Dir
hackageRelDir = 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
              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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict
              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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 (f :: * -> *) a. Applicative f => a -> f a
pure SHA256
x
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 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)
            }