{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Pantry.Hackage
( updateHackageIndex
, forceUpdateHackageIndex
, DidUpdateOccur (..)
, RequireHackageIndex (..)
, hackageIndexTarballL
, getHackageTarball
, getHackageTarballKey
, getHackageCabalFile
, getHackagePackageVersions
, getHackagePackageVersionRevisions
, getHackageTypoCorrections
, UsePreferredVersions (..)
, HackageTarballResult(..)
) where
import RIO
import RIO.Process
import Pantry.Casa
import Data.Aeson
import Conduit
import Data.Conduit.Tar
import qualified RIO.Text as T
import qualified RIO.Map as Map
import Data.Text.Unsafe (unsafeTail)
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import Pantry.Archive
import Pantry.Types hiding (FileType (..))
import Pantry.Storage hiding (TreeEntry, PackageName, Version)
import Pantry.Tree
import qualified Pantry.SHA256 as SHA256
import Network.URI (parseURI)
import Data.Time (getCurrentTime)
import Path ((</>), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile)
import qualified Distribution.Text
import qualified Distribution.PackageDescription as Cabal
import qualified Data.List.NonEmpty as NE
import Data.Text.Metrics (damerauLevenshtein)
import System.IO (SeekMode (..))
import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.Types.Version (versionNumbers)
import Distribution.Types.VersionRange (withinRange)
import qualified Hackage.Security.Client as HS
import qualified Hackage.Security.Client.Repository.Cache as HS
import qualified Hackage.Security.Client.Repository.Remote as HS
import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS
import qualified Hackage.Security.Util.Path as HS
import qualified Hackage.Security.Util.Pretty as HS
hackageRelDir :: Path Rel Dir
hackageRelDir :: Path Rel Dir
hackageRelDir = (SomeException -> Path Rel Dir)
-> (Path Rel Dir -> Path Rel Dir)
-> Either SomeException (Path Rel Dir)
-> Path Rel Dir
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Path Rel Dir
forall e a. Exception e => e -> a
impureThrow Path Rel Dir -> Path Rel Dir
forall a. a -> a
id (Either SomeException (Path Rel Dir) -> Path Rel Dir)
-> Either SomeException (Path Rel Dir) -> Path Rel Dir
forall a b. (a -> b) -> a -> b
$ FilePath -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel Dir)
parseRelDir FilePath
"hackage"
hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirL :: SimpleGetter env (Path Abs Dir)
hackageDirL = (PantryConfig -> Const r PantryConfig) -> env -> Const r env
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const r PantryConfig) -> env -> Const r env)
-> ((Path Abs Dir -> Const r (Path Abs Dir))
-> PantryConfig -> Const r PantryConfig)
-> (Path Abs Dir -> Const r (Path Abs Dir))
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Path Abs Dir)
-> SimpleGetter PantryConfig (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to ((Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
hackageRelDir) (Path Abs Dir -> Path Abs Dir)
-> (PantryConfig -> Path Abs Dir) -> PantryConfig -> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PantryConfig -> Path Abs Dir
pcRootDir)
indexRelFile :: Path Rel File
indexRelFile :: Path Rel File
indexRelFile = (SomeException -> Path Rel File)
-> (Path Rel File -> Path Rel File)
-> Either SomeException (Path Rel File)
-> Path Rel File
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Path Rel File
forall e a. Exception e => e -> a
impureThrow Path Rel File -> Path Rel File
forall a. a -> a
id (Either SomeException (Path Rel File) -> Path Rel File)
-> Either SomeException (Path Rel File) -> Path Rel File
forall a b. (a -> b) -> a -> b
$ FilePath -> Either SomeException (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
"00-index.tar"
hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL :: SimpleGetter env (Path Abs File)
hackageIndexTarballL = Getting r env (Path Abs Dir)
forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirLGetting r env (Path Abs Dir)
-> ((Path Abs File -> Const r (Path Abs File))
-> Path Abs Dir -> Const r (Path Abs Dir))
-> (Path Abs File -> Const r (Path Abs File))
-> env
-> Const r env
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Path Abs Dir -> Path Abs File)
-> SimpleGetter (Path Abs Dir) (Path Abs File)
forall s a. (s -> a) -> SimpleGetter s a
to (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
indexRelFile)
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 :: 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 :: 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 :: Bool -> Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndexInternal Bool
forceUpdate Maybe Utf8Builder
mreason = do
Storage
storage <- Getting Storage env Storage -> RIO env Storage
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Storage env Storage -> RIO env Storage)
-> Getting Storage env Storage -> RIO env Storage
forall a b. (a -> b) -> a -> b
$ (PantryConfig -> Const Storage PantryConfig)
-> env -> Const Storage env
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL((PantryConfig -> Const Storage PantryConfig)
-> env -> Const Storage env)
-> ((Storage -> Const Storage Storage)
-> PantryConfig -> Const Storage PantryConfig)
-> Getting Storage env Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PantryConfig -> Storage) -> SimpleGetter PantryConfig Storage
forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Storage
pcStorage
RIO env () -> RIO env DidUpdateOccur
forall (m :: * -> *) s b.
(MonadReader s m, HasPantryConfig s, MonadUnliftIO m) =>
m b -> m DidUpdateOccur
gateUpdate (RIO env () -> RIO env DidUpdateOccur)
-> RIO env () -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Storage -> forall env a. HasLogFunc env => RIO env a -> RIO env a
withWriteLock_ Storage
storage (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Maybe Utf8Builder -> (Utf8Builder -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Utf8Builder
mreason Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo
PantryConfig
pc <- Getting PantryConfig env PantryConfig -> RIO env PantryConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PantryConfig env PantryConfig
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
let HackageSecurityConfig [Text]
keyIds Int
threshold Text
url Bool
ignoreExpiry = PantryConfig -> HackageSecurityConfig
pcHackageSecurity PantryConfig
pc
Path Abs Dir
root <- Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env. HasPantryConfig env => SimpleGetter env (Path Abs Dir)
hackageDirL
Path Abs File
tarball <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasPantryConfig env => SimpleGetter env (Path Abs File)
hackageIndexTarballL
URI
baseURI <-
case FilePath -> Maybe URI
parseURI (FilePath -> Maybe URI) -> FilePath -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
url of
Maybe URI
Nothing -> FilePath -> RIO env URI
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString (FilePath -> RIO env URI) -> FilePath -> RIO env URI
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid Hackage Security base URL: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
url
Just URI
x -> URI -> RIO env URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
x
RIO env () -> IO ()
run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
let logTUF :: LogMessage -> IO ()
logTUF = RIO env () -> IO ()
run (RIO env () -> IO ())
-> (LogMessage -> RIO env ()) -> LogMessage -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (LogMessage -> Utf8Builder) -> LogMessage -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (FilePath -> Utf8Builder)
-> (LogMessage -> FilePath) -> LogMessage -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> FilePath
forall a. Pretty a => a -> FilePath
HS.pretty
withRepo :: (Repository RemoteTemp -> IO a) -> IO a
withRepo = HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
forall a.
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
HS.withRepository
HttpLib
HS.httpLib
[URI
baseURI]
RepoOpts
HS.defaultRepoOpts
Cache :: Path Absolute -> CacheLayout -> Cache
HS.Cache
{ cacheRoot :: Path Absolute
HS.cacheRoot = FilePath -> Path Absolute
HS.fromAbsoluteFilePath (FilePath -> Path Absolute) -> FilePath -> Path Absolute
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
root
, cacheLayout :: CacheLayout
HS.cacheLayout = CacheLayout
HS.cabalCacheLayout
}
RepoLayout
HS.hackageRepoLayout
IndexLayout
HS.hackageIndexLayout
LogMessage -> IO ()
logTUF
HasUpdates
didUpdate <- IO HasUpdates -> RIO env HasUpdates
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HasUpdates -> RIO env HasUpdates)
-> IO HasUpdates -> RIO env HasUpdates
forall a b. (a -> b) -> a -> b
$ (Repository RemoteTemp -> IO HasUpdates) -> IO HasUpdates
forall a. (Repository RemoteTemp -> IO a) -> IO a
withRepo ((Repository RemoteTemp -> IO HasUpdates) -> IO HasUpdates)
-> (Repository RemoteTemp -> IO HasUpdates) -> IO HasUpdates
forall a b. (a -> b) -> a -> b
$ \Repository RemoteTemp
repo -> ((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO HasUpdates)
-> IO HasUpdates
forall a.
((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO a)
-> IO a
HS.uncheckClientErrors (((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO HasUpdates)
-> IO HasUpdates)
-> ((Throws VerificationError, Throws SomeRemoteError,
Throws InvalidPackageException) =>
IO HasUpdates)
-> IO HasUpdates
forall a b. (a -> b) -> a -> b
$ do
Bool
needBootstrap <- Repository RemoteTemp -> IO Bool
forall (down :: * -> *). Repository down -> IO Bool
HS.requiresBootstrap Repository RemoteTemp
repo
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needBootstrap (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Repository RemoteTemp -> [KeyId] -> KeyThreshold -> IO ()
forall (down :: * -> *).
(Throws SomeRemoteError, Throws VerificationError) =>
Repository down -> [KeyId] -> KeyThreshold -> IO ()
HS.bootstrap
Repository RemoteTemp
repo
((Text -> KeyId) -> [Text] -> [KeyId]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> KeyId
HS.KeyId (FilePath -> KeyId) -> (Text -> FilePath) -> Text -> KeyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) [Text]
keyIds)
(Int54 -> KeyThreshold
HS.KeyThreshold (Int54 -> KeyThreshold) -> Int54 -> KeyThreshold
forall a b. (a -> b) -> a -> b
$ Int -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
threshold)
Maybe UTCTime
maybeNow <- if Bool
ignoreExpiry
then Maybe UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
else UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
Repository RemoteTemp -> Maybe UTCTime -> IO HasUpdates
forall (down :: * -> *).
(Throws VerificationError, Throws SomeRemoteError) =>
Repository down -> Maybe UTCTime -> IO HasUpdates
HS.checkForUpdates Repository RemoteTemp
repo Maybe UTCTime
maybeNow
case HasUpdates
didUpdate of
HasUpdates
_ | Bool
forceUpdate -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Forced package update is initialized"
Path Abs File -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
HasUpdates
HS.NoUpdates -> do
Bool
x <- Path Abs File -> RIO env Bool
forall env b t.
(HasPantryConfig env, HasLogFunc env) =>
Path b t -> RIO env Bool
needsCacheUpdate Path Abs File
tarball
if Bool
x
then do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No package index update available, but didn't update cache last time, running now"
Path Abs File -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
else Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No package index update available and cache up to date"
HasUpdates
HS.HasUpdates -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Updated package index downloaded"
Path Abs File -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> RIO env ()
updateCache Path Abs File
tarball
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Package index cache populated"
where
getTarballSize :: MonadIO m => Handle -> m Word
getTarballSize :: Handle -> m Word
getTarballSize Handle
h = (Integer -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word) -> (Integer -> Integer) -> Integer -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 (Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
subtract Integer
1024) (Integer -> Word) -> m Integer -> m Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> m Integer
forall (m :: * -> *). MonadIO m => Handle -> m Integer
hFileSize Handle
h
needsCacheUpdate :: Path b t -> RIO env Bool
needsCacheUpdate Path b t
tarball = do
Maybe (FileSize, SHA256)
mres <- ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
-> RIO env (Maybe (FileSize, SHA256))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
forall env. ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256))
loadLatestCacheUpdate
case Maybe (FileSize, SHA256)
mres of
Maybe (FileSize, SHA256)
Nothing -> Bool -> RIO env Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just (FileSize Word
cachedSize, SHA256
_sha256) -> do
Word
actualSize <- FilePath -> IOMode -> (Handle -> RIO env Word) -> RIO env Word
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b t
tarball) IOMode
ReadMode Handle -> RIO env Word
forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize
Bool -> RIO env Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Word
cachedSize Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
actualSize
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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env (Word, SHA256, Word)
-> ReaderT SqlBackend (RIO env) (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word)
-> ReaderT SqlBackend (RIO env) (Word, SHA256, Word)
forall a b. (a -> b) -> a -> b
$ FilePath
-> IOMode
-> (Handle -> RIO env (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word)
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
tarball) IOMode
ReadMode ((Handle -> RIO env (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word))
-> (Handle -> RIO env (Word, SHA256, Word))
-> RIO env (Word, SHA256, Word)
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Calculating hashes to check for hackage-security rebases or filesystem changes"
Word
newSize <- Handle -> RIO env Word
forall (m :: * -> *). MonadIO m => Handle -> m Word
getTarballSize Handle
h
let sinkSHA256 :: a -> ConduitM ByteString c m SHA256
sinkSHA256 a
len = Index ByteString -> ConduitT ByteString ByteString m ()
forall (m :: * -> *) seq.
(Monad m, IsSequence seq) =>
Index seq -> ConduitT seq seq m ()
takeCE (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len) ConduitT ByteString ByteString m ()
-> ConduitM ByteString c m SHA256 -> ConduitM ByteString c m SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString c m SHA256
forall (m :: * -> *) o. Monad m => ConduitT ByteString o m SHA256
SHA256.sinkHash
case Maybe (FileSize, SHA256)
minfo of
Maybe (FileSize, SHA256)
Nothing -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No old cache found, populating cache from scratch"
SHA256
newHash <- ConduitT () Void (RIO env) SHA256 -> RIO env SHA256
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) SHA256 -> RIO env SHA256)
-> ConduitT () Void (RIO env) SHA256 -> RIO env SHA256
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString (RIO env) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) SHA256
-> ConduitT () Void (RIO env) SHA256
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| Word -> ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) a c.
(Monad m, Integral a) =>
a -> ConduitM ByteString c m SHA256
sinkSHA256 Word
newSize
(Word, SHA256, Word) -> RIO env (Word, SHA256, Word)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
0, SHA256
newHash, Word
newSize)
Just (FileSize Word
oldSize, SHA256
oldHash) -> do
(SHA256
oldHashCheck, SHA256
newHash) <- ConduitT () Void (RIO env) (SHA256, SHA256)
-> RIO env (SHA256, SHA256)
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) (SHA256, SHA256)
-> RIO env (SHA256, SHA256))
-> ConduitT () Void (RIO env) (SHA256, SHA256)
-> RIO env (SHA256, SHA256)
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString (RIO env) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (RIO env) ()
-> ConduitM ByteString Void (RIO env) (SHA256, SHA256)
-> ConduitT () Void (RIO env) (SHA256, SHA256)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ZipSink ByteString (RIO env) (SHA256, SHA256)
-> ConduitM ByteString Void (RIO env) (SHA256, SHA256)
forall i (m :: * -> *) r. ZipSink i m r -> Sink i m r
getZipSink ((,)
(SHA256 -> SHA256 -> (SHA256, SHA256))
-> ZipSink ByteString (RIO env) SHA256
-> ZipSink ByteString (RIO env) (SHA256 -> (SHA256, SHA256))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitM ByteString Void (RIO env) SHA256
-> ZipSink ByteString (RIO env) SHA256
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Word -> ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) a c.
(Monad m, Integral a) =>
a -> ConduitM ByteString c m SHA256
sinkSHA256 Word
oldSize)
ZipSink ByteString (RIO env) (SHA256 -> (SHA256, SHA256))
-> ZipSink ByteString (RIO env) SHA256
-> ZipSink ByteString (RIO env) (SHA256, SHA256)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitM ByteString Void (RIO env) SHA256
-> ZipSink ByteString (RIO env) SHA256
forall i (m :: * -> *) r. Sink i m r -> ZipSink i m r
ZipSink (Word -> ConduitM ByteString Void (RIO env) SHA256
forall (m :: * -> *) a c.
(Monad m, Integral a) =>
a -> ConduitM ByteString c m SHA256
sinkSHA256 Word
newSize)
)
Word
offset <-
if SHA256
oldHash SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
== SHA256
oldHashCheck
then Word
oldSize Word -> RIO env () -> RIO env Word
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Updating preexisting cache, should be quick"
else Word
0 Word -> RIO env () -> RIO env Word
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat [
Utf8Builder
"Package index change detected, that's pretty unusual: "
, Utf8Builder
"\n Old size: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word
oldSize
, Utf8Builder
"\n Old hash (orig) : " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
oldHash
, Utf8Builder
"\n New hash (check): " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
oldHashCheck
, Utf8Builder
"\n Forcing a recache"
]
(Word, SHA256, Word) -> RIO env (Word, SHA256, Word)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word
offset, SHA256
newHash, Word
newSize)
RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Populating cache from file size " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word
newSize Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", hash " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SHA256 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display SHA256
newHash
Bool
-> ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
offset Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0) ReaderT SqlBackend (RIO env) ()
forall env. ReaderT SqlBackend (RIO env) ()
clearHackageRevisions
Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
populateCache Path Abs File
tarball (Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
offset) ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) ()
-> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
"Failed populating package index cache")
FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
forall env. FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) ()
storeCacheUpdate (Word -> FileSize
FileSize Word
newSize) SHA256
newHash
gateUpdate :: m b -> m DidUpdateOccur
gateUpdate m b
inner = do
PantryConfig
pc <- Getting PantryConfig s PantryConfig -> m PantryConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PantryConfig s PantryConfig
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
m (m DidUpdateOccur) -> m DidUpdateOccur
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m DidUpdateOccur) -> m DidUpdateOccur)
-> m (m DidUpdateOccur) -> m DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ MVar Bool
-> (Bool -> m (Bool, m DidUpdateOccur)) -> m (m DidUpdateOccur)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar (PantryConfig -> MVar Bool
pcUpdateRef PantryConfig
pc) ((Bool -> m (Bool, m DidUpdateOccur)) -> m (m DidUpdateOccur))
-> (Bool -> m (Bool, m DidUpdateOccur)) -> m (m DidUpdateOccur)
forall a b. (a -> b) -> a -> b
$ \Bool
toUpdate -> (Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur))
-> (Bool, m DidUpdateOccur) -> m (Bool, m DidUpdateOccur)
forall a b. (a -> b) -> a -> b
$
if Bool
toUpdate
then (Bool
False, DidUpdateOccur
UpdateOccurred DidUpdateOccur -> m b -> m DidUpdateOccur
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m b
inner)
else (Bool
False, DidUpdateOccur -> m DidUpdateOccur
forall (f :: * -> *) a. Applicative f => a -> f a
pure DidUpdateOccur
NoUpdateOccurred)
populateCache
:: (HasPantryConfig env, HasLogFunc env)
=> Path Abs File
-> Integer
-> ReaderT SqlBackend (RIO env) ()
populateCache :: Path Abs File -> Integer -> ReaderT SqlBackend (RIO env) ()
populateCache Path Abs File
fp Integer
offset = FilePath
-> IOMode
-> (Handle -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile (Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
fp) IOMode
ReadMode ((Handle -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ())
-> (Handle -> ReaderT SqlBackend (RIO env) ())
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Populating package index cache ..."
IORef Int
counter <- Int -> ReaderT SqlBackend (RIO env) (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
Handle -> SeekMode -> Integer -> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> SeekMode -> Integer -> m ()
hSeek Handle
h SeekMode
AbsoluteSeek Integer
offset
ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
-> ReaderT SqlBackend (RIO env) ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
-> ReaderT SqlBackend (RIO env) ())
-> ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
-> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Handle -> ConduitT () ByteString (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h ConduitT () ByteString (ReaderT SqlBackend (RIO env)) ()
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ()
-> ConduitT () Void (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (FileInfo
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ())
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) o.
MonadThrow m =>
(FileInfo -> ConduitM ByteString o m ())
-> ConduitM ByteString o m ()
untar (IORef Int
-> FileInfo
-> ConduitM ByteString Void (ReaderT SqlBackend (RIO env)) ()
forall a env o.
(Integral a, HasLogFunc env, Display a) =>
IORef a
-> FileInfo
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
perFile IORef Int
counter)
where
perFile :: IORef a
-> FileInfo
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
perFile IORef a
counter FileInfo
fi
| FileType
FTNormal <- FileInfo -> FileType
fileType FileInfo
fi
, Right Text
path <- ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
, Just (PackageName
name, Version
version, Text
filename) <- Text -> Maybe (PackageName, Version, Text)
forall a b. (Parsec a, Parsec b) => Text -> Maybe (a, b, Text)
parseNameVersionSuffix Text
path =
if
| Text
filename Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"package.json" ->
ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
-> (ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> (ByteString -> ReaderT SqlBackend (RIO env) ())
-> ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall env.
HasLogFunc env =>
PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addJSON PackageName
name Version
version
| Text
filename Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== SafeFilePath -> Text
unSafeFilePath (PackageName -> SafeFilePath
cabalFileName PackageName
name) -> do
(ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy) ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
-> (ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> (ByteString -> ReaderT SqlBackend (RIO env) ())
-> ByteString
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addCabal PackageName
name Version
version
a
count <- IORef a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) a
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef a
counter
let count' :: a
count' = a
count a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
IORef a
-> a -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef a
counter a
count'
Bool
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
count' a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
400 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0) (ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b. (a -> b) -> a -> b
$
ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b. (a -> b) -> a -> b
$ RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logSticky (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Processed " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
count' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" cabal files"
| Bool
otherwise -> () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
| FileType
FTNormal <- FileInfo -> FileType
fileType FileInfo
fi
, Right Text
path <- ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ FileInfo -> ByteString
filePath FileInfo
fi
, (Text
nameT, Text
"/preferred-versions") <- (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Text
path
, Just PackageName
name <- FilePath -> Maybe PackageName
parsePackageName (FilePath -> Maybe PackageName) -> FilePath -> Maybe PackageName
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
nameT = do
ByteString
lbs <- ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
case ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
lbs of
Left UnicodeException
_ -> () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Right Text
p -> ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ())
-> ReaderT SqlBackend (RIO env) ()
-> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall a b. (a -> b) -> a -> b
$ PackageName -> Text -> ReaderT SqlBackend (RIO env) ()
forall env. PackageName -> Text -> ReaderT SqlBackend (RIO env) ()
storePreferredVersion PackageName
name Text
p
| Bool
otherwise = () -> ConduitT ByteString o (ReaderT SqlBackend (RIO env)) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
addJSON :: PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addJSON PackageName
name Version
version ByteString
lbs =
case ByteString -> Either FilePath PackageDownload
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode' ByteString
lbs of
Left FilePath
e -> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RIO env () -> ReaderT SqlBackend (RIO env) ())
-> RIO env () -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Error processing Hackage security metadata for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (PackageName -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display PackageName
name) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"-" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString (Version -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display Version
version) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
e
Right (PackageDownload SHA256
sha Word
size) ->
PackageName
-> Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName
-> Version -> SHA256 -> FileSize -> ReaderT SqlBackend (RIO env) ()
storeHackageTarballInfo PackageName
name Version
version SHA256
sha (FileSize -> ReaderT SqlBackend (RIO env) ())
-> FileSize -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Word -> FileSize
FileSize Word
size
addCabal :: PackageName
-> Version -> ByteString -> ReaderT SqlBackend (RIO env) ()
addCabal PackageName
name Version
version ByteString
bs = do
(BlobId
blobTableId, BlobKey
_blobKey) <- ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
forall env.
ByteString -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey)
storeBlob ByteString
bs
PackageName -> Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName -> Version -> BlobId -> ReaderT SqlBackend (RIO env) ()
storeHackageRevision PackageName
name Version
version BlobId
blobTableId
breakSlash :: Text -> Maybe (Text, Text)
breakSlash Text
x
| Text -> Bool
T.null Text
z = Maybe (Text, Text)
forall a. Maybe a
Nothing
| Bool
otherwise = (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
y, Text -> Text
unsafeTail Text
z)
where
(Text
y, Text
z) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Text
x
parseNameVersionSuffix :: Text -> Maybe (a, b, Text)
parseNameVersionSuffix Text
t1 = do
(Text
name, Text
t2) <- Text -> Maybe (Text, Text)
breakSlash Text
t1
(Text
version, Text
filename) <- Text -> Maybe (Text, Text)
breakSlash Text
t2
a
name' <- FilePath -> Maybe a
forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse (FilePath -> Maybe a) -> FilePath -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
name
b
version' <- FilePath -> Maybe b
forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse (FilePath -> Maybe b) -> FilePath -> Maybe b
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
version
(a, b, Text) -> Maybe (a, b, Text)
forall a. a -> Maybe a
Just (a
name', b
version', Text
filename)
data PackageDownload = PackageDownload !SHA256 !Word
instance FromJSON PackageDownload where
parseJSON :: Value -> Parser PackageDownload
parseJSON = FilePath
-> (Object -> Parser PackageDownload)
-> Value
-> Parser PackageDownload
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"PackageDownload" ((Object -> Parser PackageDownload)
-> Value -> Parser PackageDownload)
-> (Object -> Parser PackageDownload)
-> Value
-> Parser PackageDownload
forall a b. (a -> b) -> a -> b
$ \Object
o1 -> do
Object
o2 <- Object
o1 Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"signed"
Object Object
o3 <- Object
o2 Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"targets"
Object Object
o4:[Value]
_ <- [Value] -> Parser [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value] -> Parser [Value]) -> [Value] -> Parser [Value]
forall a b. (a -> b) -> a -> b
$ Object -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Object
o3
Word
len <- Object
o4 Object -> Text -> Parser Word
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"length"
Object
hashes <- Object
o4 Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"hashes"
Text
sha256' <- Object
hashes Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"sha256"
SHA256
sha256 <-
case Text -> Either SHA256Exception SHA256
SHA256.fromHexText Text
sha256' of
Left SHA256Exception
e -> FilePath -> Parser SHA256
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser SHA256) -> FilePath -> Parser SHA256
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid sha256: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SHA256Exception -> FilePath
forall a. Show a => a -> FilePath
show SHA256Exception
e
Right SHA256
x -> SHA256 -> Parser SHA256
forall (m :: * -> *) a. Monad m => a -> m a
return SHA256
x
PackageDownload -> Parser PackageDownload
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDownload -> Parser PackageDownload)
-> PackageDownload -> Parser PackageDownload
forall a b. (a -> b) -> a -> b
$ SHA256 -> Word -> PackageDownload
PackageDownload SHA256
sha256 Word
len
getHackageCabalFile
:: (HasPantryConfig env, HasLogFunc env)
=> PackageIdentifierRevision
-> RIO env ByteString
getHackageCabalFile :: PackageIdentifierRevision -> RIO env ByteString
getHackageCabalFile pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
_ Version
_ CabalFileInfo
cfi) = do
BlobId
bid <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
ByteString
bs <- ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString)
-> ReaderT SqlBackend (RIO env) ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$ BlobId -> ReaderT SqlBackend (RIO env) ByteString
forall env. BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById BlobId
bid
case CabalFileInfo
cfi of
CFIHash SHA256
sha Maybe FileSize
msize -> do
let sizeMismatch :: Bool
sizeMismatch =
case Maybe FileSize
msize of
Maybe FileSize
Nothing -> Bool
False
Just FileSize
size -> Word -> FileSize
FileSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) FileSize -> FileSize -> Bool
forall a. Eq a => a -> a -> Bool
/= FileSize
size
shaMismatch :: Bool
shaMismatch = SHA256
sha SHA256 -> SHA256 -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> SHA256
SHA256.hashBytes ByteString
bs
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sizeMismatch Bool -> Bool -> Bool
|| Bool
shaMismatch)
(RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath -> RIO env ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO env ()) -> FilePath -> RIO env ()
forall a b. (a -> b) -> a -> b
$ FilePath
"getHackageCabalFile: size or SHA mismatch for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (PackageIdentifierRevision, ByteString) -> FilePath
forall a. Show a => a -> FilePath
show (PackageIdentifierRevision
pir, ByteString
bs)
CabalFileInfo
_ -> () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ByteString -> RIO env ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
resolveCabalFileInfo
:: (HasPantryConfig env, HasLogFunc env)
=> PackageIdentifierRevision
-> RIO env BlobId
resolveCabalFileInfo :: PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
cfi) = do
Maybe BlobId
mres <- RIO env (Maybe BlobId)
inner
case Maybe BlobId
mres of
Just BlobId
res -> BlobId -> RIO env BlobId
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
Maybe BlobId
Nothing -> do
DidUpdateOccur
updated <- Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just (Utf8Builder -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Cabal file info not found for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageIdentifierRevision -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
Maybe BlobId
mres' <-
case DidUpdateOccur
updated of
DidUpdateOccur
UpdateOccurred -> RIO env (Maybe BlobId)
inner
DidUpdateOccur
NoUpdateOccurred -> Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
case Maybe BlobId
mres' of
Maybe BlobId
Nothing -> PackageName -> Version -> RIO env FuzzyResults
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> Version -> RIO env FuzzyResults
fuzzyLookupCandidates PackageName
name Version
ver RIO env FuzzyResults
-> (FuzzyResults -> RIO env BlobId) -> RIO env BlobId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PantryException -> RIO env BlobId
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env BlobId)
-> (FuzzyResults -> PantryException)
-> FuzzyResults
-> RIO env BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifierRevision -> FuzzyResults -> PantryException
UnknownHackagePackage PackageIdentifierRevision
pir
Just BlobId
res -> BlobId -> RIO env BlobId
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobId
res
where
inner :: RIO env (Maybe BlobId)
inner =
case CabalFileInfo
cfi of
CFIHash SHA256
sha Maybe FileSize
msize -> PackageIdentifierRevision
-> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
forall a env.
(Display a, HasPantryConfig env, HasLogFunc env) =>
a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA PackageIdentifierRevision
pir SHA256
sha Maybe FileSize
msize
CFIRevision Revision
rev -> (((BlobId, BlobKey) -> BlobId)
-> Maybe (BlobId, BlobKey) -> Maybe BlobId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlobId, BlobKey) -> BlobId
forall a b. (a, b) -> a
fst (Maybe (BlobId, BlobKey) -> Maybe BlobId)
-> (Map Revision (BlobId, BlobKey) -> Maybe (BlobId, BlobKey))
-> Map Revision (BlobId, BlobKey)
-> Maybe BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Revision
-> Map Revision (BlobId, BlobKey) -> Maybe (BlobId, BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Revision
rev) (Map Revision (BlobId, BlobKey) -> Maybe BlobId)
-> RIO env (Map Revision (BlobId, BlobKey))
-> RIO env (Maybe BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> RIO env (Map Revision (BlobId, BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
ver)
CabalFileInfo
CFILatest -> ((((BlobId, BlobKey), Map Revision (BlobId, BlobKey)) -> BlobId)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> Maybe BlobId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((BlobId, BlobKey) -> BlobId
forall a b. (a, b) -> a
fst ((BlobId, BlobKey) -> BlobId)
-> (((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> (BlobId, BlobKey))
-> ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> (BlobId, BlobKey)
forall a b. (a, b) -> a
fst) (Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
-> Maybe BlobId)
-> (Map Revision (BlobId, BlobKey)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey)))
-> Map Revision (BlobId, BlobKey)
-> Maybe BlobId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Revision (BlobId, BlobKey)
-> Maybe ((BlobId, BlobKey), Map Revision (BlobId, BlobKey))
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView) (Map Revision (BlobId, BlobKey) -> Maybe BlobId)
-> RIO env (Map Revision (BlobId, BlobKey))
-> RIO env (Maybe BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> RIO env (Map Revision (BlobId, BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
ver)
loadOrDownloadBlobBySHA ::
(Display a, HasPantryConfig env, HasLogFunc env)
=> a
-> SHA256
-> Maybe FileSize
-> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA :: a -> SHA256 -> Maybe FileSize -> RIO env (Maybe BlobId)
loadOrDownloadBlobBySHA a
label SHA256
sha256 Maybe FileSize
msize = do
Maybe BlobId
mresult <- RIO env (Maybe BlobId)
byDB
case Maybe BlobId
mresult of
Maybe BlobId
Nothing -> do
case Maybe FileSize
msize of
Maybe FileSize
Nothing -> do
Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
Just FileSize
size -> do
Maybe ByteString
mblob <- BlobKey -> RIO env (Maybe ByteString)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
BlobKey -> RIO env (Maybe ByteString)
casaLookupKey (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha256 FileSize
size)
case Maybe ByteString
mblob of
Maybe ByteString
Nothing -> do
Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
Just {} -> do
Maybe BlobId
result <- RIO env (Maybe BlobId)
byDB
case Maybe BlobId
result of
Just BlobId
blobId -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Pulled blob from Casa for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
label)
Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobId -> Maybe BlobId
forall a. a -> Maybe a
Just BlobId
blobId)
Maybe BlobId
Nothing -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
(Utf8Builder
"Bug? Blob pulled from Casa not in database for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
label)
Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe BlobId
forall a. Maybe a
Nothing
Just BlobId
blobId -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder
"Got blob from Pantry database for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display a
label)
Maybe BlobId -> RIO env (Maybe BlobId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobId -> Maybe BlobId
forall a. a -> Maybe a
Just BlobId
blobId)
where
byDB :: RIO env (Maybe BlobId)
byDB = ReaderT SqlBackend (RIO env) (Maybe BlobId)
-> RIO env (Maybe BlobId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe BlobId)
-> RIO env (Maybe BlobId))
-> ReaderT SqlBackend (RIO env) (Maybe BlobId)
-> RIO env (Maybe BlobId)
forall a b. (a -> b) -> a -> b
$ SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
forall env. SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA SHA256
sha256
fuzzyLookupCandidates
:: (HasPantryConfig env, HasLogFunc env)
=> PackageName
-> Version
-> RIO env FuzzyResults
fuzzyLookupCandidates :: PackageName -> Version -> RIO env FuzzyResults
fuzzyLookupCandidates PackageName
name Version
ver0 = do
Map Version (Map Revision BlobKey)
m <- RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
YesRequireHackageIndex UsePreferredVersions
UsePreferredVersions PackageName
name
if Map Version (Map Revision BlobKey) -> Bool
forall k a. Map k a -> Bool
Map.null Map Version (Map Revision BlobKey)
m
then [PackageName] -> FuzzyResults
FRNameNotFound ([PackageName] -> FuzzyResults)
-> RIO env [PackageName] -> RIO env FuzzyResults
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> RIO env [PackageName]
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name
else
case Version
-> Map Version (Map Revision BlobKey)
-> Maybe (Map Revision BlobKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Version
ver0 Map Version (Map Revision BlobKey)
m of
Maybe (Map Revision BlobKey)
Nothing -> do
let withVers :: NonEmpty (Version, Map k BlobKey) -> f FuzzyResults
withVers NonEmpty (Version, Map k BlobKey)
vers = FuzzyResults -> f FuzzyResults
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyResults -> f FuzzyResults) -> FuzzyResults -> f FuzzyResults
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageIdentifierRevision -> FuzzyResults
FRVersionNotFound (NonEmpty PackageIdentifierRevision -> FuzzyResults)
-> NonEmpty PackageIdentifierRevision -> FuzzyResults
forall a b. (a -> b) -> a -> b
$ (((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty (Version, Map k BlobKey)
-> NonEmpty PackageIdentifierRevision)
-> NonEmpty (Version, Map k BlobKey)
-> ((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty PackageIdentifierRevision
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty (Version, Map k BlobKey)
-> NonEmpty PackageIdentifierRevision
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map NonEmpty (Version, Map k BlobKey)
vers (((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty PackageIdentifierRevision)
-> ((Version, Map k BlobKey) -> PackageIdentifierRevision)
-> NonEmpty PackageIdentifierRevision
forall a b. (a -> b) -> a -> b
$ \(Version
ver, Map k BlobKey
revs) ->
case Map k BlobKey -> Maybe (BlobKey, Map k BlobKey)
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map k BlobKey
revs of
Maybe (BlobKey, Map k BlobKey)
Nothing -> FilePath -> PackageIdentifierRevision
forall a. HasCallStack => FilePath -> a
error FilePath
"fuzzyLookupCandidates: no revisions"
Just (BlobKey SHA256
sha FileSize
size, Map k BlobKey
_) -> PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size))
case [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey)))
-> [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ ((Version, Map Revision BlobKey) -> Bool)
-> [(Version, Map Revision BlobKey)]
-> [(Version, Map Revision BlobKey)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> Bool
sameMajor (Version -> Bool)
-> ((Version, Map Revision BlobKey) -> Version)
-> (Version, Map Revision BlobKey)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, Map Revision BlobKey) -> Version
forall a b. (a, b) -> a
fst) ([(Version, Map Revision BlobKey)]
-> [(Version, Map Revision BlobKey)])
-> [(Version, Map Revision BlobKey)]
-> [(Version, Map Revision BlobKey)]
forall a b. (a -> b) -> a -> b
$ Map Version (Map Revision BlobKey)
-> [(Version, Map Revision BlobKey)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Version (Map Revision BlobKey)
m of
Just NonEmpty (Version, Map Revision BlobKey)
vers -> NonEmpty (Version, Map Revision BlobKey) -> RIO env FuzzyResults
forall (f :: * -> *) k.
Applicative f =>
NonEmpty (Version, Map k BlobKey) -> f FuzzyResults
withVers NonEmpty (Version, Map Revision BlobKey)
vers
Maybe (NonEmpty (Version, Map Revision BlobKey))
Nothing ->
case [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey)))
-> [(Version, Map Revision BlobKey)]
-> Maybe (NonEmpty (Version, Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ Map Version (Map Revision BlobKey)
-> [(Version, Map Revision BlobKey)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Version (Map Revision BlobKey)
m of
Maybe (NonEmpty (Version, Map Revision BlobKey))
Nothing -> FilePath -> RIO env FuzzyResults
forall a. HasCallStack => FilePath -> a
error FilePath
"fuzzyLookupCandidates: no versions"
Just NonEmpty (Version, Map Revision BlobKey)
vers -> NonEmpty (Version, Map Revision BlobKey) -> RIO env FuzzyResults
forall (f :: * -> *) k.
Applicative f =>
NonEmpty (Version, Map k BlobKey) -> f FuzzyResults
withVers NonEmpty (Version, Map Revision BlobKey)
vers
Just Map Revision BlobKey
revisions ->
let pirs :: [PackageIdentifierRevision]
pirs = (BlobKey -> PackageIdentifierRevision)
-> [BlobKey] -> [PackageIdentifierRevision]
forall a b. (a -> b) -> [a] -> [b]
map
(\(BlobKey SHA256
sha FileSize
size) -> PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver0 (SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size)))
(Map Revision BlobKey -> [BlobKey]
forall k a. Map k a -> [a]
Map.elems Map Revision BlobKey
revisions)
in case [PackageIdentifierRevision]
-> Maybe (NonEmpty PackageIdentifierRevision)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageIdentifierRevision]
pirs of
Maybe (NonEmpty PackageIdentifierRevision)
Nothing -> FilePath -> RIO env FuzzyResults
forall a. HasCallStack => FilePath -> a
error FilePath
"fuzzyLookupCandidates: no revisions"
Just NonEmpty PackageIdentifierRevision
pirs' -> FuzzyResults -> RIO env FuzzyResults
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuzzyResults -> RIO env FuzzyResults)
-> FuzzyResults -> RIO env FuzzyResults
forall a b. (a -> b) -> a -> b
$ NonEmpty PackageIdentifierRevision -> FuzzyResults
FRRevisionNotFound NonEmpty PackageIdentifierRevision
pirs'
where
sameMajor :: Version -> Bool
sameMajor Version
v = Version -> [Int]
toMajorVersion Version
v [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== Version -> [Int]
toMajorVersion Version
ver0
toMajorVersion :: Version -> [Int]
toMajorVersion :: Version -> [Int]
toMajorVersion Version
v =
case Version -> [Int]
versionNumbers Version
v of
[] -> [Int
0, Int
0]
[Int
a] -> [Int
a, Int
0]
Int
a:Int
b:[Int]
_ -> [Int
a, Int
b]
getHackageTypoCorrections
:: (HasPantryConfig env, HasLogFunc env)
=> PackageName
-> RIO env [PackageName]
getHackageTypoCorrections :: PackageName -> RIO env [PackageName]
getHackageTypoCorrections PackageName
name1 =
ReaderT SqlBackend (RIO env) [PackageName] -> RIO env [PackageName]
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) [PackageName]
-> RIO env [PackageName])
-> ReaderT SqlBackend (RIO env) [PackageName]
-> RIO env [PackageName]
forall a b. (a -> b) -> a -> b
$ (PackageName -> Bool)
-> ConduitT
PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
-> ReaderT SqlBackend (RIO env) [PackageName]
forall env a.
(PackageName -> Bool)
-> ConduitT PackageName Void (ReaderT SqlBackend (RIO env)) a
-> ReaderT SqlBackend (RIO env) a
sinkHackagePackageNames
(\PackageName
name2 -> PackageName
name1 PackageName -> PackageName -> Int
`distance` PackageName
name2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4)
(Int
-> ConduitT
PackageName PackageName (ReaderT SqlBackend (RIO env)) ()
forall (m :: * -> *) a. Monad m => Int -> ConduitT a a m ()
takeC Int
10 ConduitT PackageName PackageName (ReaderT SqlBackend (RIO env)) ()
-> ConduitT
PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
-> ConduitT
PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT
PackageName Void (ReaderT SqlBackend (RIO env)) [PackageName]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList)
where
distance :: PackageName -> PackageName -> Int
distance = Text -> Text -> Int
damerauLevenshtein (Text -> Text -> Int)
-> (PackageName -> Text) -> PackageName -> PackageName -> Int
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FilePath -> Text
T.pack (FilePath -> Text)
-> (PackageName -> FilePath) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
packageNameString)
data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions
deriving Int -> UsePreferredVersions -> FilePath -> FilePath
[UsePreferredVersions] -> FilePath -> FilePath
UsePreferredVersions -> FilePath
(Int -> UsePreferredVersions -> FilePath -> FilePath)
-> (UsePreferredVersions -> FilePath)
-> ([UsePreferredVersions] -> FilePath -> FilePath)
-> Show UsePreferredVersions
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [UsePreferredVersions] -> FilePath -> FilePath
$cshowList :: [UsePreferredVersions] -> FilePath -> FilePath
show :: UsePreferredVersions -> FilePath
$cshow :: UsePreferredVersions -> FilePath
showsPrec :: Int -> UsePreferredVersions -> FilePath -> FilePath
$cshowsPrec :: Int -> UsePreferredVersions -> FilePath -> FilePath
Show
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
showList :: [RequireHackageIndex] -> FilePath -> FilePath
$cshowList :: [RequireHackageIndex] -> FilePath -> FilePath
show :: RequireHackageIndex -> FilePath
$cshow :: RequireHackageIndex -> FilePath
showsPrec :: Int -> RequireHackageIndex -> FilePath -> FilePath
$cshowsPrec :: Int -> RequireHackageIndex -> FilePath -> FilePath
Show
initializeIndex
:: (HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> RIO env ()
initializeIndex :: RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
NoRequireHackageIndex = () -> RIO env ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
initializeIndex RequireHackageIndex
YesRequireHackageIndex = do
Int
cabalCount <- ReaderT SqlBackend (RIO env) Int -> RIO env Int
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage ReaderT SqlBackend (RIO env) Int
forall env. ReaderT SqlBackend (RIO env) Int
countHackageCabals
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
cabalCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RIO env DidUpdateOccur -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env DidUpdateOccur -> RIO env ())
-> RIO env DidUpdateOccur -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just (Utf8Builder -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No information from Hackage index, updating"
getHackagePackageVersions
:: (HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions :: RequireHackageIndex
-> UsePreferredVersions
-> PackageName
-> RIO env (Map Version (Map Revision BlobKey))
getHackagePackageVersions RequireHackageIndex
req UsePreferredVersions
usePreferred PackageName
name = do
RequireHackageIndex -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
req
ReaderT SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey)))
-> ReaderT
SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> RIO env (Map Version (Map Revision BlobKey))
forall a b. (a -> b) -> a -> b
$ do
Maybe Text
mpreferred <-
case UsePreferredVersions
usePreferred of
UsePreferredVersions
UsePreferredVersions -> PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
forall env.
PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text)
loadPreferredVersion PackageName
name
UsePreferredVersions
IgnorePreferredVersions -> Maybe Text -> ReaderT SqlBackend (RIO env) (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
let predicate :: Version -> Map Revision BlobKey -> Bool
predicate :: Version -> Map Revision BlobKey -> Bool
predicate = (Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
-> Version
-> Map Revision BlobKey
-> Bool
forall a. a -> Maybe a -> a
fromMaybe (\Version
_ Map Revision BlobKey
_ -> Bool
True) (Maybe (Version -> Map Revision BlobKey -> Bool)
-> Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
-> Version
-> Map Revision BlobKey
-> Bool
forall a b. (a -> b) -> a -> b
$ do
Text
preferredT1 <- Maybe Text
mpreferred
Text
preferredT2 <- Text -> Text -> Maybe Text
T.stripPrefix (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
packageNameString PackageName
name) Text
preferredT1
VersionRange
vr <- FilePath -> Maybe VersionRange
forall a. Parsec a => FilePath -> Maybe a
Distribution.Text.simpleParse (FilePath -> Maybe VersionRange) -> FilePath -> Maybe VersionRange
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
preferredT2
(Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
forall a. a -> Maybe a
Just ((Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool))
-> (Version -> Map Revision BlobKey -> Bool)
-> Maybe (Version -> Map Revision BlobKey -> Bool)
forall a b. (a -> b) -> a -> b
$ \Version
v Map Revision BlobKey
_ -> Version -> VersionRange -> Bool
withinRange Version
v VersionRange
vr
(Version -> Map Revision BlobKey -> Bool)
-> Map Version (Map Revision BlobKey)
-> Map Version (Map Revision BlobKey)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Version -> Map Revision BlobKey -> Bool
predicate (Map Version (Map Revision BlobKey)
-> Map Version (Map Revision BlobKey))
-> ReaderT
SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
-> ReaderT
SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> ReaderT
SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
forall env.
PackageName
-> ReaderT
SqlBackend (RIO env) (Map Version (Map Revision BlobKey))
loadHackagePackageVersions PackageName
name
getHackagePackageVersionRevisions
:: (HasPantryConfig env, HasLogFunc env)
=> RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions :: RequireHackageIndex
-> PackageName -> Version -> RIO env (Map Revision BlobKey)
getHackagePackageVersionRevisions RequireHackageIndex
req PackageName
name Version
version = do
RequireHackageIndex -> RIO env ()
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex -> RIO env ()
initializeIndex RequireHackageIndex
req
ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
-> RIO env (Map Revision BlobKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
-> RIO env (Map Revision BlobKey))
-> ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
-> RIO env (Map Revision BlobKey)
forall a b. (a -> b) -> a -> b
$
((BlobId, BlobKey) -> BlobKey)
-> Map Revision (BlobId, BlobKey) -> Map Revision BlobKey
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (BlobId, BlobKey) -> BlobKey
forall a b. (a, b) -> b
snd (Map Revision (BlobId, BlobKey) -> Map Revision BlobKey)
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
-> ReaderT SqlBackend (RIO env) (Map Revision BlobKey)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, BlobKey))
loadHackagePackageVersion PackageName
name Version
version
withCachedTree
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
withCachedTree :: RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
withCachedTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid RIO env HackageTarballResult
inner = do
Maybe Package
mres <- ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package))
-> ReaderT SqlBackend (RIO env) (Maybe Package)
-> RIO env (Maybe Package)
forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> ReaderT SqlBackend (RIO env) (Maybe Package)
loadHackageTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
bid
case Maybe Package
mres of
Just Package
package -> HackageTarballResult -> RIO env HackageTarballResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HackageTarballResult -> RIO env HackageTarballResult)
-> HackageTarballResult -> RIO env HackageTarballResult
forall a b. (a -> b) -> a -> b
$ Package
-> Maybe (GenericPackageDescription, TreeId)
-> HackageTarballResult
HackageTarballResult Package
package Maybe (GenericPackageDescription, TreeId)
forall a. Maybe a
Nothing
Maybe Package
Nothing -> do
HackageTarballResult
htr <- RIO env HackageTarballResult
inner
ReaderT SqlBackend (RIO env) () -> RIO env ()
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) () -> RIO env ())
-> ReaderT SqlBackend (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
PackageName
-> Version -> BlobId -> TreeKey -> ReaderT SqlBackend (RIO env) ()
forall env.
PackageName
-> Version -> BlobId -> TreeKey -> ReaderT SqlBackend (RIO env) ()
storeHackageTree PackageName
name Version
ver BlobId
bid (TreeKey -> ReaderT SqlBackend (RIO env) ())
-> TreeKey -> ReaderT SqlBackend (RIO env) ()
forall a b. (a -> b) -> a -> b
$ Package -> TreeKey
packageTreeKey (Package -> TreeKey) -> Package -> TreeKey
forall a b. (a -> b) -> a -> b
$ HackageTarballResult -> Package
htrPackage HackageTarballResult
htr
HackageTarballResult -> RIO env HackageTarballResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageTarballResult
htr
getHackageTarballKey
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageIdentifierRevision
-> RIO env TreeKey
getHackageTarballKey :: PackageIdentifierRevision -> RIO env TreeKey
getHackageTarballKey pir :: PackageIdentifierRevision
pir@(PackageIdentifierRevision PackageName
name Version
ver (CFIHash SHA256
sha Maybe FileSize
_msize)) = do
Maybe TreeKey
mres <- ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey))
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
-> RIO env (Maybe TreeKey)
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
forall env.
PackageName
-> Version
-> SHA256
-> ReaderT SqlBackend (RIO env) (Maybe TreeKey)
loadHackageTreeKey PackageName
name Version
ver SHA256
sha
case Maybe TreeKey
mres of
Maybe TreeKey
Nothing -> Package -> TreeKey
packageTreeKey (Package -> TreeKey)
-> (HackageTarballResult -> Package)
-> HackageTarballResult
-> TreeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageTarballResult -> Package
htrPackage (HackageTarballResult -> TreeKey)
-> RIO env HackageTarballResult -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing
Just TreeKey
key -> TreeKey -> RIO env TreeKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure TreeKey
key
getHackageTarballKey PackageIdentifierRevision
pir = Package -> TreeKey
packageTreeKey (Package -> TreeKey)
-> (HackageTarballResult -> Package)
-> HackageTarballResult
-> TreeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HackageTarballResult -> Package
htrPackage (HackageTarballResult -> TreeKey)
-> RIO env HackageTarballResult -> RIO env TreeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
forall a. Maybe a
Nothing
getHackageTarball
:: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
=> PackageIdentifierRevision
-> Maybe TreeKey
-> RIO env HackageTarballResult
getHackageTarball :: PackageIdentifierRevision
-> Maybe TreeKey -> RIO env HackageTarballResult
getHackageTarball PackageIdentifierRevision
pir Maybe TreeKey
mtreeKey = do
let PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
_cfi = PackageIdentifierRevision
pir
BlobId
cabalFile <- PackageIdentifierRevision -> RIO env BlobId
forall env.
(HasPantryConfig env, HasLogFunc env) =>
PackageIdentifierRevision -> RIO env BlobId
resolveCabalFileInfo PackageIdentifierRevision
pir
let rpli :: RawPackageLocationImmutable
rpli = PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtreeKey
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageName
-> Version
-> BlobId
-> RIO env HackageTarballResult
-> RIO env HackageTarballResult
withCachedTree RawPackageLocationImmutable
rpli PackageName
name Version
ver BlobId
cabalFile (RIO env HackageTarballResult -> RIO env HackageTarballResult)
-> RIO env HackageTarballResult -> RIO env HackageTarballResult
forall a b. (a -> b) -> a -> b
$ do
BlobKey
cabalFileKey <- ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey)
-> ReaderT SqlBackend (RIO env) BlobKey -> RIO env BlobKey
forall a b. (a -> b) -> a -> b
$ BlobId -> ReaderT SqlBackend (RIO env) BlobKey
forall env. BlobId -> ReaderT SqlBackend (RIO env) BlobKey
getBlobKey BlobId
cabalFile
Maybe (SHA256, FileSize)
mpair <- ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize)))
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize))
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
loadHackageTarballInfo PackageName
name Version
ver
(SHA256
sha, FileSize
size) <-
case Maybe (SHA256, FileSize)
mpair of
Just (SHA256, FileSize)
pair -> (SHA256, FileSize) -> RIO env (SHA256, FileSize)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize)
pair
Maybe (SHA256, FileSize)
Nothing -> do
let exc :: PantryException
exc = PackageIdentifier -> PantryException
NoHackageCryptographicHash (PackageIdentifier -> PantryException)
-> PackageIdentifier -> PantryException
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
ver
DidUpdateOccur
updated <- Maybe Utf8Builder -> RIO env DidUpdateOccur
forall env.
(HasPantryConfig env, HasLogFunc env) =>
Maybe Utf8Builder -> RIO env DidUpdateOccur
updateHackageIndex (Maybe Utf8Builder -> RIO env DidUpdateOccur)
-> Maybe Utf8Builder -> RIO env DidUpdateOccur
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Maybe Utf8Builder
forall a. a -> Maybe a
Just (Utf8Builder -> Maybe Utf8Builder)
-> Utf8Builder -> Maybe Utf8Builder
forall a b. (a -> b) -> a -> b
$ PantryException -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display PantryException
exc Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", updating"
Maybe (SHA256, FileSize)
mpair2 <-
case DidUpdateOccur
updated of
DidUpdateOccur
UpdateOccurred -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize))
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize)))
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
-> RIO env (Maybe (SHA256, FileSize))
forall a b. (a -> b) -> a -> b
$ PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
forall env.
PackageName
-> Version
-> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize))
loadHackageTarballInfo PackageName
name Version
ver
DidUpdateOccur
NoUpdateOccurred -> Maybe (SHA256, FileSize) -> RIO env (Maybe (SHA256, FileSize))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SHA256, FileSize)
forall a. Maybe a
Nothing
case Maybe (SHA256, FileSize)
mpair2 of
Maybe (SHA256, FileSize)
Nothing -> PantryException -> RIO env (SHA256, FileSize)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO PantryException
exc
Just (SHA256, FileSize)
pair2 -> (SHA256, FileSize) -> RIO env (SHA256, FileSize)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHA256, FileSize)
pair2
PantryConfig
pc <- Getting PantryConfig env PantryConfig -> RIO env PantryConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PantryConfig env PantryConfig
forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigL
let urlPrefix :: Text
urlPrefix = HackageSecurityConfig -> Text
hscDownloadPrefix (HackageSecurityConfig -> Text) -> HackageSecurityConfig -> Text
forall a b. (a -> b) -> a -> b
$ PantryConfig -> HackageSecurityConfig
pcHackageSecurity PantryConfig
pc
url :: Text
url =
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ Text
urlPrefix
, Text
"package/"
, FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display PackageName
name
, Text
"-"
, FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Version -> FilePath
forall a. Pretty a => a -> FilePath
Distribution.Text.display Version
ver
, Text
".tar.gz"
]
(SHA256
_, FileSize
_, Package
package, CachedTree
cachedTree) <-
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
HasCallStack) =>
RawPackageLocationImmutable
-> RawArchive
-> RawPackageMetadata
-> RIO env (SHA256, FileSize, Package, CachedTree)
getArchive
RawPackageLocationImmutable
rpli
RawArchive :: ArchiveLocation
-> Maybe SHA256 -> Maybe FileSize -> Text -> RawArchive
RawArchive
{ raLocation :: ArchiveLocation
raLocation = Text -> ArchiveLocation
ALUrl Text
url
, raHash :: Maybe SHA256
raHash = SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
sha
, raSize :: Maybe FileSize
raSize = FileSize -> Maybe FileSize
forall a. a -> Maybe a
Just FileSize
size
, raSubdir :: Text
raSubdir = Text
T.empty
}
RawPackageMetadata :: Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata
{ rpmName :: Maybe PackageName
rpmName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just PackageName
name
, rpmVersion :: Maybe Version
rpmVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
ver
, rpmTreeKey :: Maybe TreeKey
rpmTreeKey = Maybe TreeKey
forall a. Maybe a
Nothing
}
case CachedTree
cachedTree of
CachedTreeMap Map SafeFilePath (TreeEntry, BlobId)
m -> do
let ft :: FileType
ft =
case Package -> PackageCabal
packageCabalEntry Package
package of
PCCabalFile (TreeEntry BlobKey
_ FileType
ft') -> FileType
ft'
PackageCabal
_ -> FilePath -> FileType
forall a. HasCallStack => FilePath -> a
error FilePath
"Impossible: Hackage does not support hpack"
cabalEntry :: TreeEntry
cabalEntry = BlobKey -> FileType -> TreeEntry
TreeEntry BlobKey
cabalFileKey FileType
ft
(ByteString
cabalBS, BlobId
cabalBlobId) <-
ReaderT SqlBackend (RIO env) (ByteString, BlobId)
-> RIO env (ByteString, BlobId)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (ByteString, BlobId)
-> RIO env (ByteString, BlobId))
-> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
-> RIO env (ByteString, BlobId)
forall a b. (a -> b) -> a -> b
$ do
let BlobKey SHA256
sha' FileSize
_ = BlobKey
cabalFileKey
Maybe BlobId
mcabalBS <- SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
forall env. SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId)
loadBlobBySHA SHA256
sha'
case Maybe BlobId
mcabalBS of
Maybe BlobId
Nothing ->
FilePath -> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
forall a. HasCallStack => FilePath -> a
error (FilePath -> ReaderT SqlBackend (RIO env) (ByteString, BlobId))
-> FilePath -> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
forall a b. (a -> b) -> a -> b
$
FilePath
"Invariant violated, cabal file key: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ BlobKey -> FilePath
forall a. Show a => a -> FilePath
show BlobKey
cabalFileKey
Just BlobId
bid -> (, BlobId
bid) (ByteString -> (ByteString, BlobId))
-> ReaderT SqlBackend (RIO env) ByteString
-> ReaderT SqlBackend (RIO env) (ByteString, BlobId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlobId -> ReaderT SqlBackend (RIO env) ByteString
forall env. BlobId -> ReaderT SqlBackend (RIO env) ByteString
loadBlobById BlobId
bid
let tree' :: CachedTree
tree' = Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
CachedTreeMap (Map SafeFilePath (TreeEntry, BlobId) -> CachedTree)
-> Map SafeFilePath (TreeEntry, BlobId) -> CachedTree
forall a b. (a -> b) -> a -> b
$ SafeFilePath
-> (TreeEntry, BlobId)
-> Map SafeFilePath (TreeEntry, BlobId)
-> Map SafeFilePath (TreeEntry, BlobId)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (PackageName -> SafeFilePath
cabalFileName PackageName
name) (TreeEntry
cabalEntry, BlobId
cabalBlobId) Map SafeFilePath (TreeEntry, BlobId)
m
ident :: PackageIdentifier
ident = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
ver
([PWarning]
_warnings, GenericPackageDescription
gpd) <- Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> RIO env ([PWarning], GenericPackageDescription)
forall (m :: * -> *).
MonadThrow m =>
Either RawPackageLocationImmutable (Path Abs File)
-> ByteString -> m ([PWarning], GenericPackageDescription)
rawParseGPD (RawPackageLocationImmutable
-> Either RawPackageLocationImmutable (Path Abs File)
forall a b. a -> Either a b
Left RawPackageLocationImmutable
rpli) ByteString
cabalBS
let gpdIdent :: PackageIdentifier
gpdIdent = PackageDescription -> PackageIdentifier
Cabal.package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
Cabal.packageDescription GenericPackageDescription
gpd
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
/= PackageIdentifier
gpdIdent) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
PantryException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (PantryException -> RIO env ()) -> PantryException -> RIO env ()
forall a b. (a -> b) -> a -> b
$
PackageIdentifierRevision
-> Mismatch PackageIdentifier -> PantryException
MismatchedCabalFileForHackage
PackageIdentifierRevision
pir
Mismatch :: forall a. a -> a -> Mismatch a
Mismatch {mismatchExpected :: PackageIdentifier
mismatchExpected = PackageIdentifier
ident, mismatchActual :: PackageIdentifier
mismatchActual = PackageIdentifier
gpdIdent}
(TreeId
tid, TreeKey
treeKey') <-
ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey)
forall env a.
(HasPantryConfig env, HasLogFunc env) =>
ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage (ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey))
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
-> RIO env (TreeId, TreeKey)
forall a b. (a -> b) -> a -> b
$
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RawPackageLocationImmutable
-> PackageIdentifier
-> CachedTree
-> BuildFile
-> ReaderT SqlBackend (RIO env) (TreeId, TreeKey)
storeTree RawPackageLocationImmutable
rpli PackageIdentifier
ident CachedTree
tree' (SafeFilePath -> TreeEntry -> BuildFile
BFCabal (PackageName -> SafeFilePath
cabalFileName PackageName
name) TreeEntry
cabalEntry)
HackageTarballResult -> RIO env HackageTarballResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure
HackageTarballResult :: Package
-> Maybe (GenericPackageDescription, TreeId)
-> HackageTarballResult
HackageTarballResult
{ htrPackage :: Package
htrPackage =
Package :: TreeKey -> Tree -> PackageCabal -> PackageIdentifier -> Package
Package
{ packageTreeKey :: TreeKey
packageTreeKey = TreeKey
treeKey'
, packageTree :: Tree
packageTree = CachedTree -> Tree
unCachedTree CachedTree
tree'
, packageIdent :: PackageIdentifier
packageIdent = PackageIdentifier
ident
, packageCabalEntry :: PackageCabal
packageCabalEntry = TreeEntry -> PackageCabal
PCCabalFile TreeEntry
cabalEntry
}
, htrFreshPackageInfo :: Maybe (GenericPackageDescription, TreeId)
htrFreshPackageInfo = (GenericPackageDescription, TreeId)
-> Maybe (GenericPackageDescription, TreeId)
forall a. a -> Maybe a
Just (GenericPackageDescription
gpd, TreeId
tid)
}