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

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

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

-- (GHC 8.8.3) had rio < 0.1.16.

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

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

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

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

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

-- layout of the local cache.

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

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

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred


-- | Information returned by `getHackageTarball`

--

-- @since 0.1.0.0

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

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

    -- into pantry.

  }

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

-- database tables.

--

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

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

--

-- @since 0.1.0.0

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

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

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

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

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

--

-- @since 0.1.0.0

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


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

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

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

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

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

  -- updates.

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

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

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

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

  -- updateCache call.

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

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

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

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

  -- action.

  --

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

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

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

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

    --

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

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

    -- when that happens.

    --

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

    -- under us.

    --

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

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

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

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

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

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

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

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

          -- us what we cached already. Compare against

          -- oldHashCheck, which assuming the tarball has not been

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

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

          -- content as well.

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

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

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

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

  -> Integer -- ^ where to start processing from

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

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

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

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

    PackageName -> Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName -> Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
storeHackageRevision PackageName
name Version
version BlobId
blobTableId

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

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

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

    (a, b, Text) -> Maybe (a, b, Text)
forall a. a -> Maybe a
Just (a
name', b
version', Text
filename)

-- | Package download info from Hackage

data PackageDownload = PackageDownload !SHA256 !Word

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

getHackageCabalFile ::
     (HasPantryConfig env, HasLogFunc env)
  => PackageIdentifierRevision
  -> RIO env ByteString
getHackageCabalFile :: forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
_ Version
_ CabalFileInfo
cfi) = do
  BlobId
bid <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
  ByteString
bs <- ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString)
-> ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ BlobId -> ReaderT SqlBackend (RIO env) ByteString
forall env. BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById BlobId
bid
  case CabalFileInfo
cfi of
    CFIHash SHA256
sha Maybe FileSize
msize -> do
      let sizeMismatch :: Bool
sizeMismatch =
            case Maybe FileSize
msize of
              Maybe FileSize
Nothing -> Bool
False
              Just FileSize
size -> Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSize
size
          shaMismatch :: Bool
