1{-# LANGUAGE MultiWayIf #-} 2{-# LANGUAGE NoImplicitPrelude #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5{-# LANGUAGE TupleSections #-} 6module Pantry.Hackage 7 ( updateHackageIndex 8 , forceUpdateHackageIndex 9 , DidUpdateOccur (..) 10 , RequireHackageIndex (..) 11 , hackageIndexTarballL 12 , getHackageTarball 13 , getHackageTarballKey 14 , getHackageCabalFile 15 , getHackagePackageVersions 16 , getHackagePackageVersionRevisions 17 , getHackageTypoCorrections 18 , UsePreferredVersions (..) 19 , HackageTarballResult(..) 20 ) where 21 22import RIO 23import RIO.Process 24import Pantry.Casa 25import Data.Aeson 26import Conduit 27import Data.Conduit.Tar 28import qualified RIO.Text as T 29import qualified RIO.Map as Map 30import Data.Text.Unsafe (unsafeTail) 31import qualified RIO.ByteString as B 32import qualified RIO.ByteString.Lazy as BL 33import Pantry.Archive 34import Pantry.Types hiding (FileType (..)) 35import Pantry.Storage hiding (TreeEntry, PackageName, Version) 36import Pantry.Tree 37import qualified Pantry.SHA256 as SHA256 38import Network.URI (parseURI) 39import Data.Time (getCurrentTime) 40import Path ((</>), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) 41import qualified Distribution.Text 42import qualified Distribution.PackageDescription as Cabal 43import qualified Data.List.NonEmpty as NE 44import Data.Text.Metrics (damerauLevenshtein) 45import System.IO (SeekMode (..)) -- Needed on GHC 8.6 46import Distribution.PackageDescription (GenericPackageDescription) 47import Distribution.Types.Version (versionNumbers) 48import Distribution.Types.VersionRange (withinRange) 49 50import qualified Hackage.Security.Client as HS 51import qualified Hackage.Security.Client.Repository.Cache as HS 52import qualified Hackage.Security.Client.Repository.Remote as HS 53import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS 54import qualified Hackage.Security.Util.Path as HS 55import qualified Hackage.Security.Util.Pretty as HS 56 57hackageRelDir :: Path Rel Dir 58hackageRelDir = either impureThrow id $ parseRelDir "hackage" 59 60hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) 61hackageDirL = pantryConfigL.to ((</> hackageRelDir) . pcRootDir) 62 63indexRelFile :: Path Rel File 64indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" 65 66-- | Where does pantry download its 01-index.tar file from Hackage? 67-- 68-- @since 0.1.0.0 69hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) 70hackageIndexTarballL = hackageDirL.to (</> indexRelFile) 71 72-- | Did an update occur when running 'updateHackageIndex'? 73-- 74-- @since 0.1.0.0 75data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred 76 77 78-- | Information returned by `getHackageTarball` 79-- 80-- @since 0.1.0.0 81data HackageTarballResult = HackageTarballResult 82 { htrPackage :: !Package 83 -- ^ Package that was loaded from Hackage tarball 84 , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) 85 -- ^ This information is only available whenever package was just loaded into pantry. 86 } 87 88-- | Download the most recent 01-index.tar file from Hackage and 89-- update the database tables. 90-- 91-- This function will only perform an update once per 'PantryConfig' 92-- for user sanity. See the return value to find out if it happened. 93-- 94-- @since 0.1.0.0 95updateHackageIndex 96 :: (HasPantryConfig env, HasLogFunc env) 97 => Maybe Utf8Builder -- ^ reason for updating, if any 98 -> RIO env DidUpdateOccur 99updateHackageIndex = updateHackageIndexInternal False 100 101-- | Same as `updateHackageIndex`, but force the database update even if hackage 102-- security tells that there is no change. This can be useful in order to make 103-- sure the database is in sync with the locally downloaded tarball 104-- 105-- @since 0.1.0.0 106forceUpdateHackageIndex 107 :: (HasPantryConfig env, HasLogFunc env) 108 => Maybe Utf8Builder 109 -> RIO env DidUpdateOccur 110forceUpdateHackageIndex = updateHackageIndexInternal True 111 112 113updateHackageIndexInternal 114 :: (HasPantryConfig env, HasLogFunc env) 115 => Bool -- ^ Force the database update. 116 -> Maybe Utf8Builder -- ^ reason for updating, if any 117 -> RIO env DidUpdateOccur 118updateHackageIndexInternal forceUpdate mreason = do 119 storage <- view $ pantryConfigL.to pcStorage 120 gateUpdate $ withWriteLock_ storage $ do 121 for_ mreason logInfo 122 pc <- view pantryConfigL 123 let HackageSecurityConfig keyIds threshold url ignoreExpiry = pcHackageSecurity pc 124 root <- view hackageDirL 125 tarball <- view hackageIndexTarballL 126 baseURI <- 127 case parseURI $ T.unpack url of 128 Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url 129 Just x -> return x 130 run <- askRunInIO 131 let logTUF = run . logInfo . fromString . HS.pretty 132 withRepo = HS.withRepository 133 HS.httpLib 134 [baseURI] 135 HS.defaultRepoOpts 136 HS.Cache 137 { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root 138 , HS.cacheLayout = HS.cabalCacheLayout 139 } 140 HS.hackageRepoLayout 141 HS.hackageIndexLayout 142 logTUF 143 didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do 144 needBootstrap <- HS.requiresBootstrap repo 145 when needBootstrap $ do 146 HS.bootstrap 147 repo 148 (map (HS.KeyId . T.unpack) keyIds) 149 (HS.KeyThreshold $ fromIntegral threshold) 150 maybeNow <- if ignoreExpiry 151 then pure Nothing 152 else Just <$> getCurrentTime 153 HS.checkForUpdates repo maybeNow 154 155 case didUpdate of 156 _ | forceUpdate -> do 157 logInfo "Forced package update is initialized" 158 updateCache tarball 159 HS.NoUpdates -> do 160 x <- needsCacheUpdate tarball 161 if x 162 then do 163 logInfo "No package index update available, but didn't update cache last time, running now" 164 updateCache tarball 165 else logInfo "No package index update available and cache up to date" 166 HS.HasUpdates -> do 167 logInfo "Updated package index downloaded" 168 updateCache tarball 169 logStickyDone "Package index cache populated" 170 where 171 -- The size of the new index tarball, ignoring the required 172 -- (by the tar spec) 1024 null bytes at the end, which will be 173 -- mutated in the future by other updates. 174 getTarballSize :: MonadIO m => Handle -> m Word 175 getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h 176 177 -- Check if the size of the tarball on the disk matches the value 178 -- in CacheUpdate. If not, we need to perform a cache update, even 179 -- if we didn't download any new information. This can be caused 180 -- by canceling an updateCache call. 181 needsCacheUpdate tarball = do 182 mres <- withStorage loadLatestCacheUpdate 183 case mres of 184 Nothing -> pure True 185 Just (FileSize cachedSize, _sha256) -> do 186 actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize 187 pure $ cachedSize /= actualSize 188 189 -- This is the one action in the Pantry codebase known to hold a 190 -- write lock on the database for an extended period of time. To 191 -- avoid failures due to SQLite locks failing, we take our own 192 -- lock outside of SQLite for this action. 193 -- 194 -- See https://github.com/commercialhaskell/stack/issues/4471 195 updateCache tarball = withStorage $ do 196 -- Alright, here's the story. In theory, we only ever append to 197 -- a tarball. Therefore, we can store the last place we 198 -- populated our cache from, and fast forward to that point. But 199 -- there are two issues with that: 200 -- 201 -- 1. Hackage may rebase, in which case we need to recalculate 202 -- everything from the beginning. Unfortunately, 203 -- hackage-security doesn't let us know when that happens. 204 -- 205 -- 2. Some paranoia about files on the filesystem getting 206 -- modified out from under us. 207 -- 208 -- Therefore, we store both the last read-to index, _and_ the 209 -- SHA256 of all of the contents until that point. When updating 210 -- the cache, we calculate the new SHA256 of the whole file, and 211 -- the SHA256 of the previous read-to point. If the old hashes 212 -- match, we can do an efficient fast forward. Otherwise, we 213 -- clear the old cache and repopulate. 214 minfo <- loadLatestCacheUpdate 215 (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do 216 logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" 217 218 newSize <- getTarballSize h 219 let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash 220 221 case minfo of 222 Nothing -> do 223 logInfo "No old cache found, populating cache from scratch" 224 newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize 225 pure (0, newHash, newSize) 226 Just (FileSize oldSize, oldHash) -> do 227 -- oldSize and oldHash come from the database, and tell 228 -- us what we cached already. Compare against 229 -- oldHashCheck, which assuming the tarball has not been 230 -- rebased will be the same as oldHash. At the same 231 -- time, calculate newHash, which is the hash of the new 232 -- content as well. 233 (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) 234 <$> ZipSink (sinkSHA256 oldSize) 235 <*> ZipSink (sinkSHA256 newSize) 236 ) 237 offset <- 238 if oldHash == oldHashCheck 239 then oldSize <$ logInfo "Updating preexisting cache, should be quick" 240 else 0 <$ do 241 logWarn $ mconcat [ 242 "Package index change detected, that's pretty unusual: " 243 , "\n Old size: " <> display oldSize 244 , "\n Old hash (orig) : " <> display oldHash 245 , "\n New hash (check): " <> display oldHashCheck 246 , "\n Forcing a recache" 247 ] 248 pure (offset, newHash, newSize) 249 250 lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash 251 when (offset == 0) clearHackageRevisions 252 populateCache tarball (fromIntegral offset) `onException` 253 lift (logStickyDone "Failed populating package index cache") 254 storeCacheUpdate (FileSize newSize) newHash 255 gateUpdate inner = do 256 pc <- view pantryConfigL 257 join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ 258 if toUpdate 259 then (False, UpdateOccurred <$ inner) 260 else (False, pure NoUpdateOccurred) 261 262-- | Populate the SQLite tables with Hackage index information. 263populateCache 264 :: (HasPantryConfig env, HasLogFunc env) 265 => Path Abs File -- ^ tarball 266 -> Integer -- ^ where to start processing from 267 -> ReaderT SqlBackend (RIO env) () 268populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do 269 lift $ logInfo "Populating package index cache ..." 270 counter <- newIORef (0 :: Int) 271 hSeek h AbsoluteSeek offset 272 runConduit $ sourceHandle h .| untar (perFile counter) 273 where 274 275 perFile counter fi 276 | FTNormal <- fileType fi 277 , Right path <- decodeUtf8' $ filePath fi 278 , Just (name, version, filename) <- parseNameVersionSuffix path = 279 if 280 | filename == "package.json" -> 281 sinkLazy >>= lift . addJSON name version 282 | filename == unSafeFilePath (cabalFileName name) -> do 283 (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version 284 285 count <- readIORef counter 286 let count' = count + 1 287 writeIORef counter count' 288 when (count' `mod` 400 == 0) $ 289 lift $ lift $ 290 logSticky $ "Processed " <> display count' <> " cabal files" 291 | otherwise -> pure () 292 | FTNormal <- fileType fi 293 , Right path <- decodeUtf8' $ filePath fi 294 , (nameT, "/preferred-versions") <- T.break (== '/') path 295 , Just name <- parsePackageName $ T.unpack nameT = do 296 lbs <- sinkLazy 297 case decodeUtf8' $ BL.toStrict lbs of 298 Left _ -> pure () -- maybe warning 299 Right p -> lift $ storePreferredVersion name p 300 | otherwise = pure () 301 302 addJSON name version lbs = 303 case eitherDecode' lbs of 304 Left e -> lift $ logError $ 305 "Error processing Hackage security metadata for " <> 306 fromString (Distribution.Text.display name) <> "-" <> 307 fromString (Distribution.Text.display version) <> ": " <> 308 fromString e 309 Right (PackageDownload sha size) -> 310 storeHackageTarballInfo name version sha $ FileSize size 311 312 addCabal name version bs = do 313 (blobTableId, _blobKey) <- storeBlob bs 314 315 storeHackageRevision name version blobTableId 316 317 breakSlash x 318 | T.null z = Nothing 319 | otherwise = Just (y, unsafeTail z) 320 where 321 (y, z) = T.break (== '/') x 322 323 parseNameVersionSuffix t1 = do 324 (name, t2) <- breakSlash t1 325 (version, filename) <- breakSlash t2 326 327 name' <- Distribution.Text.simpleParse $ T.unpack name 328 version' <- Distribution.Text.simpleParse $ T.unpack version 329 330 Just (name', version', filename) 331 332-- | Package download info from Hackage 333data PackageDownload = PackageDownload !SHA256 !Word 334instance FromJSON PackageDownload where 335 parseJSON = withObject "PackageDownload" $ \o1 -> do 336 o2 <- o1 .: "signed" 337 Object o3 <- o2 .: "targets" 338 Object o4:_ <- return $ toList o3 339 len <- o4 .: "length" 340 hashes <- o4 .: "hashes" 341 sha256' <- hashes .: "sha256" 342 sha256 <- 343 case SHA256.fromHexText sha256' of 344 Left e -> fail $ "Invalid sha256: " ++ show e 345 Right x -> return x 346 return $ PackageDownload sha256 len 347 348getHackageCabalFile 349 :: (HasPantryConfig env, HasLogFunc env) 350 => PackageIdentifierRevision 351 -> RIO env ByteString 352getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do 353 bid <- resolveCabalFileInfo pir 354 bs <- withStorage $ loadBlobById bid 355 case cfi of 356 CFIHash sha msize -> do 357 let sizeMismatch = 358 case msize of 359 Nothing -> False 360 Just size -> FileSize (fromIntegral (B.length bs)) /= size 361 shaMismatch = sha /= SHA256.hashBytes bs 362 when (sizeMismatch || shaMismatch) 363 $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) 364 _ -> pure () 365 pure bs 366 367resolveCabalFileInfo 368 :: (HasPantryConfig env, HasLogFunc env) 369 => PackageIdentifierRevision 370 -> RIO env BlobId 371resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do 372 mres <- inner 373 case mres of 374 Just res -> pure res 375 Nothing -> do 376 updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" 377 mres' <- 378 case updated of 379 UpdateOccurred -> inner 380 NoUpdateOccurred -> pure Nothing 381 case mres' of 382 Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir 383 Just res -> pure res 384 where 385 inner = 386 case cfi of 387 CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize 388 CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) 389 CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) 390 391-- | Load or download a blob by its SHA. 392loadOrDownloadBlobBySHA :: 393 (Display a, HasPantryConfig env, HasLogFunc env) 394 => a 395 -> SHA256 396 -> Maybe FileSize 397 -> RIO env (Maybe BlobId) 398loadOrDownloadBlobBySHA label sha256 msize = do 399 mresult <- byDB 400 case mresult of 401 Nothing -> do 402 case msize of 403 Nothing -> do 404 pure Nothing 405 Just size -> do 406 mblob <- casaLookupKey (BlobKey sha256 size) 407 case mblob of 408 Nothing -> do 409 pure Nothing 410 Just {} -> do 411 result <- byDB 412 case result of 413 Just blobId -> do 414 logDebug ("Pulled blob from Casa for " <> display label) 415 pure (Just blobId) 416 Nothing -> do 417 logWarn 418 ("Bug? Blob pulled from Casa not in database for " <> 419 display label) 420 pure Nothing 421 Just blobId -> do 422 logDebug ("Got blob from Pantry database for " <> display label) 423 pure (Just blobId) 424 where 425 byDB = withStorage $ loadBlobBySHA sha256 426 427-- | Given package identifier and package caches, return list of packages 428-- with the same name and the same two first version number components found 429-- in the caches. 430fuzzyLookupCandidates 431 :: (HasPantryConfig env, HasLogFunc env) 432 => PackageName 433 -> Version 434 -> RIO env FuzzyResults 435fuzzyLookupCandidates name ver0 = do 436 m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name 437 if Map.null m 438 then FRNameNotFound <$> getHackageTypoCorrections name 439 else 440 case Map.lookup ver0 m of 441 Nothing -> do 442 let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> 443 case Map.maxView revs of 444 Nothing -> error "fuzzyLookupCandidates: no revisions" 445 Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) 446 case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of 447 Just vers -> withVers vers 448 Nothing -> 449 case NE.nonEmpty $ Map.toList m of 450 Nothing -> error "fuzzyLookupCandidates: no versions" 451 Just vers -> withVers vers 452 Just revisions -> 453 let pirs = map 454 (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) 455 (Map.elems revisions) 456 in case NE.nonEmpty pirs of 457 Nothing -> error "fuzzyLookupCandidates: no revisions" 458 Just pirs' -> pure $ FRRevisionNotFound pirs' 459 where 460 sameMajor v = toMajorVersion v == toMajorVersion ver0 461 462toMajorVersion :: Version -> [Int] 463toMajorVersion v = 464 case versionNumbers v of 465 [] -> [0, 0] 466 [a] -> [a, 0] 467 a:b:_ -> [a, b] 468 469-- | Try to come up with typo corrections for given package identifier 470-- using Hackage package names. This can provide more user-friendly 471-- information in error messages. 472-- 473-- @since 0.1.0.0 474getHackageTypoCorrections 475 :: (HasPantryConfig env, HasLogFunc env) 476 => PackageName 477 -> RIO env [PackageName] 478getHackageTypoCorrections name1 = 479 withStorage $ sinkHackagePackageNames 480 (\name2 -> name1 `distance` name2 < 4) 481 (takeC 10 .| sinkList) 482 where 483 distance = damerauLevenshtein `on` (T.pack . packageNameString) 484 485-- | Should we pay attention to Hackage's preferred versions? 486-- 487-- @since 0.1.0.0 488data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions 489 deriving Show 490 491-- | Require that the Hackage index is populated. 492-- 493-- @since 0.1.0.0 494data RequireHackageIndex 495 = YesRequireHackageIndex 496 -- ^ If there is nothing in the Hackage index, then perform an update 497 | NoRequireHackageIndex 498 -- ^ Do not perform an update 499 deriving Show 500 501initializeIndex 502 :: (HasPantryConfig env, HasLogFunc env) 503 => RequireHackageIndex 504 -> RIO env () 505initializeIndex NoRequireHackageIndex = pure () 506initializeIndex YesRequireHackageIndex = do 507 cabalCount <- withStorage countHackageCabals 508 when (cabalCount == 0) $ void $ 509 updateHackageIndex $ Just $ "No information from Hackage index, updating" 510 511-- | Returns the versions of the package available on Hackage. 512-- 513-- @since 0.1.0.0 514getHackagePackageVersions 515 :: (HasPantryConfig env, HasLogFunc env) 516 => RequireHackageIndex 517 -> UsePreferredVersions 518 -> PackageName -- ^ package name 519 -> RIO env (Map Version (Map Revision BlobKey)) 520getHackagePackageVersions req usePreferred name = do 521 initializeIndex req 522 withStorage $ do 523 mpreferred <- 524 case usePreferred of 525 UsePreferredVersions -> loadPreferredVersion name 526 IgnorePreferredVersions -> pure Nothing 527 let predicate :: Version -> Map Revision BlobKey -> Bool 528 predicate = fromMaybe (\_ _ -> True) $ do 529 preferredT1 <- mpreferred 530 preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 531 vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 532 Just $ \v _ -> withinRange v vr 533 Map.filterWithKey predicate <$> loadHackagePackageVersions name 534 535-- | Returns the versions of the package available on Hackage. 536-- 537-- @since 0.1.0.0 538getHackagePackageVersionRevisions 539 :: (HasPantryConfig env, HasLogFunc env) 540 => RequireHackageIndex 541 -> PackageName -- ^ package name 542 -> Version -- ^ package version 543 -> RIO env (Map Revision BlobKey) 544getHackagePackageVersionRevisions req name version = do 545 initializeIndex req 546 withStorage $ 547 Map.map snd <$> loadHackagePackageVersion name version 548 549withCachedTree 550 :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 551 => RawPackageLocationImmutable 552 -> PackageName 553 -> Version 554 -> BlobId -- ^ cabal file contents 555 -> RIO env HackageTarballResult 556 -> RIO env HackageTarballResult 557withCachedTree rpli name ver bid inner = do 558 mres <- withStorage $ loadHackageTree rpli name ver bid 559 case mres of 560 Just package -> pure $ HackageTarballResult package Nothing 561 Nothing -> do 562 htr <- inner 563 withStorage $ 564 storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr 565 pure htr 566 567getHackageTarballKey 568 :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 569 => PackageIdentifierRevision 570 -> RIO env TreeKey 571getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do 572 mres <- withStorage $ loadHackageTreeKey name ver sha 573 case mres of 574 Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing 575 Just key -> pure key 576getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing 577 578getHackageTarball 579 :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 580 => PackageIdentifierRevision 581 -> Maybe TreeKey 582 -> RIO env HackageTarballResult 583getHackageTarball pir mtreeKey = do 584 let PackageIdentifierRevision name ver _cfi = pir 585 cabalFile <- resolveCabalFileInfo pir 586 let rpli = RPLIHackage pir mtreeKey 587 withCachedTree rpli name ver cabalFile $ do 588 cabalFileKey <- withStorage $ getBlobKey cabalFile 589 mpair <- withStorage $ loadHackageTarballInfo name ver 590 (sha, size) <- 591 case mpair of 592 Just pair -> pure pair 593 Nothing -> do 594 let exc = NoHackageCryptographicHash $ PackageIdentifier name ver 595 updated <- updateHackageIndex $ Just $ display exc <> ", updating" 596 mpair2 <- 597 case updated of 598 UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver 599 NoUpdateOccurred -> pure Nothing 600 case mpair2 of 601 Nothing -> throwIO exc 602 Just pair2 -> pure pair2 603 pc <- view pantryConfigL 604 let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc 605 url = 606 mconcat 607 [ urlPrefix 608 , "package/" 609 , T.pack $ Distribution.Text.display name 610 , "-" 611 , T.pack $ Distribution.Text.display ver 612 , ".tar.gz" 613 ] 614 (_, _, package, cachedTree) <- 615 getArchive 616 rpli 617 RawArchive 618 { raLocation = ALUrl url 619 , raHash = Just sha 620 , raSize = Just size 621 , raSubdir = T.empty -- no subdirs on Hackage 622 } 623 RawPackageMetadata 624 { rpmName = Just name 625 , rpmVersion = Just ver 626 , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree 627 } 628 case cachedTree of 629 CachedTreeMap m -> do 630 let ft = 631 case packageCabalEntry package of 632 PCCabalFile (TreeEntry _ ft') -> ft' 633 _ -> error "Impossible: Hackage does not support hpack" 634 cabalEntry = TreeEntry cabalFileKey ft 635 (cabalBS, cabalBlobId) <- 636 withStorage $ do 637 let BlobKey sha' _ = cabalFileKey 638 mcabalBS <- loadBlobBySHA sha' 639 case mcabalBS of 640 Nothing -> 641 error $ 642 "Invariant violated, cabal file key: " ++ show cabalFileKey 643 Just bid -> (, bid) <$> loadBlobById bid 644 let tree' = CachedTreeMap $ Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m 645 ident = PackageIdentifier name ver 646 (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS 647 let gpdIdent = Cabal.package $ Cabal.packageDescription gpd 648 when (ident /= gpdIdent) $ 649 throwIO $ 650 MismatchedCabalFileForHackage 651 pir 652 Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} 653 (tid, treeKey') <- 654 withStorage $ 655 storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) 656 pure 657 HackageTarballResult 658 { htrPackage = 659 Package 660 { packageTreeKey = treeKey' 661 , packageTree = unCachedTree tree' 662 , packageIdent = ident 663 , packageCabalEntry = PCCabalFile cabalEntry 664 } 665 , htrFreshPackageInfo = Just (gpd, tid) 666 } 667