1{-# LANGUAGE TypeApplications #-} 2{-# LANGUAGE NamedFieldPuns #-} 3{-# LANGUAGE NoImplicitPrelude #-} 4{-# LANGUAGE BangPatterns #-} 5{-# LANGUAGE TemplateHaskell #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE QuasiQuotes #-} 8{-# LANGUAGE TypeFamilies #-} 9{-# LANGUAGE MultiParamTypeClasses #-} 10{-# LANGUAGE GeneralizedNewtypeDeriving #-} 11{-# LANGUAGE GADTs #-} 12{-# LANGUAGE OverloadedStrings #-} 13{-# LANGUAGE ViewPatterns #-} 14{-# LANGUAGE LambdaCase #-} 15{-# LANGUAGE UndecidableInstances #-} 16{-# LANGUAGE DerivingStrategies #-} 17{-# LANGUAGE StandaloneDeriving #-} 18{-# LANGUAGE TupleSections #-} 19{-# LANGUAGE DataKinds #-} 20{-# LANGUAGE FlexibleInstances #-} 21module Pantry.Storage 22 ( SqlBackend 23 , initStorage 24 , withStorage 25 , migrateAll 26 , storeBlob 27 , loadBlob 28 , loadBlobById 29 , loadBlobBySHA 30 , allBlobsSource 31 , allHackageCabalRawPackageLocations 32 , allBlobsCount 33 , allHackageCabalCount 34 , getBlobKey 35 , loadURLBlob 36 , storeURLBlob 37 , clearHackageRevisions 38 , storeHackageRevision 39 , loadHackagePackageVersions 40 , loadHackagePackageVersion 41 , loadLatestCacheUpdate 42 , storeCacheUpdate 43 , storeHackageTarballInfo 44 , loadHackageTarballInfo 45 , getHPackBlobKeyById 46 , storeTree 47 , loadTree 48 , storeHPack 49 , loadPackageById 50 , getPackageNameById 51 , getPackageNameId 52 , getVersionId 53 , getTreeForKey 54 , storeHackageTree 55 , loadHackageTree 56 , loadHackageTreeKey 57 , storeArchiveCache 58 , loadArchiveCache 59 , storeRepoCache 60 , loadRepoCache 61 , storePreferredVersion 62 , loadPreferredVersion 63 , sinkHackagePackageNames 64 , loadCabalBlobKey 65 , hpackToCabal 66 , countHackageCabals 67 , getSnapshotCacheByHash 68 , getSnapshotCacheId 69 , storeSnapshotModuleCache 70 , loadExposedModulePackages 71 , PackageNameId 72 , PackageName 73 , VersionId 74 , ModuleNameId 75 , Version 76 , versionVersion 77 , Unique(..) 78 , EntityField(..) 79 -- avoid warnings 80 , BlobId 81 , Key(unBlobKey) 82 , HackageCabalId 83 , HackageCabal(..) 84 , HackageTarballId 85 , CacheUpdateId 86 , FilePathId 87 , Tree(..) 88 , TreeId 89 , TreeEntry(..) 90 , TreeEntryId 91 , ArchiveCacheId 92 , RepoCacheId 93 , PreferredVersionsId 94 , UrlBlobId 95 , SnapshotCacheId 96 , PackageExposedModuleId 97 , loadCachedTree 98 , CachedTree (..) 99 , unCachedTree 100 ) where 101 102import RIO hiding (FilePath) 103import RIO.Process 104import qualified RIO.ByteString as B 105import qualified Pantry.Types as P 106import qualified RIO.List as List 107import qualified RIO.FilePath as FilePath 108import RIO.FilePath ((</>), takeDirectory) 109import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) 110import Database.Persist 111import Database.Persist.Sqlite 112import Database.Persist.TH 113import RIO.Orphans (HasResourceMap) 114import qualified Pantry.SHA256 as SHA256 115import qualified RIO.Map as Map 116import qualified RIO.Text as T 117import RIO.Time (UTCTime, getCurrentTime) 118import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile) 119import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur) 120import Pantry.HPack (hpackVersion, hpack) 121import Conduit 122import Data.Acquire (with) 123import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..), connRDBMS) 124import qualified Pantry.SQLite as SQLite 125 126share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 127-- Raw blobs 128Blob 129 sha SHA256 130 size FileSize 131 contents ByteString 132 UniqueBlobSha sha 133-- Previously downloaded blobs from given URLs. 134-- May change over time, so we keep a time column too. 135UrlBlob sql=url_blob 136 url Text 137 blob BlobId 138 time UTCTime 139 UniqueUrlTime url time 140 141-- For normalization, and avoiding storing strings in a bunch of 142-- tables. 143PackageName 144 name P.PackageNameP 145 UniquePackageName name 146Version 147 version P.VersionP 148 UniqueVersion version 149FilePath 150 path P.SafeFilePath 151 UniqueSfp path 152 153-- Secure download information for a package on Hackage. This does not 154-- contain revision information, since sdist tarballs are (blessedly) 155-- unmodified on Hackage. 156HackageTarball 157 name PackageNameId 158 version VersionId 159 sha SHA256 160 size FileSize 161 UniqueHackageTarball name version 162 163-- An individual cabal file from Hackage, representing a specific 164-- revision. 165HackageCabal 166 name PackageNameId 167 version VersionId 168 revision P.Revision 169 cabal BlobId 170 171 -- If available: the full tree containing the HackageTarball 172 -- contents with the cabal file modified. 173 tree TreeId Maybe 174 UniqueHackage name version revision 175 176-- Any preferred-version information from Hackage 177PreferredVersions 178 name PackageNameId 179 preferred Text 180 UniquePreferred name 181 182-- Last time we downloaded a 01-index.tar file from Hackage and 183-- updated the three previous tables. 184CacheUpdate 185 -- When did we do the update? 186 time UTCTime 187 188 -- How big was the file when we updated, ignoring the last two 189 -- all-null 512-byte blocks. 190 size FileSize 191 192 -- SHA256 of the first 'size' bytes of the file 193 sha SHA256 194 195-- A tree containing a Haskell package. See associated TreeEntry 196-- table. 197Tree 198 key BlobId 199 200 -- If the treeCabal field is Nothing, it means the Haskell package 201 -- doesn't have a corresponding cabal file for it. This may be the case 202 -- for haskell package referenced by git repository with only a hpack file. 203 cabal BlobId Maybe 204 cabalType FileType 205 name PackageNameId 206 version VersionId 207 UniqueTree key 208 209HPack 210 tree TreeId 211 212 -- hpack version used for generating this cabal file 213 version VersionId 214 215 -- Generated cabal file for the given tree and hpack version 216 cabalBlob BlobId 217 cabalPath FilePathId 218 219 UniqueHPack tree version 220 221-- An individual file within a Tree. 222TreeEntry 223 tree TreeId 224 path FilePathId 225 blob BlobId 226 type FileType 227 228-- Like UrlBlob, but stores the contents as a Tree. 229ArchiveCache 230 time UTCTime 231 url Text 232 subdir Text 233 sha SHA256 234 size FileSize 235 tree TreeId 236 237-- Like ArchiveCache, but for a Repo. 238RepoCache 239 time UTCTime 240 url Text 241 type P.RepoType 242 commit Text 243 subdir Text 244 tree TreeId 245 246-- Identified by sha of all immutable packages contained in a snapshot 247-- and GHC version used 248SnapshotCache 249 sha SHA256 250 UniqueSnapshotCache sha 251 252PackageExposedModule 253 snapshotCache SnapshotCacheId 254 module ModuleNameId 255 package PackageNameId 256 257ModuleName 258 name P.ModuleNameP 259 UniqueModule name 260|] 261 262initStorage 263 :: HasLogFunc env 264 => Path Abs File -- ^ storage file 265 -> (P.Storage -> RIO env a) 266 -> RIO env a 267initStorage = 268 SQLite.initStorage "Pantry" migrateAll 269 270withStorage 271 :: (HasPantryConfig env, HasLogFunc env) 272 => ReaderT SqlBackend (RIO env) a 273 -> RIO env a 274withStorage action = 275 flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) 276 277-- | This is a helper type to distinguish db queries between different rdbms backends. The important 278-- part is that the affects described in this data type should be semantically equivalent between 279-- the supported engines. 280data RdbmsActions env a = RdbmsActions 281 { raSqlite :: !(ReaderT SqlBackend (RIO env) a) 282 -- ^ A query that is specific to SQLite 283 , raPostgres :: !(ReaderT SqlBackend (RIO env) a) 284 -- ^ A query that is specific to PostgreSQL 285 } 286 287-- | This function provides a way to create queries supported by multiple sql backends. 288rdbmsAwareQuery 289 :: RdbmsActions env a 290 -> ReaderT SqlBackend (RIO env) a 291rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do 292 rdbms <- Pantry.Types.connRDBMS <$> ask 293 case rdbms of 294 "postgresql" -> raPostgres 295 "sqlite" -> raSqlite 296 _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" 297 298 299getPackageNameById 300 :: PackageNameId 301 -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) 302getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get 303 304 305getPackageNameId 306 :: P.PackageName 307 -> ReaderT SqlBackend (RIO env) PackageNameId 308getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP 309 310getVersionId 311 :: P.Version 312 -> ReaderT SqlBackend (RIO env) VersionId 313getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP 314 315storeBlob 316 :: ByteString 317 -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) 318storeBlob bs = do 319 let sha = SHA256.hashBytes bs 320 size = FileSize $ fromIntegral $ B.length bs 321 keys <- selectKeysList [BlobSha ==. sha] [] 322 key <- 323 case keys of 324 [] -> 325 rdbmsAwareQuery 326 RdbmsActions 327 { raSqlite = 328 insert Blob {blobSha = sha, blobSize = size, blobContents = bs} 329 , raPostgres = 330 do rawExecute 331 "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" 332 [ toPersistValue sha 333 , toPersistValue size 334 , toPersistValue bs 335 ] 336 rawSql 337 "SELECT blob.id FROM blob WHERE blob.sha = ?" 338 [toPersistValue sha] >>= \case 339 [Single key] -> pure key 340 _ -> 341 error 342 "soreBlob: there was a critical problem storing a blob." 343 } 344 key:rest -> assert (null rest) (pure key) 345 pure (key, P.BlobKey sha size) 346 347loadBlob :: 348 HasLogFunc env 349 => BlobKey 350 -> ReaderT SqlBackend (RIO env) (Maybe ByteString) 351loadBlob (P.BlobKey sha size) = do 352 ment <- getBy $ UniqueBlobSha sha 353 case ment of 354 Nothing -> pure Nothing 355 Just (Entity _ bt) 356 | blobSize bt == size -> pure $ Just $ blobContents bt 357 | otherwise -> 358 Nothing <$ lift (logWarn $ 359 "Mismatched blob size detected for SHA " <> display sha <> 360 ". Expected size: " <> display size <> 361 ". Actual size: " <> display (blobSize bt)) 362 363loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) 364loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] 365 366loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString 367loadBlobById bid = do 368 mbt <- get bid 369 case mbt of 370 Nothing -> error "loadBlobById: ID doesn't exist in database" 371 Just bt -> pure $ blobContents bt 372 373allBlobsSource :: 374 HasResourceMap env 375 => Maybe BlobId 376 -- ^ For some x, yield blob whose id>x. 377 -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) () 378allBlobsSource mblobId = 379 selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .| 380 mapC ((entityKey &&& blobContents . entityVal)) 381 382-- | Pull all hackage cabal entries from the database as 383-- 'RawPackageLocationImmutable'. We do a manual join rather than 384-- dropping to raw SQL, and Esqueleto would add more deps. 385allHackageCabalRawPackageLocations :: 386 HasResourceMap env 387 => Maybe HackageCabalId 388 -- ^ For some x, yield cabals whose id>x. 389 -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable) 390allHackageCabalRawPackageLocations mhackageId = do 391 hackageCabals :: Map HackageCabalId HackageCabal <- 392 selectTuples 393 [HackageCabalId >. hackageId | Just hackageId <- [mhackageId]] 394 [] 395 packageNames :: Map PackageNameId PackageName <- selectTuples [] [] 396 versions :: Map VersionId Version <- selectTuples [] [] 397 for 398 hackageCabals 399 (\hackageCabal -> 400 case Map.lookup (hackageCabalName hackageCabal) packageNames of 401 Nothing -> error "no such package name" 402 Just packageName -> 403 let P.PackageNameP packageName' = packageNameName packageName 404 in case Map.lookup (hackageCabalVersion hackageCabal) versions of 405 Nothing -> error "no such version" 406 Just version -> 407 let P.VersionP version' = versionVersion version 408 in do mtree <- 409 case hackageCabalTree hackageCabal of 410 Just key -> selectFirst [TreeId ==. key] [] 411 Nothing -> pure Nothing 412 mblobKey <- 413 maybe 414 (pure Nothing) 415 (fmap Just . getBlobKey) 416 (fmap (treeKey . entityVal) mtree) 417 pure 418 (P.RPLIHackage 419 (P.PackageIdentifierRevision 420 packageName' 421 version' 422 (P.CFIRevision 423 (hackageCabalRevision hackageCabal))) 424 (fmap P.TreeKey mblobKey))) 425 where 426 selectTuples pred sort = 427 fmap (Map.fromList . map tuple) (selectList pred sort) 428 tuple (Entity k v) = (k, v) 429 430allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int 431allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]] 432 433allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int 434allHackageCabalCount mhackageCabalId = 435 count 436 [ HackageCabalId >. hackageCabalId 437 | Just hackageCabalId <- [mhackageCabalId] 438 ] 439 440getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey 441getBlobKey bid = do 442 res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] 443 case res of 444 [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid 445 [(Single sha, Single size)] -> pure $ P.BlobKey sha size 446 _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) 447 448getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) 449getBlobId (P.BlobKey sha size) = do 450 res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" 451 [toPersistValue sha, toPersistValue size] 452 pure $ listToMaybe $ map unSingle res 453 454loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) 455loadURLBlob url = do 456 ment <- rawSql 457 "SELECT blob.contents\n\ 458 \FROM blob, url_blob\n\ 459 \WHERE url=?\ 460 \ AND url_blob.blob=blob.id\n\ 461 \ ORDER BY url_blob.time DESC" 462 [toPersistValue url] 463 case ment of 464 [] -> pure Nothing 465 (Single bs) : _ -> pure $ Just bs 466 467storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () 468storeURLBlob url blob = do 469 (blobId, _) <- storeBlob blob 470 now <- getCurrentTime 471 insert_ UrlBlob 472 { urlBlobUrl = url 473 , urlBlobBlob = blobId 474 , urlBlobTime = now 475 } 476 477clearHackageRevisions :: ReaderT SqlBackend (RIO env) () 478clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) 479 480storeHackageRevision :: 481 P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () 482storeHackageRevision name version key = do 483 nameid <- getPackageNameId name 484 versionid <- getVersionId version 485 rev <- count 486 [ HackageCabalName ==. nameid 487 , HackageCabalVersion ==. versionid 488 ] 489 insert_ HackageCabal 490 { hackageCabalName = nameid 491 , hackageCabalVersion = versionid 492 , hackageCabalRevision = Revision (fromIntegral rev) 493 , hackageCabalCabal = key 494 , hackageCabalTree = Nothing 495 } 496 497loadHackagePackageVersions 498 :: P.PackageName 499 -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) 500loadHackagePackageVersions name = do 501 nameid <- getPackageNameId name 502 -- would be better with esequeleto 503 (Map.fromListWith Map.union . map go) <$> rawSql 504 "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ 505 \FROM hackage_cabal as hackage, version, blob\n\ 506 \WHERE hackage.name=?\n\ 507 \AND hackage.version=version.id\n\ 508 \AND hackage.cabal=blob.id" 509 [toPersistValue nameid] 510 where 511 go (Single revision, Single (P.VersionP version), Single key, Single size) = 512 (version, Map.singleton revision (P.BlobKey key size)) 513 514loadHackagePackageVersion 515 :: P.PackageName 516 -> P.Version 517 -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) 518loadHackagePackageVersion name version = do 519 nameid <- getPackageNameId name 520 versionid <- getVersionId version 521 -- would be better with esequeleto 522 (Map.fromList . map go) <$> rawSql 523 "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ 524 \FROM hackage_cabal as hackage, version, blob\n\ 525 \WHERE hackage.name=?\n\ 526 \AND hackage.version=?\n\ 527 \AND hackage.cabal=blob.id" 528 [toPersistValue nameid, toPersistValue versionid] 529 where 530 go (Single revision, Single sha, Single size, Single bid) = 531 (revision, (bid, P.BlobKey sha size)) 532 533loadLatestCacheUpdate 534 :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) 535loadLatestCacheUpdate = 536 fmap go <$> selectFirst [] [Desc CacheUpdateTime] 537 where 538 go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) 539 540storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () 541storeCacheUpdate size sha = do 542 now <- getCurrentTime 543 insert_ CacheUpdate 544 { cacheUpdateTime = now 545 , cacheUpdateSize = size 546 , cacheUpdateSha = sha 547 } 548 549storeHackageTarballInfo 550 :: P.PackageName 551 -> P.Version 552 -> SHA256 553 -> FileSize 554 -> ReaderT SqlBackend (RIO env) () 555storeHackageTarballInfo name version sha size = do 556 nameid <- getPackageNameId name 557 versionid <- getVersionId version 558 void $ insertBy HackageTarball 559 { hackageTarballName = nameid 560 , hackageTarballVersion = versionid 561 , hackageTarballSha = sha 562 , hackageTarballSize = size 563 } 564 565loadHackageTarballInfo 566 :: P.PackageName 567 -> P.Version 568 -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) 569loadHackageTarballInfo name version = do 570 nameid <- getPackageNameId name 571 versionid <- getVersionId version 572 fmap go <$> getBy (UniqueHackageTarball nameid versionid) 573 where 574 go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) 575 576storeCabalFile :: 577 ByteString 578 -> P.PackageName 579 -> ReaderT SqlBackend (RIO env) BlobId 580storeCabalFile cabalBS pkgName = do 581 (bid, _) <- storeBlob cabalBS 582 let cabalFile = P.cabalFileName pkgName 583 _ <- insertBy FilePath {filePathPath = cabalFile} 584 return bid 585 586loadFilePath :: 587 SafeFilePath 588 -> ReaderT SqlBackend (RIO env) (Entity FilePath) 589loadFilePath path = do 590 fp <- getBy $ UniqueSfp path 591 case fp of 592 Nothing -> 593 error $ 594 "loadFilePath: No row found for " <> 595 (T.unpack $ P.unSafeFilePath path) 596 Just record -> return record 597 598loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) 599loadHPackTreeEntity tid = do 600 filepath <- loadFilePath P.hpackSafeFilePath 601 let filePathId :: FilePathId = entityKey filepath 602 hpackTreeEntry <- 603 selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] 604 case hpackTreeEntry of 605 Nothing -> 606 error $ 607 "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ 608 show tid 609 Just record -> return record 610 611storeHPack :: 612 (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 613 => P.RawPackageLocationImmutable 614 -> TreeId 615 -> ReaderT SqlBackend (RIO env) (Key HPack) 616storeHPack rpli tid = do 617 vid <- hpackVersionId 618 hpackRecord <- getBy (UniqueHPack tid vid) 619 case hpackRecord of 620 Nothing -> generateHPack rpli tid vid 621 Just record -> return $ entityKey record 622 623loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey 624loadCabalBlobKey hpackId = do 625 hpackRecord <- getJust hpackId 626 getBlobKey $ hPackCabalBlob hpackRecord 627 628generateHPack :: 629 (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 630 => P.RawPackageLocationImmutable -- ^ for exceptions 631 -> TreeId 632 -> VersionId 633 -> ReaderT SqlBackend (RIO env) (Key HPack) 634generateHPack rpli tid vid = do 635 tree <- getTree tid 636 (pkgName, cabalBS) <- hpackToCabalS rpli tree 637 bid <- storeCabalFile cabalBS pkgName 638 let cabalFile = P.cabalFileName pkgName 639 fid <- insertBy FilePath {filePathPath = cabalFile} 640 let hpackRecord = 641 HPack 642 { hPackTree = tid 643 , hPackVersion = vid 644 , hPackCabalBlob = bid 645 , hPackCabalPath = either entityKey id fid 646 } 647 either entityKey id <$> insertBy hpackRecord 648 649 650hpackVersionId :: 651 (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 652 => ReaderT SqlBackend (RIO env) VersionId 653hpackVersionId = do 654 hpackSoftwareVersion <- lift hpackVersion 655 fmap (either entityKey id) $ 656 insertBy $ 657 Version {versionVersion = P.VersionP hpackSoftwareVersion} 658 659 660getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId 661getFilePathId sfp = 662 selectKeysList [FilePathPath ==. sfp] [] >>= \case 663 [fpId] -> pure fpId 664 [] -> 665 rdbmsAwareQuery 666 RdbmsActions 667 { raSqlite = insert $ FilePath sfp 668 , raPostgres = 669 do rawExecute 670 "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" 671 [toPersistValue sfp] 672 rawSql 673 "SELECT id FROM file_path WHERE path = ?" 674 [toPersistValue sfp] >>= \case 675 [Single key] -> pure key 676 _ -> 677 error 678 "getFilePathId: there was a critical problem storing a blob." 679 } 680 _ -> 681 error $ 682 "getFilePathId: FilePath unique constraint key is violated for: " ++ fp 683 where 684 fp = T.unpack (P.unSafeFilePath sfp) 685 686-- | A tree that has already been stored in the database 687newtype CachedTree 688 = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId)) 689 deriving Show 690 691unCachedTree :: CachedTree -> P.Tree 692unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m 693 694storeTree 695 :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 696 => P.RawPackageLocationImmutable -- ^ for exceptions 697 -> P.PackageIdentifier 698 -> CachedTree 699 -> P.BuildFile 700 -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) 701storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do 702 (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree 703 (cabalid, ftype) <- case buildFile of 704 P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) 705 P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do 706 buildTypeid <- loadBlobBySHA btypeSha 707 buildid <- 708 case buildTypeid of 709 Just buildId -> pure buildId 710 Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha) 711 return (Just buildid, ftype) 712 nameid <- getPackageNameId name 713 versionid <- getVersionId version 714 etid <- insertBy Tree 715 { treeKey = bid 716 , treeCabal = cabalid 717 , treeCabalType = ftype 718 , treeName = nameid 719 , treeVersion = versionid 720 } 721 722 (tid, pTreeKey) <- case etid of 723 Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches 724 Right tid -> do 725 for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do 726 sfpid <- getFilePathId sfp 727 insert_ TreeEntry 728 { treeEntryTree = tid 729 , treeEntryPath = sfpid 730 , treeEntryBlob = bid' 731 , treeEntryType = ft 732 } 733 pure (tid, P.TreeKey blobKey) 734 case buildFile of 735 P.BFHpack _ -> storeHPack rpli tid >> return () 736 P.BFCabal _ _ -> return () 737 return (tid, pTreeKey) 738 739getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree 740getTree tid = do 741 (mts :: Maybe Tree) <- get tid 742 ts <- 743 case mts of 744 Nothing -> 745 error $ "getTree: invalid foreign key " ++ show tid 746 Just ts -> pure ts 747 loadTreeByEnt $ Entity tid ts 748 749loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) 750loadTree key = do 751 ment <- getTreeForKey key 752 case ment of 753 Nothing -> pure Nothing 754 Just ent -> Just <$> loadTreeByEnt ent 755 756getTreeForKey 757 :: TreeKey 758 -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) 759getTreeForKey (P.TreeKey key) = do 760 mbid <- getBlobId key 761 case mbid of 762 Nothing -> pure Nothing 763 Just bid -> getBy $ UniqueTree bid 764 765loadPackageById :: 766 (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 767 => P.RawPackageLocationImmutable -- ^ for exceptions 768 -> TreeId 769 -> ReaderT SqlBackend (RIO env) Package 770loadPackageById rpli tid = do 771 (mts :: Maybe Tree) <- get tid 772 ts <- 773 case mts of 774 Nothing -> 775 error $ "loadPackageById: invalid foreign key " ++ show tid 776 Just ts -> pure ts 777 (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts 778 (blobKey :: BlobKey) <- getBlobKey $ treeKey ts 779 (mname :: Maybe PackageName) <- get $ treeName ts 780 name <- 781 case mname of 782 Nothing -> 783 error $ 784 "loadPackageByid: invalid foreign key " ++ show (treeName ts) 785 Just (PackageName (P.PackageNameP name)) -> pure name 786 mversion <- get $ treeVersion ts 787 version <- 788 case mversion of 789 Nothing -> 790 error $ 791 "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) 792 Just (Version (P.VersionP version)) -> pure version 793 let ident = P.PackageIdentifier name version 794 (packageEntry, mtree) <- 795 case treeCabal ts of 796 Just keyBlob -> do 797 cabalKey <- getBlobKey keyBlob 798 return 799 ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) 800 , tree) 801 Nothing -> do 802 hpackVid <- hpackVersionId 803 hpackEntity <- getBy (UniqueHPack tid hpackVid) 804 let (P.TreeMap tmap) = tree 805 cabalFile = P.cabalFileName name 806 case hpackEntity of 807 Nothing 808 -- This case will happen when you either 809 -- update stack with a new hpack version or 810 -- use different hpack version via 811 -- --with-hpack option. 812 -> do 813 (hpackId :: HPackId) <- storeHPack rpli tid 814 hpackRecord <- getJust hpackId 815 getHPackCabalFile hpackRecord ts tmap cabalFile 816 Just (Entity _ item) -> 817 getHPackCabalFile item ts tmap cabalFile 818 pure 819 Package 820 { packageTreeKey = P.TreeKey blobKey 821 , packageTree = mtree 822 , packageCabalEntry = packageEntry 823 , packageIdent = ident 824 } 825 826getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey 827getHPackBlobKey hpackRecord = do 828 let treeId = hPackTree hpackRecord 829 hpackEntity <- loadHPackTreeEntity treeId 830 getBlobKey (treeEntryBlob $ entityVal hpackEntity) 831 832getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey 833getHPackBlobKeyById hpackId = do 834 hpackRecord <- getJust hpackId 835 getHPackBlobKey hpackRecord 836 837 838getHPackCabalFile :: 839 (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 840 => HPack 841 -> Tree 842 -> Map SafeFilePath P.TreeEntry 843 -> SafeFilePath 844 -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) 845getHPackCabalFile hpackRecord ts tmap cabalFile = do 846 cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) 847 hpackKey <- getHPackBlobKey hpackRecord 848 hpackSoftwareVersion <- lift hpackVersion 849 let fileType = treeCabalType ts 850 cbTreeEntry = P.TreeEntry cabalKey fileType 851 hpackTreeEntry = P.TreeEntry hpackKey fileType 852 tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap 853 return 854 ( P.PCHpack $ 855 P.PHpack 856 { P.phOriginal = hpackTreeEntry 857 , P.phGenerated = cbTreeEntry 858 , P.phVersion = hpackSoftwareVersion 859 } 860 , tree) 861 862loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree 863loadTreeByEnt (Entity tid _t) = do 864 entries <- rawSql 865 "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ 866 \FROM tree_entry, blob, file_path\n\ 867 \WHERE tree_entry.tree=?\n\ 868 \AND tree_entry.blob=blob.id\n\ 869 \AND tree_entry.path=file_path.id" 870 [toPersistValue tid] 871 pure $ P.TreeMap $ Map.fromList $ map 872 (\(Single sfp, Single sha, Single size, Single ft) -> 873 (sfp, P.TreeEntry (P.BlobKey sha size) ft)) 874 entries 875 876storeHackageTree 877 :: P.PackageName 878 -> P.Version 879 -> BlobId 880 -> P.TreeKey 881 -> ReaderT SqlBackend (RIO env) () 882storeHackageTree name version cabal treeKey' = do 883 nameid <- getPackageNameId name 884 versionid <- getVersionId version 885 ment <- getTreeForKey treeKey' 886 for_ ment $ \ent -> updateWhere 887 [ HackageCabalName ==. nameid 888 , HackageCabalVersion ==. versionid 889 , HackageCabalCabal ==. cabal 890 ] 891 [HackageCabalTree =. Just (entityKey ent)] 892 893loadHackageTreeKey 894 :: P.PackageName 895 -> P.Version 896 -> SHA256 897 -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) 898loadHackageTreeKey name ver sha = do 899 res <- rawSql 900 "SELECT treeblob.sha, treeblob.size\n\ 901 \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ 902 \WHERE package_name.name=?\n\ 903 \AND version.version=?\n\ 904 \AND cabalblob.sha=?\n\ 905 \AND hackage_cabal.name=package_name.id\n\ 906 \AND hackage_cabal.version=version.id\n\ 907 \AND hackage_cabal.cabal=cabalblob.id\n\ 908 \AND hackage_cabal.tree=tree.id\n\ 909 \AND tree.key=treeblob.id" 910 [ toPersistValue $ P.PackageNameP name 911 , toPersistValue $ P.VersionP ver 912 , toPersistValue sha 913 ] 914 case res of 915 [] -> pure Nothing 916 (Single treesha, Single size):_ -> 917 pure $ Just $ P.TreeKey $ P.BlobKey treesha size 918 919loadHackageTree 920 :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 921 => P.RawPackageLocationImmutable -- ^ for exceptions 922 -> P.PackageName 923 -> P.Version 924 -> BlobId 925 -> ReaderT SqlBackend (RIO env) (Maybe Package) 926loadHackageTree rpli name ver bid = do 927 nameid <- getPackageNameId name 928 versionid <- getVersionId ver 929 ment <- selectFirst 930 [ HackageCabalName ==. nameid 931 , HackageCabalVersion ==. versionid 932 , HackageCabalCabal ==. bid 933 , HackageCabalTree !=. Nothing 934 ] 935 [] 936 case ment of 937 Nothing -> pure Nothing 938 Just (Entity _ hc) -> 939 case hackageCabalTree hc of 940 Nothing -> assert False $ pure Nothing 941 Just tid -> Just <$> loadPackageById rpli tid 942 943storeArchiveCache 944 :: Text -- ^ URL 945 -> Text -- ^ subdir 946 -> SHA256 947 -> FileSize 948 -> P.TreeKey 949 -> ReaderT SqlBackend (RIO env) () 950storeArchiveCache url subdir sha size treeKey' = do 951 now <- getCurrentTime 952 ment <- getTreeForKey treeKey' 953 for_ ment $ \ent -> insert_ ArchiveCache 954 { archiveCacheTime = now 955 , archiveCacheUrl = url 956 , archiveCacheSubdir = subdir 957 , archiveCacheSha = sha 958 , archiveCacheSize = size 959 , archiveCacheTree = entityKey ent 960 } 961 962loadArchiveCache 963 :: Text -- ^ URL 964 -> Text -- ^ subdir 965 -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] 966loadArchiveCache url subdir = map go <$> selectList 967 [ ArchiveCacheUrl ==. url 968 , ArchiveCacheSubdir ==. subdir 969 ] 970 [Desc ArchiveCacheTime] 971 where 972 go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) 973 974storeRepoCache 975 :: Repo 976 -> Text -- ^ subdir 977 -> TreeId 978 -> ReaderT SqlBackend (RIO env) () 979storeRepoCache repo subdir tid = do 980 now <- getCurrentTime 981 insert_ RepoCache 982 { repoCacheTime = now 983 , repoCacheUrl = repoUrl repo 984 , repoCacheType = repoType repo 985 , repoCacheCommit = repoCommit repo 986 , repoCacheSubdir = subdir 987 , repoCacheTree = tid 988 } 989 990loadRepoCache 991 :: Repo 992 -> Text -- ^ subdir 993 -> ReaderT SqlBackend (RIO env) (Maybe TreeId) 994loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst 995 [ RepoCacheUrl ==. repoUrl repo 996 , RepoCacheType ==. repoType repo 997 , RepoCacheCommit ==. repoCommit repo 998 , RepoCacheSubdir ==. subdir 999 ] 1000 [Desc RepoCacheTime] 1001 1002storePreferredVersion :: 1003 P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () 1004storePreferredVersion name p = do 1005 nameid <- getPackageNameId name 1006 ment <- getBy $ UniquePreferred nameid 1007 case ment of 1008 Nothing -> insert_ PreferredVersions 1009 { preferredVersionsName = nameid 1010 , preferredVersionsPreferred = p 1011 } 1012 Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] 1013 1014loadPreferredVersion :: 1015 P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) 1016loadPreferredVersion name = do 1017 nameid <- getPackageNameId name 1018 fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) 1019 1020sinkHackagePackageNames 1021 :: (P.PackageName -> Bool) 1022 -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a 1023 -> ReaderT SqlBackend (RIO env) a 1024sinkHackagePackageNames predicate sink = do 1025 acqSrc <- selectSourceRes [] [] 1026 with acqSrc $ \src -> runConduit 1027 $ src 1028 .| concatMapMC go 1029 .| sink 1030 where 1031 go (Entity nameid (PackageName (PackageNameP name))) 1032 | predicate name = do 1033 -- Make sure it's actually on Hackage. Would be much more 1034 -- efficient with some raw SQL and an inner join, but we 1035 -- don't have a Conduit version of rawSql. 1036 onHackage <- checkOnHackage nameid 1037 pure $ if onHackage then Just name else Nothing 1038 | otherwise = pure Nothing 1039 1040 checkOnHackage nameid = do 1041 cnt <- count [HackageCabalName ==. nameid] 1042 pure $ cnt > 0 1043 1044-- | Get the filename for the cabal file in the given directory. 1045-- 1046-- If no .cabal file is present, or more than one is present, an exception is 1047-- thrown via 'throwM'. 1048-- 1049-- If the directory contains a file named package.yaml, hpack is used to 1050-- generate a .cabal file from it. 1051findOrGenerateCabalFile 1052 :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 1053 => Path Abs Dir -- ^ package directory 1054 -> RIO env (P.PackageName, Path Abs File) 1055findOrGenerateCabalFile pkgDir = do 1056 hpack pkgDir 1057 files <- filter (flip hasExtension "cabal" . toFilePath) . snd 1058 <$> listDir pkgDir 1059 -- If there are multiple files, ignore files that start with 1060 -- ".". On unixlike environments these are hidden, and this 1061 -- character is not valid in package names. The main goal is 1062 -- to ignore emacs lock files - see 1063 -- https://github.com/commercialhaskell/stack/issues/1897. 1064 let isHidden ('.':_) = True 1065 isHidden _ = False 1066 case filter (not . isHidden . fromRelFile . filename) files of 1067 [] -> throwIO $ P.NoCabalFileFound pkgDir 1068 [x] -> maybe 1069 (throwIO $ P.InvalidCabalFilePath x) 1070 (\pn -> pure $ (pn, x)) $ 1071 List.stripSuffix ".cabal" (toFilePath (filename x)) >>= 1072 P.parsePackageName 1073 _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files 1074 where hasExtension fp x = FilePath.takeExtension fp == "." ++ x 1075 1076-- | Similar to 'hpackToCabal' but doesn't require a new connection to database. 1077hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 1078 => P.RawPackageLocationImmutable -- ^ for exceptions 1079 -> P.Tree 1080 -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) 1081hpackToCabalS rpli tree = do 1082 tmpDir <- lift $ do 1083 tdir <- getTempDir 1084 createTempDir tdir "hpack-pkg-dir" 1085 unpackTreeToDir rpli tmpDir tree 1086 (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir 1087 !bs <- lift $ B.readFile (fromAbsFile cfile) 1088 lift $ removeDirRecur tmpDir 1089 return $ (packageName, bs) 1090 1091hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) 1092 => P.RawPackageLocationImmutable -- ^ for exceptions 1093 -> P.Tree 1094 -> RIO env (P.PackageName, ByteString) 1095hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do 1096 tdir <- parseAbsDir tmpdir 1097 withStorage $ unpackTreeToDir rpli tdir tree 1098 (packageName, cfile) <- findOrGenerateCabalFile tdir 1099 bs <- B.readFile (fromAbsFile cfile) 1100 return (packageName, bs) 1101 1102unpackTreeToDir 1103 :: (HasPantryConfig env, HasLogFunc env) 1104 => P.RawPackageLocationImmutable -- ^ for exceptions 1105 -> Path Abs Dir -- ^ dest dir, will be created if necessary 1106 -> P.Tree 1107 -> ReaderT SqlBackend (RIO env) () 1108unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do 1109 for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do 1110 let dest = dir </> T.unpack (P.unSafeFilePath sfp) 1111 createDirectoryIfMissing True $ takeDirectory dest 1112 mbs <- loadBlob blobKey 1113 case mbs of 1114 Nothing -> do 1115 -- TODO when we have pantry wire stuff, try downloading 1116 throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey 1117 Just bs -> do 1118 B.writeFile dest bs 1119 case ft of 1120 FTNormal -> pure () 1121 FTExecutable -> liftIO $ do 1122 perms <- getPermissions dest 1123 setPermissions dest $ setOwnerExecutable True perms 1124 1125countHackageCabals :: ReaderT SqlBackend (RIO env) Int 1126countHackageCabals = do 1127 res <- rawSql 1128 "SELECT COUNT(*)\n\ 1129 \FROM hackage_cabal" 1130 [] 1131 case res of 1132 [] -> pure 0 1133 (Single n):_ -> 1134 pure n 1135 1136getSnapshotCacheByHash 1137 :: SnapshotCacheHash 1138 -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) 1139getSnapshotCacheByHash = 1140 fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash 1141 1142getSnapshotCacheId 1143 :: SnapshotCacheHash 1144 -> ReaderT SqlBackend (RIO env) SnapshotCacheId 1145getSnapshotCacheId = 1146 fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash 1147 1148getModuleNameId 1149 :: P.ModuleName 1150 -> ReaderT SqlBackend (RIO env) ModuleNameId 1151getModuleNameId = 1152 fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP 1153 1154storeSnapshotModuleCache 1155 :: SnapshotCacheId 1156 -> Map P.PackageName (Set P.ModuleName) 1157 -> ReaderT SqlBackend (RIO env) () 1158storeSnapshotModuleCache cache packageModules = 1159 forM_ (Map.toList packageModules) $ \(pn, modules) -> do 1160 package <- getPackageNameId pn 1161 forM_ modules $ \m -> do 1162 moduleName <- getModuleNameId m 1163 insert_ PackageExposedModule 1164 { packageExposedModuleSnapshotCache = cache 1165 , packageExposedModulePackage = package 1166 , packageExposedModuleModule = moduleName 1167 } 1168 1169loadExposedModulePackages 1170 :: SnapshotCacheId 1171 -> P.ModuleName 1172 -> ReaderT SqlBackend (RIO env) [P.PackageName] 1173loadExposedModulePackages cacheId mName = 1174 map go <$> rawSql 1175 "SELECT package_name.name\n\ 1176 \FROM package_name, package_exposed_module, module_name\n\ 1177 \WHERE module_name.name=?\n\ 1178 \AND package_exposed_module.snapshot_cache=?\n\ 1179 \AND module_name.id=package_exposed_module.module\n\ 1180 \AND package_name.id=package_exposed_module.package" 1181 [ toPersistValue (P.ModuleNameP mName) 1182 , toPersistValue cacheId 1183 ] 1184 where 1185 go (Single (P.PackageNameP m)) = m 1186 1187data LoadCachedTreeException = MissingBlob !BlobKey 1188 deriving (Show, Typeable) 1189instance Exception LoadCachedTreeException 1190 1191-- | Ensure that all blobs needed for this package are present in the cache 1192loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree) 1193loadCachedTree (P.TreeMap m) = 1194 try $ CachedTreeMap <$> traverse loadEntry m 1195 where 1196 loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId) 1197 loadEntry te = (te, ) <$> loadBlob' (P.teBlob te) 1198 1199 loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId 1200 loadBlob' blobKey@(P.BlobKey sha _) = do 1201 mbid <- loadBlobBySHA sha 1202 case mbid of 1203 Nothing -> throwIO $ MissingBlob blobKey 1204 Just bid -> pure bid 1205