shaMismatch = SHA256
sha SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> SHA256
SHA256.hashBytes ByteString
bs
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sizeMismatch Bool -> Bool -> Bool
|| Bool
shaMismatch)
        (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> RIO env ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath
"getHackageCabalFile: size or SHA mismatch for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (PackageIdentifierRevision, ByteString) -> FilePath
forall a. Show a => a -> FilePath
show (PackageIdentifierRevision
pir, ByteString
bs)
    CabalFileInfo
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ByteString -> RIO env ByteString
forall a. a -> RIO env a
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 -> BlobId -> RIO env BlobId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
    Maybe BlobId
Nothing -> do
      DidUpdateOccur
updated <- Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just
        (Utf8Builder -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$  Utf8Builder
"Cabal file info not found for "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
      Maybe BlobId
mres' <-
        case DidUpdateOccur
updated of
          DidUpdateOccur
UpdateOccurred -> RIO env (Maybe BlobId)
inner
          DidUpdateOccur
NoUpdateOccurred -> Maybe BlobId -> RIO env (Maybe BlobId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
      case Maybe BlobId
mres' of
        Maybe BlobId
Nothing -> PackageName -> Version -> RIO env FuzzyResults
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> Version -> RIO env FuzzyResults
fuzzyLookupCandidates PackageName
name Version
ver RIO env FuzzyResults
-> (FuzzyResults -> RIO env BlobId) -> RIO env BlobId
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PantryException -> RIO env BlobId
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env BlobId)
-> (FuzzyResults -> PantryException)
-> FuzzyResults
-> RIO env BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifierRevision -> FuzzyResults -> PantryException
UnknownHackagePackage PackageIdentifierRevision
pir
        Just BlobId
res -> BlobId -> RIO env BlobId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
 where
  inner :: RIO env (Maybe BlobId)
inner =
    case CabalFileInfo
cfi of
      CFIHash SHA256
sha Maybe FileSize
msize -> PackageIdentifierRevision
-> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
forall a env.
(Display a, HasPantryConfig env, HasLogFunc env) =>
a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA PackageIdentifierRevision
pir SHA256
sha Maybe FileSize
msize
      CFIRevision Revision
rev ->
        ((BlobId, BlobKey) -> BlobId)
-> Maybe (BlobId, BlobKey) -> Maybe BlobId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlobId, BlobKey) -> BlobId
forall a b. (a, b) -> a
fst (Maybe (BlobId, BlobKey) -> Maybe BlobId)
-> (Map Revision (BlobId, BlobKey) -> Maybe (BlobId, BlobKey))
-> Map Revision (BlobId, BlobKey)
-> Maybe BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Revision
-> Map Revision (BlobId, BlobKey) -> Maybe (BlobId, BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Revision
rev (Map Revision (BlobId, BlobKey) -> Maybe BlobId)
-> RIO env (Map Revision (BlobId, BlobKey))
-> RIO env (Maybe BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> RIO env (Map Revision (BlobId, BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
ver)
      CabalFileInfo
CFILatest ->
        (((BlobId, BlobKey), Map Revision (BlobId, BlobKey)) -> BlobId)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> Maybe BlobId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlobId, BlobKey) -> BlobId
forall a b. (a, b) -> a
fst ((BlobId, BlobKey) -> BlobId)
-> (((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
    -> (BlobId, BlobKey))
-> ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> (BlobId, BlobKey)
forall a b. (a, b) -> a
fst) (Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
 -> Maybe BlobId)
-> (Map Revision (BlobId, BlobKey)
    -> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey)))
-> Map Revision (BlobId, BlobKey)
-> Maybe BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Revision (BlobId, BlobKey)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView (Map Revision (BlobId, BlobKey) -> Maybe BlobId)
-> RIO env (Map Revision (BlobId, BlobKey))
-> RIO env (Maybe BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> RIO env (Map Revision (BlobId, BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
ver)

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

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

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

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

-- caches.

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

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

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

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

-- error messages.

--

-- @since 0.1.0.0

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

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

--

-- @since 0.1.0.0

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

-- | Require that the Hackage index is populated.

--

-- @since 0.1.0.0

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

  | NoRequireHackageIndex
    -- ^ Do not perform an update

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

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

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

--

-- @since 0.1.0.0

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

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

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

--

-- @since 0.1.0.0

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

  -> Version -- ^ package version

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

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

  -> RIO env HackageTarballResult
  -> RIO env HackageTarballResult
withCachedTree :: forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
withCachedTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid RIO env HackageTarballResult
inner = do
  Maybe Package
mres <- ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe Package)
 -> RIO env (Maybe Package))
-> ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
loadHackageTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid
  case Maybe Package
mres of
    Just Package
package -> HackageTarballResult -> RIO env HackageTarballResult
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageTarballResult -> RIO env HackageTarballResult)
-> HackageTarballResult -> RIO env HackageTarballResult
forall a b. (a -> b) -> a -> b
$ Package
-> Maybe (GenericPackageDescription, TreeId)
-> HackageTarballResult
HackageTarballResult Package
package Maybe (GenericPackageDescription, TreeId)
forall a. Maybe a
Nothing
    Maybe Package
Nothing -> do
      HackageTarballResult
htr <- RIO env HackageTarballResult
inner
      ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        PackageName
-> Version -> BlobId -> TreeKey -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName
-> Version -> BlobId -> TreeKey -> ReaderT SqlBackend (RIO env) ()
storeHackageTree PackageName
name Version
ver BlobId
bid (TreeKey -> ReaderT SqlBackend (RIO env) ())
-> TreeKey -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Package -> TreeKey
packageTreeKey (Package -> TreeKey) -> Package -> TreeKey
forall a b. (a -> b) -> a -> b
$ HackageTarballResult -> Package
htrPackage HackageTarballResult
htr
      HackageTarballResult -> RIO env HackageTarballResult
forall a. a -> RIO env a
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 <- ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe TreeKey)
 -> RIO env (Maybe TreeKey))
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey)
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
forall env.
PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
loadHackageTreeKey PackageName
name Version
ver SHA256
sha
  case Maybe TreeKey
mres of
    Maybe TreeKey
Nothing -> Package -> TreeKey
packageTreeKey (Package -> TreeKey)
-> (HackageTarballResult -> Package)
-> HackageTarballResult
-> TreeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageTarballResult -> Package
htrPackage (HackageTarballResult -> TreeKey)
-> RIO env HackageTarballResult -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing
    Just TreeKey
key -> TreeKey -> RIO env TreeKey
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
key
getHackageTarballKey PackageIdentifierRevision
pir =
  Package -> TreeKey
packageTreeKey (Package -> TreeKey)
-> (HackageTarballResult -> Package)
-> HackageTarballResult
-> TreeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageTarballResult -> Package
htrPackage (HackageTarballResult -> TreeKey)
-> RIO env HackageTarballResult -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing

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

          }
        RawPackageMetadata
          { rpmName :: Maybe PackageName
rpmName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name
          , rpmVersion :: Maybe Version
rpmVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
ver
          , rpmTreeKey :: Maybe TreeKey
rpmTreeKey = Maybe TreeKey
forall a. Maybe a
Nothing -- with a revision cabal file will differ

                                 -- giving a different tree

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