From a5c9b1b971747998017ca9ac51455f43a454f249 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 11 Jan 2019 17:10:12 +0300 Subject: [PATCH 1/9] Additions necessary for integration of pantry into stackage-server: * Addition of few class instances and exports needed for stackage-server * Fixed concurrent blob and file name writes in multi-connection sql pool setting. Added few more exports needed for stackage-server * Improved speed and safety by added database aware queries. Switched all queries to MonadIO * Removed pantry cabal file and added it to gitignore * Export PackageName and Version and aded NFData instances for PackageNameP and VersionP * Lower restriction from RIO to MonadUnliftIO for sql query running in `withStorage` * Turned on `-Wall` for pantry tests. --- .gitignore | 1 + subs/pantry/.hindent.yaml | 1 + subs/pantry/package.yaml | 7 + subs/pantry/src/Pantry.hs | 16 +-- subs/pantry/src/Pantry/Archive.hs | 6 +- subs/pantry/src/Pantry/Hackage.hs | 59 ++++++-- subs/pantry/src/Pantry/Storage.hs | 218 +++++++++++++++++------------- subs/pantry/src/Pantry/Tree.hs | 2 +- subs/pantry/src/Pantry/Types.hs | 56 ++++++-- 9 files changed, 237 insertions(+), 129 deletions(-) create mode 100644 subs/pantry/.hindent.yaml diff --git a/.gitignore b/.gitignore index d2645e022c..af5d767bea 100644 --- a/.gitignore +++ b/.gitignore @@ -29,3 +29,4 @@ tags /etc/scripts/stack-scripts.cabal .hspec-failures better-cache/ +/subs/*/*.cabal diff --git a/subs/pantry/.hindent.yaml b/subs/pantry/.hindent.yaml new file mode 100644 index 0000000000..5e5e32ff0f --- /dev/null +++ b/subs/pantry/.hindent.yaml @@ -0,0 +1 @@ +indent-size: 2 diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index bbbd842967..99a184c028 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -86,6 +86,9 @@ dependencies: - directory - filepath +ghc-options: + - -Wall + library: source-dirs: src/ when: @@ -104,6 +107,10 @@ library: # For testing - Pantry.Internal - Pantry.Internal.StaticBytes + # For stackage-server + - Pantry.Storage + - Pantry.Types + - Pantry.Hackage # FIXME must be removed from pantry! - Data.Aeson.Extended diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e973c2d778..2b4c953f2e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -179,7 +179,7 @@ import qualified RIO.FilePath as FilePath import Pantry.Archive import Pantry.Repo import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage +import Pantry.Storage hiding (TreeEntry, PackageName, Version) import Pantry.Tree import Pantry.Types import Pantry.Hackage @@ -299,8 +299,8 @@ getLatestHackageLocation req name preferred = do forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) - treeKey <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' -- | Returns the latest revision of the given package version available from -- Hackage. @@ -318,8 +318,8 @@ getLatestHackageRevision req name version = do Nothing -> pure Nothing Just (revision, cfKey@(BlobKey sha size)) -> do let cfi = CFIHash sha (Just size) - treeKey <- getHackageTarballKey (PackageIdentifierRevision name version cfi) - return $ Just (revision, cfKey, treeKey) + treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) + return $ Just (revision, cfKey, treeKey') fetchTreeKeys :: (HasPantryConfig env, HasLogFunc env, Foldable f) @@ -739,8 +739,8 @@ completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name versio pir = PackageIdentifierRevision name version cfi logDebug $ "Added in cabal file hash: " <> display pir pure (pir, BlobKey sha size) - treeKey <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' completePackageLocation pl@(RPLIArchive archive rpm) = do -- getArchive checks archive and package metadata (sha, size, package) <- getArchive pl archive rpm @@ -1344,7 +1344,7 @@ getRawPackageLocationTreeKey -> RIO env TreeKey getRawPackageLocationTreeKey pl = case getRawTreeKey pl of - Just treeKey -> pure treeKey + Just treeKey' -> pure treeKey' Nothing -> case pl of RPLIHackage pir _ -> getHackageTarballKey pir diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 4549445792..574ba660e2 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -13,7 +13,7 @@ module Pantry.Archive import RIO import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage +import Pantry.Storage hiding (Tree, TreeEntry) import Pantry.Tree import Pantry.Types import RIO.Process @@ -447,7 +447,7 @@ parseArchive rpli archive fp = do BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name _ -> return () -- It's good! Store the tree, let's bounce - (tid, treeKey) <- withStorage $ storeTree rpli ident tree buildFile + (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile packageCabal <- case buildFile of BFCabal _ _ -> pure $ PCCabalFile buildFileEntry BFHpack _ -> do @@ -458,7 +458,7 @@ parseArchive rpli archive fp = do let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} pure Package - { packageTreeKey = treeKey + { packageTreeKey = treeKey' , packageTree = tree , packageCabalEntry = packageCabal , packageIdent = ident diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 7eaad0fb60..62f3d9caf6 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -4,10 +4,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Pantry.Hackage ( updateHackageIndex + , forceUpdateHackageIndex , DidUpdateOccur (..) , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball + , getHackageTarballOnGPD , getHackageTarballKey , getHackageCabalFile , getHackagePackageVersions @@ -28,7 +30,7 @@ import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL import Pantry.Archive import Pantry.Types hiding (FileType (..)) -import Pantry.Storage +import Pantry.Storage hiding (TreeEntry, PackageName, Version) import Pantry.Tree import qualified Pantry.SHA256 as SHA256 import Network.URI (parseURI) @@ -39,6 +41,7 @@ import qualified Distribution.PackageDescription as Cabal import System.IO (SeekMode (..)) import qualified Data.List.NonEmpty as NE import Data.Text.Metrics (damerauLevenshtein) +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.Types.Version (versionNumbers) import Distribution.Types.VersionRange (withinRange) @@ -80,7 +83,26 @@ updateHackageIndex :: (HasPantryConfig env, HasLogFunc env) => Maybe Utf8Builder -- ^ reason for updating, if any -> RIO env DidUpdateOccur -updateHackageIndex mreason = do +updateHackageIndex = updateHackageIndexInternal False + +-- | Same as `updateHackageIndex`, but force the database update even if hackage +-- security tells that there is no change. This can be useful in order to make +-- sure the database is in sync with the locally downloaded tarball +-- +-- @since 0.1.0.0 +forceUpdateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => Maybe Utf8Builder + -> RIO env DidUpdateOccur +forceUpdateHackageIndex = updateHackageIndexInternal True + + +updateHackageIndexInternal + :: (HasPantryConfig env, HasLogFunc env) + => Bool -- ^ Force the database update. + -> Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env DidUpdateOccur +updateHackageIndexInternal forceUpdate mreason = do storage <- view $ pantryConfigL.to pcStorage gateUpdate $ withWriteLock_ storage $ do for_ mreason logInfo @@ -118,6 +140,9 @@ updateHackageIndex mreason = do HS.checkForUpdates repo maybeNow case didUpdate of + _ | forceUpdate -> do + logInfo "Forced package update is initialized" + updateCache tarball HS.NoUpdates -> do x <- needsCacheUpdate tarball if x @@ -200,11 +225,13 @@ updateHackageIndex mreason = do if oldHash == oldHashCheck then oldSize <$ logInfo "Updating preexisting cache, should be quick" else 0 <$ do - logInfo "Package index change detected, that's pretty unusual" - logInfo $ "Old size: " <> display oldSize - logInfo $ "Old hash (orig) : " <> display oldHash - logInfo $ "New hash (check): " <> display oldHashCheck - logInfo "Forcing a recache" + logWarn $ mconcat [ + "Package index change detected, that's pretty unusual: " + , "\n Old size: " <> display oldSize + , "\n Old hash (orig) : " <> display oldHash + , "\n New hash (check): " <> display oldHashCheck + , "\n Forcing a recache" + ] pure (offset, newHash, newSize) lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash @@ -503,11 +530,22 @@ getHackageTarball => PackageIdentifierRevision -> Maybe TreeKey -> RIO env Package -getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do +getHackageTarball = getHackageTarballOnGPD (\ _ _ -> pure ()) + +-- | Same as `getHackageTarball`, but allows an extra action to be performed on the parsed +-- `GenericPackageDescription` and newly created `TreeId`. +getHackageTarballOnGPD + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => (TreeId -> GenericPackageDescription -> RIO env ()) + -> PackageIdentifierRevision + -> Maybe TreeKey + -> RIO env Package +getHackageTarballOnGPD onGPD pir mtreeKey = do + let PackageIdentifierRevision name ver _cfi = pir cabalFile <- resolveCabalFileInfo pir - cabalFileKey <- withStorage $ getBlobKey cabalFile let rpli = RPLIHackage pir mtreeKey withCachedTree rpli name ver cabalFile $ do + cabalFileKey <- withStorage $ getBlobKey cabalFile mpair <- withStorage $ loadHackageTarballInfo name ver (sha, size) <- case mpair of @@ -569,7 +607,8 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do , mismatchActual = gpdIdent } - (_tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + onGPD tid gpd pure Package { packageTreeKey = treeKey' , packageTree = tree' diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 539d28c5df..2a0b9df546 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -9,10 +9,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} module Pantry.Storage ( SqlBackend , initStorage , withStorage + , migrateAll , storeBlob , loadBlob , loadBlobById @@ -33,6 +35,9 @@ module Pantry.Storage , loadTree , storeHPack , loadPackageById + , getPackageNameById + , getPackageNameId + , getVersionId , getTreeForKey , storeHackageTree , loadHackageTree @@ -51,14 +56,24 @@ module Pantry.Storage , getSnapshotCacheId , storeSnapshotModuleCache , loadExposedModulePackages - + , PackageNameId + , PackageName + , VersionId + , ModuleNameId + , Version + , Unique(..) + , EntityField(..) -- avoid warnings , BlobId + , unBlobKey , HackageCabalId + , HackageCabal(..) , HackageTarballId , CacheUpdateId , FilePathId + , Tree(..) , TreeId + , TreeEntry(..) , TreeEntryId , ArchiveCacheId , RepoCacheId @@ -243,39 +258,61 @@ withStorage withStorage action = flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) + +rdbmsAwareQuery + :: MonadIO m + => ReaderT SqlBackend m a + -> ReaderT SqlBackend m a + -> ReaderT SqlBackend m a +rdbmsAwareQuery postgresQuery sqliteQuery = do + rdbms <- connRDBMS <$> ask + case rdbms of + "postgresql" -> postgresQuery + "sqlite" -> sqliteQuery + _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" + + +getPackageNameById + :: MonadIO m + => PackageNameId + -> ReaderT SqlBackend m (Maybe P.PackageName) +getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get + + getPackageNameId - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName - -> ReaderT SqlBackend (RIO env) PackageNameId + -> ReaderT SqlBackend m PackageNameId getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.Version - -> ReaderT SqlBackend (RIO env) VersionId + -> ReaderT SqlBackend m VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP -getFilePathId - :: (HasPantryConfig env, HasLogFunc env) - => SafeFilePath - -> ReaderT SqlBackend (RIO env) FilePathId -getFilePathId = fmap (either entityKey id) . insertBy . FilePath - storeBlob - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => ByteString - -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) + -> ReaderT SqlBackend m (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of - [] -> insert Blob - { blobSha = sha - , blobSize = size - , blobContents = bs - } + [] -> rdbmsAwareQuery + (do rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" + [toPersistValue sha, toPersistValue size, toPersistValue bs] + rawSql "SELECT blob.id FROM blob WHERE blob.sha = ?" [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> error "soreBlob: there was a critical problem storing a blob.") + (insert Blob + { blobSha = sha + , blobSize = size + , blobContents = bs + }) key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) @@ -295,27 +332,17 @@ loadBlob (P.BlobKey sha size) = do ". Expected size: " <> display size <> ". Actual size: " <> display (blobSize bt)) -loadBlobBySHA - :: (HasPantryConfig env, HasLogFunc env) - => SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +loadBlobBySHA :: MonadIO m => SHA256 -> ReaderT SqlBackend m (Maybe BlobId) loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] -loadBlobById - :: (HasPantryConfig env, HasLogFunc env) - => BlobId - -> ReaderT SqlBackend (RIO env) ByteString +loadBlobById :: MonadIO m => BlobId -> ReaderT SqlBackend m ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" Just bt -> pure $ blobContents bt - -getBlobKey - :: (HasPantryConfig env, HasLogFunc env) - => BlobId - -> ReaderT SqlBackend (RIO env) BlobKey +getBlobKey :: MonadIO m => BlobId -> ReaderT SqlBackend m BlobKey getBlobKey bid = do res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of @@ -323,19 +350,13 @@ getBlobKey bid = do [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) -getBlobId - :: (HasPantryConfig env, HasLogFunc env) - => BlobKey - -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +getBlobId :: MonadIO m => BlobKey -> ReaderT SqlBackend m (Maybe BlobId) getBlobId (P.BlobKey sha size) = do res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res -loadURLBlob - :: (HasPantryConfig env, HasLogFunc env) - => Text - -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadURLBlob :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe ByteString) loadURLBlob url = do ment <- rawSql "SELECT blob.contents\n\ @@ -348,11 +369,7 @@ loadURLBlob url = do [] -> pure Nothing (Single bs) : _ -> pure $ Just bs -storeURLBlob - :: (HasPantryConfig env, HasLogFunc env) - => Text - -> ByteString - -> ReaderT SqlBackend (RIO env) () +storeURLBlob :: MonadIO m => Text -> ByteString -> ReaderT SqlBackend m () storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime @@ -362,17 +379,15 @@ storeURLBlob url blob = do , urlBlobTime = now } -clearHackageRevisions - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) () +clearHackageRevisions :: MonadIO m => ReaderT SqlBackend m () clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) storeHackageRevision - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> BlobId - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -389,9 +404,9 @@ storeHackageRevision name version key = do } loadHackagePackageVersions - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName - -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) + -> ReaderT SqlBackend m (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esequeleto @@ -407,10 +422,10 @@ loadHackagePackageVersions name = do (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version - -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) + -> ReaderT SqlBackend m (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -427,18 +442,18 @@ loadHackagePackageVersion name version = do (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) + :: MonadIO m + => ReaderT SqlBackend m (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) storeCacheUpdate - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => FileSize -> SHA256 - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate @@ -448,12 +463,12 @@ storeCacheUpdate size sha = do } storeHackageTarballInfo - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> SHA256 -> FileSize - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeHackageTarballInfo name version sha size = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -465,10 +480,10 @@ storeHackageTarballInfo name version sha size = do } loadHackageTarballInfo - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version - -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) + -> ReaderT SqlBackend m (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -561,6 +576,26 @@ hpackVersionId = do insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} +getFilePathId + :: MonadIO m + => SafeFilePath + -> ReaderT SqlBackend m FilePathId +getFilePathId sfp = + selectKeysList [FilePathPath ==. sfp] [] >>= \case + [fpId] -> pure fpId + [] -> rdbmsAwareQuery + (do rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql "SELECT id FROM file_path WHERE path = ?" [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> error "getFilePathId: there was a critical problem storing a blob.") + (insert $ FilePath sfp) + _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp + where + fp = T.unpack (P.unSafeFilePath sfp) + + storeTree :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => P.RawPackageLocationImmutable -- ^ for exceptions @@ -623,10 +658,7 @@ getTree tid = do Just ts -> pure ts loadTreeByEnt $ Entity tid ts -loadTree - :: (HasPantryConfig env, HasLogFunc env) - => P.TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) +loadTree :: MonadIO m => P.TreeKey -> ReaderT SqlBackend m (Maybe P.Tree) loadTree key = do ment <- getTreeForKey key case ment of @@ -634,9 +666,9 @@ loadTree key = do Just ent -> Just <$> loadTreeByEnt ent getTreeForKey - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) + -> ReaderT SqlBackend m (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key case mbid of @@ -672,8 +704,8 @@ loadPackageById rpli tid = do "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) Just (Version (P.VersionP version)) -> pure version let ident = P.PackageIdentifier name version - (pentry, mtree) <- - case (treeCabal ts) of + (pantry, mtree) <- + case treeCabal ts of Just keyBlob -> do cabalKey <- getBlobKey keyBlob return @@ -700,7 +732,7 @@ loadPackageById rpli tid = do Package { packageTreeKey = P.TreeKey blobKey , packageTree = mtree - , packageCabalEntry = pentry + , packageCabalEntry = pantry , packageIdent = ident } @@ -741,9 +773,9 @@ getHPackCabalFile hpackRecord ts tmap cabalFile = do , tree) loadTreeByEnt - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Entity Tree - -> ReaderT SqlBackend (RIO env) P.Tree + -> ReaderT SqlBackend m P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ @@ -758,12 +790,12 @@ loadTreeByEnt (Entity tid _t) = do entries storeHackageTree - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> BlobId -> P.TreeKey - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -776,11 +808,11 @@ storeHackageTree name version cabal treeKey' = do [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> P.Version -> SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) + -> ReaderT SqlBackend m (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql "SELECT treeblob.sha, treeblob.size\n\ @@ -827,13 +859,13 @@ loadHackageTree rpli name ver bid = do Just tid -> Just <$> loadPackageById rpli tid storeArchiveCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize -> P.TreeKey - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime ment <- getTreeForKey treeKey' @@ -847,10 +879,10 @@ storeArchiveCache url subdir sha size treeKey' = do } loadArchiveCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Text -- ^ URL -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] + -> ReaderT SqlBackend m [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir @@ -860,11 +892,11 @@ loadArchiveCache url subdir = map go <$> selectList go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) storeRepoCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Repo -> Text -- ^ subdir -> TreeId - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storeRepoCache repo subdir tid = do now <- getCurrentTime insert_ RepoCache @@ -877,10 +909,10 @@ storeRepoCache repo subdir tid = do } loadRepoCache - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => Repo -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) (Maybe TreeId) + -> ReaderT SqlBackend m (Maybe TreeId) loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo @@ -890,10 +922,10 @@ loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [Desc RepoCacheTime] storePreferredVersion - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName -> Text - -> ReaderT SqlBackend (RIO env) () + -> ReaderT SqlBackend m () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid @@ -905,18 +937,18 @@ storePreferredVersion name p = do Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] loadPreferredVersion - :: (HasPantryConfig env, HasLogFunc env) + :: MonadIO m => P.PackageName - -> ReaderT SqlBackend (RIO env) (Maybe Text) + -> ReaderT SqlBackend m (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames - :: (HasPantryConfig env, HasLogFunc env) + :: MonadUnliftIO m => (P.PackageName -> Bool) - -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a - -> ReaderT SqlBackend (RIO env) a + -> ConduitT P.PackageName Void (ReaderT SqlBackend m) a + -> ReaderT SqlBackend m a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] with acqSrc $ \src -> runConduit @@ -1019,8 +1051,8 @@ unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do setPermissions dest $ setOwnerExecutable True perms countHackageCabals - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) Int + :: MonadIO m + => ReaderT SqlBackend m Int countHackageCabals = do res <- rawSql "SELECT COUNT(*)\n\ diff --git a/subs/pantry/src/Pantry/Tree.hs b/subs/pantry/src/Pantry/Tree.hs index 63625280bc..63f2e25808 100644 --- a/subs/pantry/src/Pantry/Tree.hs +++ b/subs/pantry/src/Pantry/Tree.hs @@ -10,7 +10,7 @@ import RIO import qualified RIO.Map as Map import qualified RIO.Text as T import qualified RIO.ByteString as B -import Pantry.Storage +import Pantry.Storage hiding (Tree, TreeEntry) import Pantry.Types import RIO.FilePath ((), takeDirectory) import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 60ffd03b30..8098fc11f5 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -10,7 +10,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiWayIf #-} module Pantry.Types ( PantryConfig (..) @@ -122,6 +121,7 @@ import qualified RIO.Set as Set import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText, Parser) import Data.Aeson.Extended +import Data.Aeson.Encoding.Internal (unsafeToEncoding) import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) import Database.Persist import Database.Persist.Sql @@ -130,7 +130,7 @@ import qualified Pantry.SHA256 as SHA256 import qualified Distribution.Compat.ReadP as Parse import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) -import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) import Distribution.Types.VersionRange (VersionRange) import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) import Distribution.Types.PackageId (PackageIdentifier (..)) @@ -205,8 +205,8 @@ newtype Revision = Revision Word -- whether a pool is used, and the default implementation in -- "Pantry.Storage" does not use a pool. data Storage = Storage - { withStorage_ :: (forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a) - , withWriteLock_ :: (forall env a. HasLogFunc env => RIO env a -> RIO env a) + { withStorage_ :: forall m a. MonadUnliftIO m => ReaderT SqlBackend m a -> m a + , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a } -- | Configuration value used by the entire pantry package. Create one @@ -483,9 +483,9 @@ data Repo = Repo -- -- @since 0.1.0.0 , repoSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 } deriving (Generic, Eq, Ord, Typeable) instance NFData Repo @@ -540,6 +540,7 @@ instance FromJSON (WithJSONWarnings HackageSecurityConfig) where hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= False pure HackageSecurityConfig {..} + -- | An environment which contains a 'PantryConfig'. -- -- @since 0.1.0.0 @@ -549,6 +550,7 @@ class HasPantryConfig env where -- @since 0.1.0.0 pantryConfigL :: Lens' env PantryConfig + -- | File size in bytes -- -- @since 0.1.0.0 @@ -587,7 +589,9 @@ instance FromJSON BlobKey where <*> o .: "size" newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } - deriving (Show) + deriving (Eq, Ord, Show, Read, NFData) +instance Display PackageNameP where + display = fromString . packageNameString . unPackageNameP instance PersistField PackageNameP where toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn fromPersistValue v = do @@ -597,9 +601,20 @@ instance PersistField PackageNameP where Just pn -> Right $ PackageNameP pn instance PersistFieldSql PackageNameP where sqlType _ = SqlString - -newtype VersionP = VersionP Version - deriving (Show) +instance ToJSON PackageNameP where + toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn +instance FromJSON PackageNameP where + parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack +instance ToJSONKey PackageNameP where + toJSONKey = + ToJSONKeyText + (T.pack . packageNameString . unPackageNameP) + (unsafeToEncoding . getUtf8Builder . display) +instance FromJSONKey PackageNameP where + fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack + +newtype VersionP = VersionP { unVersionP :: Version } + deriving (Eq, Ord, Show, Read, NFData) instance PersistField VersionP where toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v fromPersistValue v = do @@ -609,9 +624,20 @@ instance PersistField VersionP where Just ver -> Right $ VersionP ver instance PersistFieldSql VersionP where sqlType _ = SqlString - -newtype ModuleNameP = ModuleNameP ModuleName - deriving (Show) +instance Display VersionP where + display (VersionP v) = fromString $ versionString v +instance ToJSON VersionP where + toJSON (VersionP v) = String $ T.pack $ versionString v +instance FromJSON VersionP where + parseJSON = + withText "VersionP" $ + either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack + +newtype ModuleNameP = ModuleNameP + { unModuleNameP :: ModuleName + } deriving (Eq, Ord, Show, NFData) +instance Display ModuleNameP where + display = fromString . moduleNameString . unModuleNameP instance PersistField ModuleNameP where toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn fromPersistValue v = do @@ -1624,6 +1650,7 @@ data HpackExecutable -- ^ Executable at the provided path deriving (Show, Read, Eq, Ord) + -- | Which compiler a snapshot wants to use. The build tool may elect -- to do some fuzzy matching of versions (e.g., allowing different -- patch versions). @@ -1637,6 +1664,7 @@ data WantedCompiler !Version -- ^ GHCJS version followed by GHC version deriving (Show, Eq, Ord, Generic) + instance NFData WantedCompiler instance Display WantedCompiler where display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) From 24381d9444def8be549ba0d70970b8e1f029f787 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 02:52:14 +0300 Subject: [PATCH 2/9] Add `Pantry.Internal.Stackage` that exports all of the stuff needed for Stackage Server --- subs/pantry/package.yaml | 4 +- subs/pantry/src/Pantry.hs | 1 - subs/pantry/src/Pantry/Internal/Stackage.hs | 50 +++++++++++++++++++++ 3 files changed, 51 insertions(+), 4 deletions(-) create mode 100644 subs/pantry/src/Pantry/Internal/Stackage.hs diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 99a184c028..57ad825507 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -108,9 +108,7 @@ library: - Pantry.Internal - Pantry.Internal.StaticBytes # For stackage-server - - Pantry.Storage - - Pantry.Types - - Pantry.Hackage + - Pantry.Internal.Stackage # FIXME must be removed from pantry! - Data.Aeson.Extended diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 2b4c953f2e..ea2f6cab7a 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -- | Content addressable Haskell package management, providing for -- secure, reproducible acquisition of Haskell package contents and -- metadata. diff --git a/subs/pantry/src/Pantry/Internal/Stackage.hs b/subs/pantry/src/Pantry/Internal/Stackage.hs new file mode 100644 index 0000000000..d5e42b2159 --- /dev/null +++ b/subs/pantry/src/Pantry/Internal/Stackage.hs @@ -0,0 +1,50 @@ +-- | All types and functions exported from this module are for advanced usage +-- only. They are needed for stackage-server integration with pantry. +module Pantry.Internal.Stackage + ( module X + ) where + +import Pantry.Hackage as X + ( forceUpdateHackageIndex + , getHackageTarballOnGPD + ) +import Pantry.Storage as X + ( BlobId + , EntityField(..) + , HackageCabalId + , ModuleNameId + , PackageName + , PackageNameId + , Tree(..) + , TreeEntry(..) + , TreeEntryId + , TreeId + , Unique(..) + , Version + , VersionId + , getBlobKey + , getPackageNameById + , getPackageNameId + , getTreeForKey + , getVersionId + , loadBlobById + , migrateAll + , treeCabal + , unBlobKey + ) +import Pantry.Types as X + ( ModuleNameP(..) + , PackageNameP(..) + , PantryConfig(..) + , SafeFilePath + , Storage(..) + , VersionP(..) + , mkSafeFilePath + , packageNameString + , packageTreeKey + , parsePackageName + , parseVersion + , parseVersionThrowing + , unSafeFilePath + , versionString + ) From de9cf4a4a8bf8ed9afb9b9b31b5d7a2cce44be4d Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 03:10:10 +0300 Subject: [PATCH 3/9] Adjust `getHackageTarball` to not rely on callback style and introduce an extra data type to handle it --- subs/pantry/src/Pantry.hs | 5 +- subs/pantry/src/Pantry/Hackage.hs | 144 +++++++++++--------- subs/pantry/src/Pantry/Internal/Stackage.hs | 3 +- 3 files changed, 83 insertions(+), 69 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index ea2f6cab7a..1f0d2d3ea3 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -701,7 +701,8 @@ loadPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageLocationImmutable -> RIO env Package -loadPackage (PLIHackage ident cfHash tree) = getHackageTarball (pirForHash ident cfHash) (Just tree) +loadPackage (PLIHackage ident cfHash tree) = + htrPackage <$> getHackageTarball (pirForHash ident cfHash) (Just tree) loadPackage pli@(PLIArchive archive pm) = getArchivePackage (toRawPLI pli) (toRawArchive archive) (toRawPM pm) loadPackage (PLIRepo repo pm) = getRepo repo (toRawPM pm) @@ -712,7 +713,7 @@ loadPackageRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable -> RIO env Package -loadPackageRaw (RPLIHackage pir mtree) = getHackageTarball pir mtree +loadPackageRaw (RPLIHackage pir mtree) = htrPackage <$> getHackageTarball pir mtree loadPackageRaw rpli@(RPLIArchive archive pm) = getArchivePackage rpli archive pm loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm diff --git a/subs/pantry/src/Pantry/Hackage.hs b/subs/pantry/src/Pantry/Hackage.hs index 62f3d9caf6..fc02529ad0 100644 --- a/subs/pantry/src/Pantry/Hackage.hs +++ b/subs/pantry/src/Pantry/Hackage.hs @@ -9,13 +9,13 @@ module Pantry.Hackage , RequireHackageIndex (..) , hackageIndexTarballL , getHackageTarball - , getHackageTarballOnGPD , getHackageTarballKey , getHackageCabalFile , getHackagePackageVersions , getHackagePackageVersionRevisions , getHackageTypoCorrections , UsePreferredVersions (..) + , HackageTarballResult(..) ) where import RIO @@ -72,6 +72,17 @@ hackageIndexTarballL = hackageDirL.to ( indexRelFile) -- @since 0.1.0.0 data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred + +-- | Information returned by `getHackageTarball` +-- +-- @since 0.1.0.0 +data HackageTarballResult = HackageTarballResult + { htrPackage :: !Package + -- ^ Package that was loaded from Hackage tarball + , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) + -- ^ This information is only available whenever package was just loaded into pantry. + } + -- | Download the most recent 01-index.tar file from Hackage and -- update the database tables. -- @@ -503,16 +514,17 @@ withCachedTree -> PackageName -> Version -> BlobId -- ^ cabal file contents - -> RIO env Package - -> RIO env Package + -> RIO env HackageTarballResult + -> RIO env HackageTarballResult withCachedTree rpli name ver bid inner = do mres <- withStorage $ loadHackageTree rpli name ver bid case mres of - Just package -> pure package + Just package -> pure $ HackageTarballResult package Nothing Nothing -> do - package <- inner - withStorage $ storeHackageTree name ver bid $ packageTreeKey package - pure package + htr <- inner + withStorage $ + storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr + pure htr getHackageTarballKey :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -521,26 +533,16 @@ getHackageTarballKey getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do mres <- withStorage $ loadHackageTreeKey name ver sha case mres of - Nothing -> packageTreeKey <$> getHackageTarball pir Nothing + Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing Just key -> pure key -getHackageTarballKey pir = packageTreeKey <$> getHackageTarball pir Nothing +getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing getHackageTarball :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => PackageIdentifierRevision -> Maybe TreeKey - -> RIO env Package -getHackageTarball = getHackageTarballOnGPD (\ _ _ -> pure ()) - --- | Same as `getHackageTarball`, but allows an extra action to be performed on the parsed --- `GenericPackageDescription` and newly created `TreeId`. -getHackageTarballOnGPD - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => (TreeId -> GenericPackageDescription -> RIO env ()) - -> PackageIdentifierRevision - -> Maybe TreeKey - -> RIO env Package -getHackageTarballOnGPD onGPD pir mtreeKey = do + -> RIO env HackageTarballResult +getHackageTarball pir mtreeKey = do let PackageIdentifierRevision name ver _cfi = pir cabalFile <- resolveCabalFileInfo pir let rpli = RPLIHackage pir mtreeKey @@ -562,56 +564,66 @@ getHackageTarballOnGPD onGPD pir mtreeKey = do Just pair2 -> pure pair2 pc <- view pantryConfigL let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc - url = mconcat - [ urlPrefix - , "package/" - , T.pack $ Distribution.Text.display name - , "-" - , T.pack $ Distribution.Text.display ver - , ".tar.gz" - ] - package <- getArchivePackage - rpli - RawArchive - { raLocation = ALUrl url - , raHash = Just sha - , raSize = Just size - , raSubdir = T.empty -- no subdirs on Hackage - } - RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just ver - , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree - , rpmCabal = Nothing -- cabal file in the tarball may be different! - } - + url = + mconcat + [ urlPrefix + , "package/" + , T.pack $ Distribution.Text.display name + , "-" + , T.pack $ Distribution.Text.display ver + , ".tar.gz" + ] + package <- + getArchivePackage + rpli + RawArchive + { raLocation = ALUrl url + , raHash = Just sha + , raSize = Just size + , raSubdir = T.empty -- no subdirs on Hackage + } + RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just ver + , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree + , rpmCabal = Nothing -- cabal file in the tarball may be different! + } case packageTree package of TreeMap m -> do - let (PCCabalFile (TreeEntry _ ft)) = packageCabalEntry package + let ft = + case packageCabalEntry package of + PCCabalFile (TreeEntry _ ft') -> ft' + _ -> error "Impossible: Hackage does not support hpack" cabalEntry = TreeEntry cabalFileKey ft tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m ident = PackageIdentifier name ver - - cabalBS <- withStorage $ do - let BlobKey sha' _ = cabalFileKey - mcabalBS <- loadBlobBySHA sha' - case mcabalBS of - Nothing -> error $ "Invariant violated, cabal file key: " ++ show cabalFileKey - Just bid -> loadBlobById bid - + cabalBS <- + withStorage $ do + let BlobKey sha' _ = cabalFileKey + mcabalBS <- loadBlobBySHA sha' + case mcabalBS of + Nothing -> + error $ + "Invariant violated, cabal file key: " ++ show cabalFileKey + Just bid -> loadBlobById bid (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS let gpdIdent = Cabal.package $ Cabal.packageDescription gpd - when (ident /= gpdIdent) $ throwIO $ - MismatchedCabalFileForHackage pir Mismatch - { mismatchExpected = ident - , mismatchActual = gpdIdent + when (ident /= gpdIdent) $ + throwIO $ + MismatchedCabalFileForHackage + pir + Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} + (tid, treeKey') <- + withStorage $ + storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + pure + HackageTarballResult + { htrPackage = + Package + { packageTreeKey = treeKey' + , packageTree = tree' + , packageIdent = ident + , packageCabalEntry = PCCabalFile cabalEntry + } + , htrFreshPackageInfo = Just (gpd, tid) } - - (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) - onGPD tid gpd - pure Package - { packageTreeKey = treeKey' - , packageTree = tree' - , packageIdent = ident - , packageCabalEntry = PCCabalFile cabalEntry - } diff --git a/subs/pantry/src/Pantry/Internal/Stackage.hs b/subs/pantry/src/Pantry/Internal/Stackage.hs index d5e42b2159..4c315cd42e 100644 --- a/subs/pantry/src/Pantry/Internal/Stackage.hs +++ b/subs/pantry/src/Pantry/Internal/Stackage.hs @@ -6,7 +6,8 @@ module Pantry.Internal.Stackage import Pantry.Hackage as X ( forceUpdateHackageIndex - , getHackageTarballOnGPD + , getHackageTarball + , HackageTarballResult(..) ) import Pantry.Storage as X ( BlobId From 0d920aeac5c5127594f0ee4cff549386c3a8889e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 03:30:11 +0300 Subject: [PATCH 4/9] Make rdbms aware queries more type safe with clearer documentation --- subs/pantry/src/Pantry/Storage.hs | 81 ++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 27 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 2a0b9df546..fd72eb5a1a 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} @@ -258,17 +259,25 @@ withStorage withStorage action = flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) +-- | This is a helper type to distinguish db queries between different rdbms backends. The important +-- part is that the affects described in this data type should be semantically equivalent between +-- the supported engines. +data RdbmsActions m a = RdbmsActions + { raSqlite :: !(ReaderT SqlBackend m a) + -- ^ A query that is specific to SQLite + , raPostgres :: !(ReaderT SqlBackend m a) + } +-- | This function provides a way to create queries supported by multiple sql backends. rdbmsAwareQuery :: MonadIO m - => ReaderT SqlBackend m a + => RdbmsActions m a -> ReaderT SqlBackend m a - -> ReaderT SqlBackend m a -rdbmsAwareQuery postgresQuery sqliteQuery = do +rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- connRDBMS <$> ask case rdbms of - "postgresql" -> postgresQuery - "sqlite" -> sqliteQuery + "postgresql" -> raPostgres + "sqlite" -> raSqlite _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" @@ -301,18 +310,26 @@ storeBlob bs = do keys <- selectKeysList [BlobSha ==. sha] [] key <- case keys of - [] -> rdbmsAwareQuery - (do rawExecute - "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" - [toPersistValue sha, toPersistValue size, toPersistValue bs] - rawSql "SELECT blob.id FROM blob WHERE blob.sha = ?" [toPersistValue sha] >>= \case - [Single key] -> pure key - _ -> error "soreBlob: there was a critical problem storing a blob.") - (insert Blob - { blobSha = sha - , blobSize = size - , blobContents = bs - }) + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = + insert Blob {blobSha = sha, blobSize = size, blobContents = bs} + , raPostgres = + do rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" + [ toPersistValue sha + , toPersistValue size + , toPersistValue bs + ] + rawSql + "SELECT blob.id FROM blob WHERE blob.sha = ?" + [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> + error + "soreBlob: there was a critical problem storing a blob." + } key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) @@ -571,7 +588,7 @@ hpackVersionId :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ReaderT SqlBackend (RIO env) VersionId hpackVersionId = do - hpackSoftwareVersion <- lift $ hpackVersion + hpackSoftwareVersion <- lift hpackVersion fmap (either entityKey id) $ insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} @@ -583,15 +600,25 @@ getFilePathId getFilePathId sfp = selectKeysList [FilePathPath ==. sfp] [] >>= \case [fpId] -> pure fpId - [] -> rdbmsAwareQuery - (do rawExecute - "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" - [toPersistValue sfp] - rawSql "SELECT id FROM file_path WHERE path = ?" [toPersistValue sfp] >>= \case - [Single key] -> pure key - _ -> error "getFilePathId: there was a critical problem storing a blob.") - (insert $ FilePath sfp) - _ -> error $ "getFilePathId: FilePath unique constraint key is violated for: " ++ fp + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = insert $ FilePath sfp + , raPostgres = + do rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql + "SELECT id FROM file_path WHERE path = ?" + [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> + error + "getFilePathId: there was a critical problem storing a blob." + } + _ -> + error $ + "getFilePathId: FilePath unique constraint key is violated for: " ++ fp where fp = T.unpack (P.unSafeFilePath sfp) From 4767c4e1fe6d43fc04b7789e1586a04e3473e18e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 03:33:38 +0300 Subject: [PATCH 5/9] Rename binding to packageEntry --- subs/pantry/src/Pantry/Storage.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index fd72eb5a1a..a54890dfa9 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -731,7 +731,7 @@ loadPackageById rpli tid = do "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) Just (Version (P.VersionP version)) -> pure version let ident = P.PackageIdentifier name version - (pantry, mtree) <- + (packageEntry, mtree) <- case treeCabal ts of Just keyBlob -> do cabalKey <- getBlobKey keyBlob @@ -759,7 +759,7 @@ loadPackageById rpli tid = do Package { packageTreeKey = P.TreeKey blobKey , packageTree = mtree - , packageCabalEntry = pantry + , packageCabalEntry = packageEntry , packageIdent = ident } From bbc35419ebe0f14f805c0de9b3f43ce33df088af Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 12:47:54 +0300 Subject: [PATCH 6/9] Revert back `withStorage_` signature restricted to `RIO` --- subs/pantry/src/Pantry/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 8098fc11f5..7a2e1484e7 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -205,7 +205,7 @@ newtype Revision = Revision Word -- whether a pool is used, and the default implementation in -- "Pantry.Storage" does not use a pool. data Storage = Storage - { withStorage_ :: forall m a. MonadUnliftIO m => ReaderT SqlBackend m a -> m a + { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a } From a6f4abff639897837bbbc19559110828cfdfc5b9 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 15:11:35 +0300 Subject: [PATCH 7/9] Switch to RIO from MonadIO for all queries --- subs/pantry/src/Pantry/Storage.hs | 149 +++++++++++------------------- 1 file changed, 56 insertions(+), 93 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index a54890dfa9..025d05a5e9 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -262,17 +262,16 @@ withStorage action = -- | This is a helper type to distinguish db queries between different rdbms backends. The important -- part is that the affects described in this data type should be semantically equivalent between -- the supported engines. -data RdbmsActions m a = RdbmsActions - { raSqlite :: !(ReaderT SqlBackend m a) +data RdbmsActions env a = RdbmsActions + { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite - , raPostgres :: !(ReaderT SqlBackend m a) + , raPostgres :: !(ReaderT SqlBackend (RIO env) a) } -- | This function provides a way to create queries supported by multiple sql backends. rdbmsAwareQuery - :: MonadIO m - => RdbmsActions m a - -> ReaderT SqlBackend m a + :: RdbmsActions env a + -> ReaderT SqlBackend (RIO env) a rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do rdbms <- connRDBMS <$> ask case rdbms of @@ -282,28 +281,24 @@ rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do getPackageNameById - :: MonadIO m - => PackageNameId - -> ReaderT SqlBackend m (Maybe P.PackageName) + :: PackageNameId + -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get getPackageNameId - :: MonadIO m - => P.PackageName - -> ReaderT SqlBackend m PackageNameId + :: P.PackageName + -> ReaderT SqlBackend (RIO env) PackageNameId getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP getVersionId - :: MonadIO m - => P.Version - -> ReaderT SqlBackend m VersionId + :: P.Version + -> ReaderT SqlBackend (RIO env) VersionId getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP storeBlob - :: MonadIO m - => ByteString - -> ReaderT SqlBackend m (BlobId, BlobKey) + :: ByteString + -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) storeBlob bs = do let sha = SHA256.hashBytes bs size = FileSize $ fromIntegral $ B.length bs @@ -349,17 +344,17 @@ loadBlob (P.BlobKey sha size) = do ". Expected size: " <> display size <> ". Actual size: " <> display (blobSize bt)) -loadBlobBySHA :: MonadIO m => SHA256 -> ReaderT SqlBackend m (Maybe BlobId) +loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] -loadBlobById :: MonadIO m => BlobId -> ReaderT SqlBackend m ByteString +loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString loadBlobById bid = do mbt <- get bid case mbt of Nothing -> error "loadBlobById: ID doesn't exist in database" Just bt -> pure $ blobContents bt -getBlobKey :: MonadIO m => BlobId -> ReaderT SqlBackend m BlobKey +getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey getBlobKey bid = do res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] case res of @@ -367,13 +362,13 @@ getBlobKey bid = do [(Single sha, Single size)] -> pure $ P.BlobKey sha size _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) -getBlobId :: MonadIO m => BlobKey -> ReaderT SqlBackend m (Maybe BlobId) +getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) getBlobId (P.BlobKey sha size) = do res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" [toPersistValue sha, toPersistValue size] pure $ listToMaybe $ map unSingle res -loadURLBlob :: MonadIO m => Text -> ReaderT SqlBackend m (Maybe ByteString) +loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadURLBlob url = do ment <- rawSql "SELECT blob.contents\n\ @@ -386,7 +381,7 @@ loadURLBlob url = do [] -> pure Nothing (Single bs) : _ -> pure $ Just bs -storeURLBlob :: MonadIO m => Text -> ByteString -> ReaderT SqlBackend m () +storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () storeURLBlob url blob = do (blobId, _) <- storeBlob blob now <- getCurrentTime @@ -396,15 +391,11 @@ storeURLBlob url blob = do , urlBlobTime = now } -clearHackageRevisions :: MonadIO m => ReaderT SqlBackend m () +clearHackageRevisions :: ReaderT SqlBackend (RIO env) () clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) -storeHackageRevision - :: MonadIO m - => P.PackageName - -> P.Version - -> BlobId - -> ReaderT SqlBackend m () +storeHackageRevision :: + P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () storeHackageRevision name version key = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -421,9 +412,8 @@ storeHackageRevision name version key = do } loadHackagePackageVersions - :: MonadIO m - => P.PackageName - -> ReaderT SqlBackend m (Map P.Version (Map Revision BlobKey)) + :: P.PackageName + -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) loadHackagePackageVersions name = do nameid <- getPackageNameId name -- would be better with esequeleto @@ -439,10 +429,9 @@ loadHackagePackageVersions name = do (version, Map.singleton revision (P.BlobKey key size)) loadHackagePackageVersion - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version - -> ReaderT SqlBackend m (Map Revision (BlobId, P.BlobKey)) + -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) loadHackagePackageVersion name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -459,18 +448,13 @@ loadHackagePackageVersion name version = do (revision, (bid, P.BlobKey sha size)) loadLatestCacheUpdate - :: MonadIO m - => ReaderT SqlBackend m (Maybe (FileSize, SHA256)) + :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) loadLatestCacheUpdate = fmap go <$> selectFirst [] [Desc CacheUpdateTime] where go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) -storeCacheUpdate - :: MonadIO m - => FileSize - -> SHA256 - -> ReaderT SqlBackend m () +storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () storeCacheUpdate size sha = do now <- getCurrentTime insert_ CacheUpdate @@ -480,12 +464,11 @@ storeCacheUpdate size sha = do } storeHackageTarballInfo - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version -> SHA256 -> FileSize - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeHackageTarballInfo name version sha size = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -497,10 +480,9 @@ storeHackageTarballInfo name version sha size = do } loadHackageTarballInfo - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version - -> ReaderT SqlBackend m (Maybe (SHA256, FileSize)) + -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) loadHackageTarballInfo name version = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -593,10 +575,8 @@ hpackVersionId = do insertBy $ Version {versionVersion = P.VersionP hpackSoftwareVersion} -getFilePathId - :: MonadIO m - => SafeFilePath - -> ReaderT SqlBackend m FilePathId + +getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId getFilePathId sfp = selectKeysList [FilePathPath ==. sfp] [] >>= \case [fpId] -> pure fpId @@ -685,7 +665,7 @@ getTree tid = do Just ts -> pure ts loadTreeByEnt $ Entity tid ts -loadTree :: MonadIO m => P.TreeKey -> ReaderT SqlBackend m (Maybe P.Tree) +loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) loadTree key = do ment <- getTreeForKey key case ment of @@ -693,9 +673,8 @@ loadTree key = do Just ent -> Just <$> loadTreeByEnt ent getTreeForKey - :: MonadIO m - => TreeKey - -> ReaderT SqlBackend m (Maybe (Entity Tree)) + :: TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) getTreeForKey (P.TreeKey key) = do mbid <- getBlobId key case mbid of @@ -790,7 +769,7 @@ getHPackCabalFile hpackRecord ts tmap cabalFile = do cbTreeEntry = P.TreeEntry cabalKey fileType hpackTreeEntry = P.TreeEntry hpackKey fileType tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap - return $ + return ( P.PCHpack $ P.PHpack { P.phOriginal = hpackTreeEntry @@ -799,10 +778,7 @@ getHPackCabalFile hpackRecord ts tmap cabalFile = do } , tree) -loadTreeByEnt - :: MonadIO m - => Entity Tree - -> ReaderT SqlBackend m P.Tree +loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree loadTreeByEnt (Entity tid _t) = do entries <- rawSql "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ @@ -817,12 +793,11 @@ loadTreeByEnt (Entity tid _t) = do entries storeHackageTree - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version -> BlobId -> P.TreeKey - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeHackageTree name version cabal treeKey' = do nameid <- getPackageNameId name versionid <- getVersionId version @@ -835,11 +810,10 @@ storeHackageTree name version cabal treeKey' = do [HackageCabalTree =. Just (entityKey ent)] loadHackageTreeKey - :: MonadIO m - => P.PackageName + :: P.PackageName -> P.Version -> SHA256 - -> ReaderT SqlBackend m (Maybe TreeKey) + -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) loadHackageTreeKey name ver sha = do res <- rawSql "SELECT treeblob.sha, treeblob.size\n\ @@ -886,13 +860,12 @@ loadHackageTree rpli name ver bid = do Just tid -> Just <$> loadPackageById rpli tid storeArchiveCache - :: MonadIO m - => Text -- ^ URL + :: Text -- ^ URL -> Text -- ^ subdir -> SHA256 -> FileSize -> P.TreeKey - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeArchiveCache url subdir sha size treeKey' = do now <- getCurrentTime ment <- getTreeForKey treeKey' @@ -906,10 +879,9 @@ storeArchiveCache url subdir sha size treeKey' = do } loadArchiveCache - :: MonadIO m - => Text -- ^ URL + :: Text -- ^ URL -> Text -- ^ subdir - -> ReaderT SqlBackend m [(SHA256, FileSize, TreeId)] + -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] loadArchiveCache url subdir = map go <$> selectList [ ArchiveCacheUrl ==. url , ArchiveCacheSubdir ==. subdir @@ -919,11 +891,10 @@ loadArchiveCache url subdir = map go <$> selectList go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) storeRepoCache - :: MonadIO m - => Repo + :: Repo -> Text -- ^ subdir -> TreeId - -> ReaderT SqlBackend m () + -> ReaderT SqlBackend (RIO env) () storeRepoCache repo subdir tid = do now <- getCurrentTime insert_ RepoCache @@ -936,10 +907,9 @@ storeRepoCache repo subdir tid = do } loadRepoCache - :: MonadIO m - => Repo + :: Repo -> Text -- ^ subdir - -> ReaderT SqlBackend m (Maybe TreeId) + -> ReaderT SqlBackend (RIO env) (Maybe TreeId) loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst [ RepoCacheUrl ==. repoUrl repo , RepoCacheType ==. repoType repo @@ -948,11 +918,8 @@ loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst ] [Desc RepoCacheTime] -storePreferredVersion - :: MonadIO m - => P.PackageName - -> Text - -> ReaderT SqlBackend m () +storePreferredVersion :: + P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () storePreferredVersion name p = do nameid <- getPackageNameId name ment <- getBy $ UniquePreferred nameid @@ -963,10 +930,8 @@ storePreferredVersion name p = do } Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] -loadPreferredVersion - :: MonadIO m - => P.PackageName - -> ReaderT SqlBackend m (Maybe Text) +loadPreferredVersion :: + P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) loadPreferredVersion name = do nameid <- getPackageNameId name fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) @@ -1077,9 +1042,7 @@ unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do perms <- getPermissions dest setPermissions dest $ setOwnerExecutable True perms -countHackageCabals - :: MonadIO m - => ReaderT SqlBackend m Int +countHackageCabals :: ReaderT SqlBackend (RIO env) Int countHackageCabals = do res <- rawSql "SELECT COUNT(*)\n\ From aafe48bb89a322b78d9b9417e9d2f4bddbdb3836 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Apr 2019 15:42:41 +0300 Subject: [PATCH 8/9] Removed redundant constraints --- subs/pantry/src/Pantry/Storage.hs | 59 +++++++++++++------------------ 1 file changed, 25 insertions(+), 34 deletions(-) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index 025d05a5e9..a6a9e99aca 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -266,6 +266,7 @@ data RdbmsActions env a = RdbmsActions { raSqlite :: !(ReaderT SqlBackend (RIO env) a) -- ^ A query that is specific to SQLite , raPostgres :: !(ReaderT SqlBackend (RIO env) a) + -- ^ A query that is specific to PostgreSQL } -- | This function provides a way to create queries supported by multiple sql backends. @@ -328,8 +329,8 @@ storeBlob bs = do key:rest -> assert (null rest) (pure key) pure (key, P.BlobKey sha size) -loadBlob - :: (HasPantryConfig env, HasLogFunc env) +loadBlob :: + HasLogFunc env => BlobKey -> ReaderT SqlBackend (RIO env) (Maybe ByteString) loadBlob (P.BlobKey sha size) = do @@ -491,8 +492,7 @@ loadHackageTarballInfo name version = do go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) storeCabalFile :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ByteString + ByteString -> P.PackageName -> ReaderT SqlBackend (RIO env) BlobId storeCabalFile cabalBS pkgName = do @@ -502,8 +502,7 @@ storeCabalFile cabalBS pkgName = do return bid loadFilePath :: - (HasPantryConfig env, HasLogFunc env) - => SafeFilePath + SafeFilePath -> ReaderT SqlBackend (RIO env) (Entity FilePath) loadFilePath path = do fp <- getBy $ UniqueSfp path @@ -514,18 +513,18 @@ loadFilePath path = do (T.unpack $ P.unSafeFilePath path) Just record -> return record -loadHPackTreeEntity :: (HasPantryConfig env, HasLogFunc env) => TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) +loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) loadHPackTreeEntity tid = do filepath <- loadFilePath P.hpackSafeFilePath let filePathId :: FilePathId = entityKey filepath hpackTreeEntry <- - selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] - hpackEntity <- - case hpackTreeEntry of - Nothing -> - error $ "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ (show tid) - Just record -> return record - return hpackEntity + selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] + case hpackTreeEntry of + Nothing -> + error $ + "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ + show tid + Just record -> return record storeHPack :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) @@ -539,7 +538,7 @@ storeHPack rpli tid = do Nothing -> generateHPack rpli tid vid Just record -> return $ entityKey record -loadCabalBlobKey :: (HasPantryConfig env, HasLogFunc env) => HPackId -> ReaderT SqlBackend (RIO env) BlobKey +loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey loadCabalBlobKey hpackId = do hpackRecord <- getJust hpackId getBlobKey $ hPackCabalBlob hpackRecord @@ -653,9 +652,7 @@ storeTree rpli (P.PackageIdentifier name version) tree@(P.TreeMap m) buildFile = P.BFCabal _ _ -> return () return (tid, pTreeKey) -getTree :: (HasPantryConfig env, HasLogFunc env) - => TreeId - -> ReaderT SqlBackend (RIO env) P.Tree +getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree getTree tid = do (mts :: Maybe Tree) <- get tid ts <- @@ -742,13 +739,13 @@ loadPackageById rpli tid = do , packageIdent = ident } -getHPackBlobKey :: (HasPantryConfig env, HasLogFunc env) => HPack -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKey hpackRecord = do let treeId = hPackTree hpackRecord hpackEntity <- loadHPackTreeEntity treeId getBlobKey (treeEntryBlob $ entityVal hpackEntity) -getHPackBlobKeyById :: (HasPantryConfig env, HasLogFunc env) => HPackId -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey getHPackBlobKeyById hpackId = do hpackRecord <- getJust hpackId getHPackBlobKey hpackRecord @@ -937,10 +934,9 @@ loadPreferredVersion name = do fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) sinkHackagePackageNames - :: MonadUnliftIO m - => (P.PackageName -> Bool) - -> ConduitT P.PackageName Void (ReaderT SqlBackend m) a - -> ReaderT SqlBackend m a + :: (P.PackageName -> Bool) + -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a + -> ReaderT SqlBackend (RIO env) a sinkHackagePackageNames predicate sink = do acqSrc <- selectSourceRes [] [] with acqSrc $ \src -> runConduit @@ -1054,29 +1050,25 @@ countHackageCabals = do pure n getSnapshotCacheByHash - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheHash + :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) getSnapshotCacheByHash = fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash getSnapshotCacheId - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheHash + :: SnapshotCacheHash -> ReaderT SqlBackend (RIO env) SnapshotCacheId getSnapshotCacheId = fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash getModuleNameId - :: (HasPantryConfig env, HasLogFunc env) - => P.ModuleName + :: P.ModuleName -> ReaderT SqlBackend (RIO env) ModuleNameId getModuleNameId = fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP storeSnapshotModuleCache - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheId + :: SnapshotCacheId -> Map P.PackageName (Set P.ModuleName) -> ReaderT SqlBackend (RIO env) () storeSnapshotModuleCache cache packageModules = @@ -1091,8 +1083,7 @@ storeSnapshotModuleCache cache packageModules = } loadExposedModulePackages - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheId + :: SnapshotCacheId -> P.ModuleName -> ReaderT SqlBackend (RIO env) [P.PackageName] loadExposedModulePackages cacheId mName = From 8a57805bd414dce27578fd10d5b76d20ff3667df Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 24 Apr 2019 15:03:55 +0300 Subject: [PATCH 9/9] Work around for ghc bug: https://gitlab.haskell.org/ghc/ghc/issues/16077 --- subs/pantry/src/Pantry/Internal/Stackage.hs | 2 +- subs/pantry/src/Pantry/Storage.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Internal/Stackage.hs b/subs/pantry/src/Pantry/Internal/Stackage.hs index 4c315cd42e..1a76a2c5d9 100644 --- a/subs/pantry/src/Pantry/Internal/Stackage.hs +++ b/subs/pantry/src/Pantry/Internal/Stackage.hs @@ -31,7 +31,7 @@ import Pantry.Storage as X , loadBlobById , migrateAll , treeCabal - , unBlobKey + , Key(unBlobKey) ) import Pantry.Types as X ( ModuleNameP(..) diff --git a/subs/pantry/src/Pantry/Storage.hs b/subs/pantry/src/Pantry/Storage.hs index a6a9e99aca..eeecb8d75f 100644 --- a/subs/pantry/src/Pantry/Storage.hs +++ b/subs/pantry/src/Pantry/Storage.hs @@ -66,7 +66,7 @@ module Pantry.Storage , EntityField(..) -- avoid warnings , BlobId - , unBlobKey + , Key(unBlobKey) , HackageCabalId , HackageCabal(..) , HackageTarballId