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