{-# 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)
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)
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'
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)
data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred
data HackageTarballResult = HackageTarballResult
{ HackageTarballResult -> Package
htrPackage :: !Package
, HackageTarballResult -> Maybe (GenericPackageDescription, TreeId)
htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId))
}
updateHackageIndex ::
(HasPantryConfig env, HasLogFunc env)
=> Maybe Utf8Builder
-> 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
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
-> Maybe Utf8Builder
-> 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
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
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
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
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
(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)
populateCache ::
(HasPantryConfig env, HasLogFunc env)
=> Path Abs File
-> Integer
-> 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 ()
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)
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)
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
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]
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)
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
data RequireHackageIndex
= YesRequireHackageIndex
| NoRequireHackageIndex
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"
getHackagePackageVersions ::
(HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> 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
getHackagePackageVersionRevisions ::
(HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> PackageName
-> 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
-> 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
}
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
}
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)
}