From 722260e1d451120c74873f2e98c47ea8ddc1c857 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 12 Feb 2020 00:40:31 +0300 Subject: [PATCH 1/3] Addition of fallback repository with core cabal files --- src/Stackage/Database/Cron.hs | 32 ++++++++++++++++++++++++++++---- src/Stackage/Database/Github.hs | 9 +++++++++ src/Stackage/Database/Query.hs | 1 - 3 files changed, 37 insertions(+), 5 deletions(-) diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index 19bfc98..02f8e49 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -239,29 +239,53 @@ makeCorePackageGetters :: makeCorePackageGetters = do rootDir <- scStackageRoot <$> ask contentDir <- getStackageContentDir rootDir + coreCabalFiles <- getCoreCabalFiles rootDir liftIO (decodeFileEither (contentDir "stack" "global-hints.yaml")) >>= \case Right (hints :: Map CompilerP (Map PackageNameP VersionP)) -> Map.traverseWithKey (\compiler -> - fmap Map.elems . Map.traverseMaybeWithKey (makeCorePackageGetter compiler)) + fmap Map.elems . + Map.traverseMaybeWithKey (makeCorePackageGetter compiler coreCabalFiles)) hints Left exc -> do logError $ "Error parsing 'global-hints.yaml' file: " <> fromString (displayException exc) return mempty +getCoreCabalFiles :: FilePath -> RIO StackageCron (Map PackageIdentifierP GenericPackageDescription) +getCoreCabalFiles rootDir = do + coreCabalFilesDir <- getCoreCabalFilesDir rootDir + cabalFileNames <- getDirectoryContents coreCabalFilesDir + cabalFiles <- + forM (filter (isExtensionOf ".cabal") cabalFileNames) $ \cabalFileName -> + let pidTxt = T.pack (dropExtension (takeFileName cabalFileName)) + in case fromPathPiece pidTxt of + Nothing -> do + logError $ "Invalid package identifier: " <> fromString cabalFileName + pure Nothing + Just pid@(PackageIdentifierP pname _) -> do + mgpd <- + readFileBinary (coreCabalFilesDir cabalFileName) >>= + parseCabalBlobMaybe pname + pure ((,) pid <$> mgpd) + pure $ Map.fromList $ catMaybes cabalFiles + -- | Core package info rarely changes between the snapshots, therefore it would be wasteful to -- load, parse and update all packages from gloabl-hints for each snapshot, instead we produce -- a memoized version that will do it once initiall and then return information aboat a -- package on subsequent invocations. makeCorePackageGetter :: - CompilerP -> PackageNameP -> VersionP -> RIO StackageCron (Maybe CorePackageGetter) -makeCorePackageGetter _compiler pname ver = + CompilerP + -> Map PackageIdentifierP GenericPackageDescription + -> PackageNameP + -> VersionP + -> RIO StackageCron (Maybe CorePackageGetter) +makeCorePackageGetter _compiler fallbackCabalFileMap pname ver = run (getHackageCabalByRev0 pid) >>= \case Nothing -> do logWarn $ "Core package from global-hints: '" <> display pid <> "' was not found in pantry." - pure Nothing + pure (pure . (,,,) Nothing Nothing pid <$> Map.lookup pid fallbackCabalFileMap) Just (hackageCabalId, blobId, _) -> do pkgInfoRef <- newIORef Nothing -- use for caching of pkgInfo let getMemoPackageInfo = diff --git a/src/Stackage/Database/Github.hs b/src/Stackage/Database/Github.hs index 664b2b2..8ea0deb 100644 --- a/src/Stackage/Database/Github.hs +++ b/src/Stackage/Database/Github.hs @@ -4,6 +4,7 @@ module Stackage.Database.Github ( cloneOrUpdate , lastGitFileUpdate , getStackageContentDir + , getCoreCabalFilesDir , GithubRepo(..) ) where @@ -72,3 +73,11 @@ getStackageContentDir :: -> m FilePath getStackageContentDir rootDir = cloneOrUpdate rootDir (GithubRepo "commercialhaskell" "stackage-content") + +-- | Use backup location with cabal files, hackage doesn't have all of them. +getCoreCabalFilesDir :: + (MonadReader env m, HasLogFunc env, HasProcessContext env, MonadIO m) + => FilePath + -> m FilePath +getCoreCabalFilesDir rootDir = + cloneOrUpdate rootDir (GithubRepo "commercialhaskell" "core-cabal-files") diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 0b10d24..436b0b7 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Stackage.Database.Query ( -- * Snapshot From 8e247dde0369663d64df0604cf83bc1ab6f9eafa Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 12 Feb 2020 02:09:35 +0300 Subject: [PATCH 2/3] Update to ghc-8.8, pantry-0.2 and Cabal-3.0 --- package.yaml | 1 + src/Data/WebsiteContent.hs | 1 - src/Handler/Blog.hs | 1 + src/Handler/Download.hs | 1 - src/Handler/Feed.hs | 2 +- src/Handler/Haddock.hs | 1 - src/Handler/Hoogle.hs | 1 - src/Handler/MirrorStatus.hs | 2 +- src/Handler/Package.hs | 2 -- src/Handler/PackageDeps.hs | 2 -- src/Handler/StackageHome.hs | 1 - src/Handler/StackageSdist.hs | 1 - src/Import.hs | 3 --- src/Stackage/Database/Cron.hs | 35 ++++++++++++---------------- src/Stackage/Database/Github.hs | 16 +++++++++---- src/Stackage/Database/Haddock.hs | 4 +--- src/Stackage/Database/PackageInfo.hs | 4 +--- src/Stackage/Database/Query.hs | 6 ++--- src/Stackage/Database/Schema.hs | 3 +++ src/Stackage/Database/Types.hs | 3 +-- src/Types.hs | 9 +++---- stack.yaml | 19 ++++++++++----- 22 files changed, 57 insertions(+), 61 deletions(-) diff --git a/package.yaml b/package.yaml index f632f6c..4669928 100644 --- a/package.yaml +++ b/package.yaml @@ -39,6 +39,7 @@ dependencies: - persistent-template - resourcet - rio +- semialign - shakespeare - tar-conduit - template-haskell diff --git a/src/Data/WebsiteContent.hs b/src/Data/WebsiteContent.hs index 0d1a5bc..aa5ce10 100644 --- a/src/Data/WebsiteContent.hs +++ b/src/Data/WebsiteContent.hs @@ -11,7 +11,6 @@ module Data.WebsiteContent import ClassyPrelude.Yesod import CMarkGFM -import Data.Aeson (withObject) import Data.GhcLinks import Data.Yaml import System.FilePath (takeFileName) diff --git a/src/Handler/Blog.hs b/src/Handler/Blog.hs index 08f4a17..0b5a8e7 100644 --- a/src/Handler/Blog.hs +++ b/src/Handler/Blog.hs @@ -86,4 +86,5 @@ getBlogFeedR = do , feedEntryTitle = postTitle post , feedEntryContent = postBody post , feedEntryEnclosure = Nothing + , feedEntryCategories = [] } diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 35c9e9c..c83c6d6 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -12,7 +12,6 @@ import Import import Data.GhcLinks import Yesod.GitRepo (grContent) import Stackage.Database -import Stackage.Database.Types (ghcVersion) getDownloadR :: Handler Html getDownloadR = track "Hoogle.Download.getDownloadR" $ diff --git a/src/Handler/Feed.hs b/src/Handler/Feed.hs index b0c7d5b..91960d9 100644 --- a/src/Handler/Feed.hs +++ b/src/Handler/Feed.hs @@ -12,7 +12,6 @@ import RIO.Time (getCurrentTime) import Stackage.Database import Stackage.Snapshot.Diff import Text.Blaze (text) -import Yesod.Core.Handler (lookupGetParam) getFeedR :: Handler TypedContent getFeedR = track "Handler.Feed.getBranchFeedR" $ getBranchFeed Nothing @@ -38,6 +37,7 @@ mkFeed mBranch snaps = do , feedEntryTitle = snapshotTitle snap , feedEntryContent = content , feedEntryEnclosure = Nothing + , feedEntryCategories = [] } updated <- case entries of diff --git a/src/Handler/Haddock.hs b/src/Handler/Haddock.hs index a0bacc5..8940f4a 100644 --- a/src/Handler/Haddock.hs +++ b/src/Handler/Haddock.hs @@ -7,7 +7,6 @@ module Handler.Haddock import Import import qualified Data.Text as T (takeEnd) import Stackage.Database -import Stackage.Database.Types (haddockBucketName) makeURL :: SnapName -> [Text] -> Text makeURL snapName rest = concat diff --git a/src/Handler/Hoogle.hs b/src/Handler/Hoogle.hs index 4d2c2fa..9dd60bb 100644 --- a/src/Handler/Hoogle.hs +++ b/src/Handler/Hoogle.hs @@ -8,7 +8,6 @@ {-# LANGUAGE TemplateHaskell #-} module Handler.Hoogle where -import Control.DeepSeq (NFData(..)) import qualified Data.Text as T import Data.Text.Read (decimal) import qualified Hoogle diff --git a/src/Handler/MirrorStatus.hs b/src/Handler/MirrorStatus.hs index 77a978e..714a671 100644 --- a/src/Handler/MirrorStatus.hs +++ b/src/Handler/MirrorStatus.hs @@ -8,7 +8,7 @@ module Handler.MirrorStatus import Import import Control.AutoUpdate import Network.HTTP.Simple -import RIO.Time (parseTimeM, diffUTCTime, addUTCTime, getCurrentTime) +import RIO.Time (diffUTCTime, addUTCTime, getCurrentTime) import Text.XML.Stream.Parse import Data.XML.Types (Event (EventContent), Content (ContentText)) import qualified Prelude diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs index 61f57c6..241ab2b 100644 --- a/src/Handler/Package.hs +++ b/src/Handler/Package.hs @@ -27,8 +27,6 @@ import Graphics.Badge.Barrier import Import import Stackage.Database import Stackage.Database.PackageInfo (PackageInfo(..), Identifier(..), renderEmail) -import Stackage.Database.Types (HackageCabalInfo(..), LatestInfo(..), - ModuleListingInfo(..)) import qualified Text.Blaze.Html.Renderer.Text as LT import Yesod.GitRepo diff --git a/src/Handler/PackageDeps.hs b/src/Handler/PackageDeps.hs index bee0d6e..653a808 100644 --- a/src/Handler/PackageDeps.hs +++ b/src/Handler/PackageDeps.hs @@ -9,9 +9,7 @@ module Handler.PackageDeps import Handler.StackageSdist (pnvToSnapshotPackageInfo) import Import -import Types (PackageVersionRev(..)) import Stackage.Database -import Stackage.Database.Types (SnapshotPackageInfo(..)) getPackageDepsR :: PackageNameP -> Handler Html getPackageDepsR pname = do diff --git a/src/Handler/StackageHome.hs b/src/Handler/StackageHome.hs index ba37389..f1e69bb 100644 --- a/src/Handler/StackageHome.hs +++ b/src/Handler/StackageHome.hs @@ -17,7 +17,6 @@ import Data.These import RIO.Time (FormatTime) import Import import Stackage.Database -import Stackage.Database.Types (PackageListingInfo(..), isLts) import Stackage.Snapshot.Diff getStackageHomeR :: SnapName -> Handler TypedContent diff --git a/src/Handler/StackageSdist.hs b/src/Handler/StackageSdist.hs index e1005e6..b4f0f68 100644 --- a/src/Handler/StackageSdist.hs +++ b/src/Handler/StackageSdist.hs @@ -6,7 +6,6 @@ module Handler.StackageSdist import Import import Stackage.Database -import Stackage.Database.Types (SnapshotPackageInfo(..)) import Handler.Package (packagePage) handlePNVTarball :: PackageNameP -> VersionP -> Handler TypedContent diff --git a/src/Import.hs b/src/Import.hs index e5fafc4..8a96d16 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -3,19 +3,16 @@ module Import ( module Import ) where -import Control.Monad.Trans.Class (lift) import ClassyPrelude.Yesod as Import hiding (getCurrentTime) import Foundation as Import import Settings as Import import Settings.StaticFiles as Import import Types as Import import Yesod.Auth as Import -import Yesod.Core.Handler (getYesod) import Data.WebsiteContent as Import (WebsiteContent (..)) import Data.Text.Read (decimal) import RIO.Time (diffUTCTime) --import qualified Prometheus as P -import Stackage.Database (SnapName) import Stackage.Database.Types (ModuleListingInfo(..)) import Formatting (format) import Formatting.Time (diff) diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index 02f8e49..8e96cdd 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -28,24 +28,21 @@ import Data.Streaming.Network (bindPortTCP) import Data.Yaml (decodeFileEither) import Database.Persist import Database.Persist.Postgresql -import Distribution.PackageDescription (GenericPackageDescription) import qualified Hoogle import Network.AWS hiding (Request, Response) -import Network.AWS.Data.Body (toBody) import Network.AWS.Data.Text (toText) import Network.AWS.S3 import Network.HTTP.Client import Network.HTTP.Client.Conduit (bodyReaderSource) -import Network.HTTP.Simple (getResponseBody, httpJSONEither, parseRequest) +import Network.HTTP.Simple (getResponseBody, httpJSONEither) import Network.HTTP.Types (status200, status404) import Pantry (CabalFileInfo(..), DidUpdateOccur(..), HpackExecutable(HpackBundled), PackageIdentifierRevision(..), - defaultHackageSecurityConfig) -import Pantry.Internal.Stackage (HackageCabalId, HackageTarballResult(..), + defaultHackageSecurityConfig, defaultCasaRepoPrefix, defaultCasaMaxPerRequest) +import Pantry.Internal.Stackage (HackageTarballResult(..), PantryConfig(..), Storage(..), forceUpdateHackageIndex, getHackageTarball, - getTreeForKey, loadBlobById, packageTreeKey, - treeCabal) + packageTreeKey) import Path (parseAbsDir, toFilePath) import RIO import RIO.Directory @@ -192,6 +189,8 @@ stackageServerCron StackageCronOptions {..} = do , pcParsedCabalFilesRawImmutable = cabalImmutable , pcParsedCabalFilesMutable = cabalMutable , pcConnectionCount = connectionCount + , pcCasaRepoPrefix = defaultCasaRepoPrefix + , pcCasaMaxPerRequest = defaultCasaMaxPerRequest } stackage = StackageCron @@ -453,19 +452,15 @@ sourceSnapshots = do "Error parsing snapshot file: " <> fromString fp <> "\n" <> fromString (displayException exc) return Nothing - lastGitFileUpdate gitDir fp >>= \case - Left err -> do - logError $ "Error parsing git commit date: " <> fromString err - return Nothing - Right updatedOn -> do - env <- lift ask - return $ - Just - SnapshotFileInfo - { sfiSnapName = snapName - , sfiUpdatedOn = updatedOn - , sfiSnapshotFileGetter = runRIO env (parseSnapshot updatedOn) - } + mUpdatedOn <- lastGitFileUpdate gitDir fp + forM mUpdatedOn $ \updatedOn -> do + env <- lift ask + return $ + SnapshotFileInfo + { sfiSnapName = snapName + , sfiUpdatedOn = updatedOn + , sfiSnapshotFileGetter = runRIO env (parseSnapshot updatedOn) + } getLtsParser gitDir fp = case mapM (BS8.readInt . BS8.pack) $ take 2 $ reverse (splitPath fp) of Just [(minor, ".yaml"), (major, "/")] -> diff --git a/src/Stackage/Database/Github.hs b/src/Stackage/Database/Github.hs index 8ea0deb..7cd8638 100644 --- a/src/Stackage/Database/Github.hs +++ b/src/Stackage/Database/Github.hs @@ -15,6 +15,7 @@ import RIO.FilePath import RIO.Process import RIO.Time + data GithubRepo = GithubRepo { grAccount :: !String , grName :: !String @@ -33,17 +34,22 @@ lastGitFileUpdate :: (MonadReader env m, HasLogFunc env, HasProcessContext env, MonadUnliftIO m) => FilePath -- ^ Root dir of the repository -> FilePath -- ^ Relative path of the file - -> m (Either String UTCTime) + -> m (Maybe UTCTime) lastGitFileUpdate gitDir filePath = do lastCommitTimestamps <- gitLog gitDir filePath ["-1", "--format=%cD"] parseGitDate rfc822DateFormat lastCommitTimestamps where parseGitDate fmt dates = case listToMaybe $ LBS8.lines dates of - Nothing -> return $ Left "Git log is empty for the file" - Just lbsDate -> - mapLeft (displayException :: SomeException -> String) <$> - try (parseTimeM False defaultTimeLocale fmt (LBS8.unpack lbsDate)) + Nothing -> do + logError "Git log is empty for the file" + return Nothing + Just lbsDate -> do + let parseDateTime = parseTimeM False defaultTimeLocale fmt (LBS8.unpack lbsDate) + catchAny (Just <$> liftIO parseDateTime) $ \exc -> do + logError $ + "Error parsing git commit date: " <> fromString (displayException exc) + pure Nothing -- | Clone a repository locally. In case when repository is already present sync it up with -- remote. Returns the full path where repository was cloned into. diff --git a/src/Stackage/Database/Haddock.hs b/src/Stackage/Database/Haddock.hs index a9ff42a..357882c 100644 --- a/src/Stackage/Database/Haddock.hs +++ b/src/Stackage/Database/Haddock.hs @@ -38,9 +38,7 @@ hToHtml = H.dt (go x) ++ H.dd (go y) go (DocCodeBlock x) = H.pre $ H.code $ go x go (DocHyperlink (Hyperlink url mlabel)) = - H.a H.! A.href (H.toValue url) $ toHtml label - where - label = fromMaybe url mlabel + H.a H.! A.href (H.toValue url) $ maybe (toHtml url) (toHtml . go) mlabel go (DocPic (Picture url mtitle)) = H.img H.! A.src (H.toValue url) H.! A.title (H.toValue $ fromMaybe mempty mtitle) go (DocAName s) = H.div H.! A.id (H.toValue s) $ mempty diff --git a/src/Stackage/Database/PackageInfo.hs b/src/Stackage/Database/PackageInfo.hs index f88ebd5..1399639 100644 --- a/src/Stackage/Database/PackageInfo.hs +++ b/src/Stackage/Database/PackageInfo.hs @@ -18,8 +18,6 @@ import Data.Coerce import Data.Char (isSpace) import Data.Map.Merge.Strict as Map import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Package (Dependency(..)) import Distribution.PackageDescription (CondTree(..), Condition(..), @@ -172,7 +170,7 @@ getDeps checkCond = goTree where goTree (CondNode _data deps comps) = combineDeps $ - map (\(Dependency name range) -> Map.singleton (PackageNameP name) range) deps ++ + map (\(Dependency name range _) -> Map.singleton (PackageNameP name) range) deps ++ map goComp comps goComp (CondBranch cond yes no) | checkCond cond = goTree yes diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 436b0b7..7d7ad96 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -72,10 +72,10 @@ import Database.Esqueleto import Database.Esqueleto.Internal.Language (FromPreprocess) import Database.Esqueleto.Internal.Sql import qualified Database.Persist as P -import Pantry.Internal.Stackage (EntityField(..), PackageName, Unique(..), +import Pantry.Internal.Stackage (EntityField(..), PackageName, Version, getBlobKey, getPackageNameById, getPackageNameId, getTreeForKey, getVersionId, - loadBlobById, mkSafeFilePath, treeCabal) + loadBlobById, mkSafeFilePath) import RIO hiding (on, (^.)) import qualified RIO.Map as Map import qualified RIO.Set as Set @@ -364,7 +364,7 @@ getPackageVersionForSnapshot snapshotId pname = pure (v ^. VersionVersion)) getLatest :: - FromPreprocess SqlQuery SqlExpr SqlBackend t + FromPreprocess t => PackageNameP -> (t -> SqlExpr (Value SnapshotId)) -> (t -> SqlQuery ()) diff --git a/src/Stackage/Database/Schema.hs b/src/Stackage/Database/Schema.hs index b370b08..6adedc2 100644 --- a/src/Stackage/Database/Schema.hs +++ b/src/Stackage/Database/Schema.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -8,8 +9,10 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Stackage.Database.Schema ( -- * Database run diff --git a/src/Stackage/Database/Types.hs b/src/Stackage/Database/Types.hs index 4e28274..4d2c756 100644 --- a/src/Stackage/Database/Types.hs +++ b/src/Stackage/Database/Types.hs @@ -52,8 +52,7 @@ import Data.Text.Read (decimal) import Network.AWS (Env, HasEnv(..)) import Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..), HasPantryConfig(..), PackageIdentifierRevision(..), TreeKey(..)) -import Pantry.Internal.Stackage as Pantry (PackageNameP(..), PantryConfig, - VersionP(..)) +import Pantry.Internal.Stackage as Pantry (PantryConfig) import Pantry.SHA256 (fromHexText) import RIO import RIO.Process (HasProcessContext(..), ProcessContext) diff --git a/src/Types.hs b/src/Types.hs index 7ab7199..fdc8360 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -49,7 +49,6 @@ module Types ) where import ClassyPrelude.Yesod (ToBuilder(..)) -import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson import Data.Bifunctor (bimap) import Data.Char (ord) @@ -63,7 +62,9 @@ import Database.Persist.Sql (PersistFieldSql(sqlType)) import qualified Distribution.ModuleName as DT (components, fromComponents, validModuleComponent) import Distribution.PackageDescription (FlagName, GenericPackageDescription) -import qualified Distribution.Text as DT (Text, display, simpleParse) +import Distribution.Parsec as DT (Parsec) +import Distribution.Pretty as DT (Pretty) +import qualified Distribution.Text as DT (display, simpleParse) import Distribution.Types.VersionRange (VersionRange) import Distribution.Version (mkVersion, versionNumbers) import Pantry (Revision(..)) @@ -84,14 +85,14 @@ instance Exception ParseFailedException where displayException (ParseFailedException tyRep origString) = "Was unable to parse " ++ showsTypeRep tyRep ": " ++ origString -dtParse :: forall a m. (Typeable a, DT.Text a, MonadThrow m) => Text -> m a +dtParse :: forall a m. (Typeable a, DT.Parsec a, MonadThrow m) => Text -> m a dtParse txt = let str = T.unpack txt in case DT.simpleParse str of Nothing -> throwM $ ParseFailedException (typeRep (Proxy :: Proxy a)) str Just dt -> pure dt -dtDisplay :: (DT.Text a, IsString b) => a -> b +dtDisplay :: (DT.Pretty a, IsString b) => a -> b dtDisplay = fromString . DT.display diff --git a/stack.yaml b/stack.yaml index b980f14..c12175d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,17 @@ -resolver: lts-13.16 +resolver: nightly-2020-02-08 packages: - '.' extra-deps: -- git: https://github.com/commercialhaskell/stack - commit: dfbf85ad7e8af5b01cf7b51367290870ffc2c90e +- barrier-0.1.1@sha256:2021f84c3aba67bb635d72825d3bc0371942444dc014bc307b875071e29eea98,3931 +- hackage-security-0.6.0.0@sha256:69987d46e7b55fe5f0fc537021c3873c5f6f44a6665d349ee6995fd593df8147,11976 +- hoogle-5.0.17.14@sha256:a35eab4f833cd131f1abc79360e3bdbc5aecd7526b9a530ac606580e18691e2b,3173 +- hpack-0.33.0@sha256:ca82f630abe0fba199aa05dcc9942ee8bf137e1425049a7a9ac8458c82d9dcc9,4406 +- yesod-gitrepo-0.3.0@sha256:7aad996935065726ce615c395d735cc01dcef3993b1788f670f6bfc866085e02,1191 +- lukko-0.1.1.1@sha256:5c674bdd8a06b926ba55d872abe254155ed49a58df202b4d842b643e5ed6bcc9,4289 +- github: commercialhaskell/pantry + commit: 86462a97c4d8091993cc6e246fd0f2ae5aa608f0 +- github: fpco/casa + commit: fc0ed26858bfc4f2966ed2dfb2871bae9266dda6 subdirs: - - subs/http-download - - subs/pantry - - subs/rio-prettyprint + - casa-client + - casa-types From bdcdd1887a57b9298d403c77490a41eebb346bd1 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 12 Feb 2020 02:21:12 +0300 Subject: [PATCH 3/3] Store fallback cabal files into pantry. And few follow up improvements: * Fix atomic durable writing, since issue in RIO was fixed * Log information about falling back onto the core-cabal-files repo * Convert conduit pipe to Maybe fishes. * Make sure module names, package name and version are added for fallback cabal files --- src/Handler/Package.hs | 6 +- src/Stackage/Database/Cron.hs | 83 ++++++++++---------- src/Stackage/Database/PackageInfo.hs | 36 +++++---- src/Stackage/Database/Query.hs | 111 +++++++++++++++++++++------ src/Stackage/Database/Schema.hs | 2 +- src/Stackage/Database/Types.hs | 3 +- src/Stackage/Snapshot/Diff.hs | 2 +- src/Types.hs | 10 +-- stack.yaml | 2 +- 9 files changed, 160 insertions(+), 95 deletions(-) diff --git a/src/Handler/Package.hs b/src/Handler/Package.hs index 241ab2b..b1eca39 100644 --- a/src/Handler/Package.hs +++ b/src/Handler/Package.hs @@ -73,9 +73,7 @@ checkSpam pname inner = do $(widgetFile "spam-package") else inner -packagePage :: Maybe SnapshotPackageInfo - -> PackageNameP - -> Handler Html +packagePage :: Maybe SnapshotPackageInfo -> PackageNameP -> Handler Html packagePage mspi pname = track "Handler.Package.packagePage" $ checkSpam pname $ @@ -86,8 +84,6 @@ packagePage mspi pname = Just spi -> handlePackage $ Right spi - - handlePackage :: Either HackageCabalInfo SnapshotPackageInfo -> Handler Html handlePackage epi = do (isDeprecated, inFavourOf) <- getDeprecated pname diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index 8e96cdd..620cf19 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -46,6 +46,7 @@ import Pantry.Internal.Stackage (HackageTarballResult(..), import Path (parseAbsDir, toFilePath) import RIO import RIO.Directory +import RIO.File import RIO.FilePath import RIO.List as L import qualified RIO.Map as Map @@ -115,7 +116,6 @@ newHoogleLocker env man = mkSingleRun hoogleLocker hoogleLocker name = runRIO env $ do let fp = T.unpack $ hoogleKey name - fptmp = fp <.> "tmp" exists <- doesFileExist fp if exists then return $ Just fp @@ -126,24 +126,17 @@ newHoogleLocker env man = mkSingleRun hoogleLocker case responseStatus res of status | status == status200 -> do - createDirectoryIfMissing True $ takeDirectory fptmp - -- TODO: https://github.com/commercialhaskell/rio/issues/160 - -- withBinaryFileDurableAtomic fp WriteMode $ \h -> - -- runConduitRes $ - -- bodyReaderSource (responseBody res) .| ungzip .| - -- sinkHandle h - runConduitRes $ + createDirectoryIfMissing True $ takeDirectory fp + withBinaryFileDurableAtomic fp WriteMode $ \h -> + runConduitRes $ bodyReaderSource (responseBody res) .| ungzip .| - sinkFile fptmp - renamePath fptmp fp + sinkHandle h return $ Just fp | status == status404 -> do logDebug $ "NotFound: " <> display (hoogleUrl name) return Nothing | otherwise -> do body <- liftIO $ brConsume $ responseBody res - -- TODO: ideally only consume the body when log level set to - -- LevelDebug, will require a way to get LogLevel from LogFunc mapM_ (logDebug . displayBytesUtf8) body return Nothing @@ -251,7 +244,9 @@ makeCorePackageGetters = do "Error parsing 'global-hints.yaml' file: " <> fromString (displayException exc) return mempty -getCoreCabalFiles :: FilePath -> RIO StackageCron (Map PackageIdentifierP GenericPackageDescription) +getCoreCabalFiles :: + FilePath + -> RIO StackageCron (Map PackageIdentifierP (GenericPackageDescription, CabalFileIds)) getCoreCabalFiles rootDir = do coreCabalFilesDir <- getCoreCabalFilesDir rootDir cabalFileNames <- getDirectoryContents coreCabalFilesDir @@ -262,11 +257,10 @@ getCoreCabalFiles rootDir = do Nothing -> do logError $ "Invalid package identifier: " <> fromString cabalFileName pure Nothing - Just pid@(PackageIdentifierP pname _) -> do - mgpd <- - readFileBinary (coreCabalFilesDir cabalFileName) >>= - parseCabalBlobMaybe pname - pure ((,) pid <$> mgpd) + Just pid -> do + cabalBlob <- readFileBinary (coreCabalFilesDir cabalFileName) + mCabalInfo <- run $ addCabalFile pid cabalBlob + pure ((,) pid <$> mCabalInfo) pure $ Map.fromList $ catMaybes cabalFiles -- | Core package info rarely changes between the snapshots, therefore it would be wasteful to @@ -275,7 +269,7 @@ getCoreCabalFiles rootDir = do -- package on subsequent invocations. makeCorePackageGetter :: CompilerP - -> Map PackageIdentifierP GenericPackageDescription + -> Map PackageIdentifierP (GenericPackageDescription, CabalFileIds) -> PackageNameP -> VersionP -> RIO StackageCron (Maybe CorePackageGetter) @@ -284,9 +278,17 @@ makeCorePackageGetter _compiler fallbackCabalFileMap pname ver = Nothing -> do logWarn $ "Core package from global-hints: '" <> display pid <> "' was not found in pantry." - pure (pure . (,,,) Nothing Nothing pid <$> Map.lookup pid fallbackCabalFileMap) + forM (Map.lookup pid fallbackCabalFileMap) $ \(gpd, cabalFileIds) -> do + logInfo $ + "Falling back on '" <> display pid <> + ".cabal' file from the commercialhaskell/core-cabal-files repo" + pure $ pure (Left cabalFileIds, Nothing, pid, gpd) Just (hackageCabalId, blobId, _) -> do pkgInfoRef <- newIORef Nothing -- use for caching of pkgInfo + let getCabalFileIdsTree gpd = + \case + Just tree -> pure $ Right tree + Nothing -> Left <$> getCabalFileIds blobId gpd let getMemoPackageInfo = readIORef pkgInfoRef >>= \case Just pkgInfo -> return pkgInfo @@ -296,17 +298,21 @@ makeCorePackageGetter _compiler fallbackCabalFileMap pname ver = htr <- getHackageTarball pir Nothing case htrFreshPackageInfo htr of Just (gpd, treeId) -> do - mTree <- run $ getEntity treeId - let pkgInfo = (mTree, Just hackageCabalId, pid, gpd) + eTree <- + run $ do + mTree <- getEntity treeId + getCabalFileIdsTree gpd mTree + let pkgInfo = (eTree, Just hackageCabalId, pid, gpd) gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo pure pkgInfo Nothing -> do - (cabalBlob, mTree) <- - run - ((,) <$> loadBlobById blobId <*> - getTreeForKey (packageTreeKey (htrPackage htr))) - let gpd = parseCabalBlob cabalBlob - pkgInfo = (mTree, Just hackageCabalId, pid, gpd) + (gpd, eCabalTree) <- + run $ do + cabalBlob <- loadBlobById blobId + let gpd = parseCabalBlob cabalBlob + mTree <- getTreeForKey (packageTreeKey (htrPackage htr)) + (,) gpd <$> getCabalFileIdsTree gpd mTree + let pkgInfo = (eCabalTree, Just hackageCabalId, pid, gpd) gpd `deepseq` writeIORef pkgInfoRef $ Just pkgInfo pure pkgInfo pure $ Just getMemoPackageInfo @@ -348,11 +354,12 @@ addPantryPackage sid compiler isHidden flags (PantryPackage pc treeKey) = do , tid /= treeId -> do lift $ logError $ "Pantry Tree Key mismatch for: " <> display pc pure False - mTree@(Just (Entity _ Tree {treeCabal})) + Just tree@(Entity _ Tree {treeCabal}) | Just treeCabal' <- treeCabal -> do gpd <- getCachedGPD treeCabal' mgpd let mhcid = Just hcid - addSnapshotPackage sid compiler Hackage mTree mhcid isHidden flags pid gpd + eTree = Right tree + addSnapshotPackage sid compiler Hackage eTree mhcid isHidden flags pid gpd pure True _ -> do lift $ logError $ "Pantry is missing the source tree for " <> display pc @@ -386,9 +393,7 @@ checkForDocs snapshotId snapName = do runConduit $ AWS.paginate (req bucketName) .| concatMapC (^. lovrsContents) .| mapC (\obj -> toText (obj ^. oKey)) .| - concatMapC (T.stripSuffix ".html") .| - concatMapC (T.stripPrefix prefix) .| - concatMapC pathToPackageModule .| + concatMapC (T.stripSuffix ".html" >=> T.stripPrefix prefix >=> pathToPackageModule) .| sinkList -- it is faster to download all modules in this snapshot, than process them with a conduit all -- the way to the database. @@ -515,7 +520,7 @@ decideOnSnapshotUpdate SnapshotFileInfo {sfiSnapName, sfiUpdatedOn, sfiSnapshotF _ -> return Nothing type CorePackageGetter - = RIO StackageCron ( Maybe (Entity Tree) + = RIO StackageCron ( Either CabalFileIds (Entity Tree) , Maybe HackageCabalId , PackageIdentifierP , GenericPackageDescription) @@ -617,8 +622,8 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {.. ] Just compilerCorePackages -> forM_ compilerCorePackages $ \getCorePackageInfo -> do - (mTree, mhcid, pid, gpd) <- getCorePackageInfo - run $ addSnapshotPackage snapshotId sfCompiler Core mTree mhcid False mempty pid gpd + (eTree, mhcid, pid, gpd) <- getCorePackageInfo + run $ addSnapshotPackage snapshotId sfCompiler Core eTree mhcid False mempty pid gpd return $ do checkForDocsSucceeded <- tryAny (checkForDocs snapshotId snapName) >>= \case @@ -726,12 +731,8 @@ createHoogleDB snapshotId snapName = withResponseUnliftIO req {decompress = const True} man $ \res -> do throwErrorStatusCodes req res createDirectoryIfMissing True $ takeDirectory tarFP - --withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle -> - --FIXME: https://github.com/commercialhaskell/rio/issues/160 - let tmpTarFP = tarFP <.> "tmp" - withBinaryFile tmpTarFP WriteMode $ \tarHandle -> + withBinaryFileDurableAtomic tarFP WriteMode $ \tarHandle -> runConduitRes $ bodyReaderSource (responseBody res) .| sinkHandle tarHandle - renameFile tmpTarFP tarFP void $ tryIO $ removeDirectoryRecursive bindir void $ tryIO $ removeFile outname createDirectoryIfMissing True bindir diff --git a/src/Stackage/Database/PackageInfo.hs b/src/Stackage/Database/PackageInfo.hs index 1399639..47eac31 100644 --- a/src/Stackage/Database/PackageInfo.hs +++ b/src/Stackage/Database/PackageInfo.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} module Stackage.Database.PackageInfo ( PackageInfo(..) , Identifier(..) @@ -14,10 +14,11 @@ module Stackage.Database.PackageInfo ) where import CMarkGFM -import Data.Coerce import Data.Char (isSpace) +import Data.Coerce import Data.Map.Merge.Strict as Map import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Package (Dependency(..)) import Distribution.PackageDescription (CondTree(..), Condition(..), @@ -26,28 +27,29 @@ import Distribution.PackageDescription (CondTree(..), Condition(..), GenericPackageDescription, author, condExecutables, condLibrary, description, genPackageFlags, homepage, - license, maintainer, - packageDescription, synopsis) + license, maintainer, packageDescription, + synopsis) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) import Distribution.Pretty (prettyShow) import Distribution.System (Arch(X86_64), OS(Linux)) import Distribution.Types.CondTree (CondBranch(..)) import Distribution.Types.Library (exposedModules) +import Distribution.Types.PackageDescription (PackageDescription(package)) import Distribution.Types.VersionRange (VersionRange, intersectVersionRanges, normaliseVersionRange, withinRange) import Distribution.Version (simplifyVersionRange) -import qualified Data.Text.Encoding as T import RIO import qualified RIO.Map as Map import qualified RIO.Map.Unchecked as Map (mapKeysMonotonic) import Stackage.Database.Haddock (renderHaddock) import Stackage.Database.Types (Changelog(..), Readme(..)) import Text.Blaze.Html (Html, preEscapedToHtml, toHtml) -import Types (CompilerP(..), FlagNameP(..), ModuleNameP(..), PackageNameP(..), - SafeFilePath, VersionP(..), VersionRangeP(..), unSafeFilePath) -import Yesod.Form.Fields (Textarea(..)) import Text.Email.Validate +import Types (CompilerP(..), FlagNameP(..), ModuleNameP(..), PackageIdentifierP, + PackageNameP(..), SafeFilePath, VersionP(..), VersionRangeP(..), + unSafeFilePath, dtDisplay) +import Yesod.Form.Fields (Textarea(..)) data PackageInfo = PackageInfo @@ -79,7 +81,7 @@ toPackageInfo gpd mreadme mchangelog = , piHomepage = case T.strip $ T.pack $ homepage pd of "" -> Nothing - x -> Just x + x -> Just x , piLicenseName = T.pack $ prettyShow $ license pd } where @@ -125,17 +127,23 @@ parseCabalBlob cabalBlob = parseCabalBlobMaybe :: (MonadIO m, MonadReader env m, HasLogFunc env) - => PackageNameP + => PackageIdentifierP -> ByteString -> m (Maybe GenericPackageDescription) -parseCabalBlobMaybe packageName cabalBlob = +parseCabalBlobMaybe pidp cabalBlob = case snd $ runParseResult $ parseGenericPackageDescription cabalBlob of Left err -> Nothing <$ logError - ("Problem parsing cabal blob for '" <> display packageName <> "': " <> - displayShow err) - Right pgd -> pure $ Just pgd + ("Problem parsing cabal blob for '" <> display pidp <> "': " <> displayShow err) + Right gpd -> do + let pid = package (packageDescription gpd) + unless (textDisplay (dtDisplay pid :: Utf8Builder) == textDisplay pidp) $ + logError $ + "Supplied package identifier: '" <> display pidp <> + "' does not match the one in cabal file: '" <> + dtDisplay pid + pure $ Just gpd getCheckCond :: CompilerP -> Map FlagName Bool -> GenericPackageDescription -> Condition ConfVar -> Bool diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 7d7ad96..c24b6e0 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Stackage.Database.Query ( @@ -52,13 +53,15 @@ module Stackage.Database.Query , getTreeForKey , treeCabal -- ** Stackage server + , CabalFileIds + , addCabalFile + , getCabalFileIds , addSnapshotPackage , getHackageCabalByRev0 , getHackageCabalByKey , snapshotMarkUpdated , insertSnapshotName , markModuleHasDocs - , insertSnapshotPackageModules , insertDeps -- ** For Hoogle db creation , lastLtsNightly @@ -71,11 +74,14 @@ import qualified Data.List as L import Database.Esqueleto import Database.Esqueleto.Internal.Language (FromPreprocess) import Database.Esqueleto.Internal.Sql +import Distribution.Types.PackageId (PackageIdentifier(PackageIdentifier)) +import Distribution.PackageDescription (packageDescription) +import Distribution.Types.PackageDescription (PackageDescription(package)) import qualified Database.Persist as P import Pantry.Internal.Stackage (EntityField(..), PackageName, Version, getBlobKey, getPackageNameById, getPackageNameId, getTreeForKey, getVersionId, - loadBlobById, mkSafeFilePath) + loadBlobById, storeBlob, mkSafeFilePath) import RIO hiding (on, (^.)) import qualified RIO.Map as Map import qualified RIO.Set as Set @@ -776,6 +782,75 @@ insertDeps pid snapshotPackageId dependencies = display dep return $ Just dep +data CabalFileIds = CabalFileIds + { cfiPackageNameId :: !PackageNameId + , cfiVersionId :: !VersionId + , cfiCabalBlobId :: !(Maybe BlobId) + , cfiModuleNameIds :: ![ModuleNameId] + } + +getCabalFileIds :: + HasLogFunc env + => BlobId + -> GenericPackageDescription + -> ReaderT SqlBackend (RIO env) CabalFileIds +getCabalFileIds cabalBlobId gpd = do + let PackageIdentifier name ver = package (packageDescription gpd) + packageNameId <- getPackageNameId name + versionId <- getVersionId ver + moduleNameIds <- mapM insertModuleSafe (extractModuleNames gpd) + pure + CabalFileIds + { cfiPackageNameId = packageNameId + , cfiVersionId = versionId + , cfiCabalBlobId = Just cabalBlobId + , cfiModuleNameIds = moduleNameIds + } + +addCabalFile :: + HasLogFunc env + => PackageIdentifierP + -> ByteString + -> ReaderT SqlBackend (RIO env) (Maybe (GenericPackageDescription, CabalFileIds)) +addCabalFile pid cabalBlob = do + mgpd <- lift $ parseCabalBlobMaybe pid cabalBlob + forM mgpd $ \gpd -> do + (cabalBlobId, _) <- storeBlob cabalBlob + cabalIds <- getCabalFileIds cabalBlobId gpd + pure (gpd, cabalIds) + +getPackageIds :: + GenericPackageDescription + -> Either CabalFileIds (Entity Tree) + -> ReaderT SqlBackend (RIO env) (CabalFileIds, Maybe (TreeId, BlobId)) +getPackageIds gpd = + \case + Left cabalFileIds -> pure (cabalFileIds, Nothing) + Right (Entity treeId tree) + -- -- TODO: Remove Maybe from cfiCabalBlobId and + -- -- Generate cabal file from package.yaml: + -- case treeCabal tree of + -- Just cabalBlobId -> pure cabalBlobId + -- Nothing -> do + -- let rawMetaData = RawPackageMetadata { + -- rpmName = Just pname + -- , rpmVersion = Just pver + -- , rpmTreeKey = treeKey tree + -- } + -- rpli = ... get + -- generateHPack (RPLIArchive / RPLIRepo ..) treeId treeVersion tree + -- ... + -> do + moduleNameIds <- mapM insertModuleSafe (extractModuleNames gpd) + let cabalFileIds = + CabalFileIds + { cfiPackageNameId = treeName tree + , cfiVersionId = treeVersion tree + , cfiCabalBlobId = treeCabal tree + , cfiModuleNameIds = moduleNameIds + } + pure (cabalFileIds, Just (treeId, treeKey tree)) + -- TODO: Optimize, whenever package is already in one snapshot only create the modules and new -- SnapshotPackage addSnapshotPackage :: @@ -783,30 +858,27 @@ addSnapshotPackage :: => SnapshotId -> CompilerP -> Origin - -> Maybe (Entity Tree) + -> Either CabalFileIds (Entity Tree) -> Maybe HackageCabalId -> Bool -> Map FlagNameP Bool -> PackageIdentifierP -> GenericPackageDescription -> ReaderT SqlBackend (RIO env) () -addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden flags pid gpd = do - let PackageIdentifierP pname pver = pid - mTreeId = entityKey <$> mTree - packageNameId <- - maybe (getPackageNameId (unPackageNameP pname)) (pure . treeName . entityVal) mTree - versionId <- maybe (getVersionId (unVersionP pver)) (pure . treeVersion . entityVal) mTree +addSnapshotPackage snapshotId compiler origin eCabalTree mHackageCabalId isHidden flags pid gpd = do + (CabalFileIds{..}, mTree) <- getPackageIds gpd eCabalTree + let mTreeId = fst <$> mTree mrevision <- maybe (pure Nothing) getHackageRevision mHackageCabalId mreadme <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mreadmeQuery mchangelog <- fromMaybe (pure Nothing) $ getContentTreeEntryId <$> mTreeId <*> mchangelogQuery let snapshotPackage = SnapshotPackage { snapshotPackageSnapshot = snapshotId - , snapshotPackagePackageName = packageNameId - , snapshotPackageVersion = versionId + , snapshotPackagePackageName = cfiPackageNameId + , snapshotPackageVersion = cfiVersionId , snapshotPackageRevision = mrevision - , snapshotPackageCabal = treeCabal =<< entityVal <$> mTree - , snapshotPackageTreeBlob = treeKey . entityVal <$> mTree + , snapshotPackageCabal = cfiCabalBlobId + , snapshotPackageTreeBlob = snd <$> mTree , snapshotPackageOrigin = origin , snapshotPackageOriginUrl = "" -- TODO: add , snapshotPackageSynopsis = getSynopsis gpd @@ -831,7 +903,8 @@ addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden fla forM_ msnapshotPackageId $ \snapshotPackageId -> do _ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd) -- TODO: collect all missing dependencies and make a report - insertSnapshotPackageModules snapshotPackageId (extractModuleNames gpd) + forM_ cfiModuleNameIds $ \modNameId -> do + void $ P.insertBy (SnapshotPackageModule snapshotPackageId modNameId False) getContentTreeEntryId :: TreeId @@ -978,16 +1051,6 @@ getSnapshotPackageCabalBlob snapshotId pname = (pn ^. PackageNameName ==. val pname)) return (blob ^. BlobContents) - --- | Add all modules available for the package in a particular snapshot. Initially they are marked --- as without available documentation. -insertSnapshotPackageModules :: - SnapshotPackageId -> [ModuleNameP] -> ReaderT SqlBackend (RIO env) () -insertSnapshotPackageModules snapshotPackageId = - mapM_ $ \modName -> do - moduleId <- insertModuleSafe modName - void $ P.insertBy (SnapshotPackageModule snapshotPackageId moduleId False) - -- | Idempotent and thread safe way of adding a new module. insertModuleSafe :: ModuleNameP -> ReaderT SqlBackend (RIO env) ModuleNameId insertModuleSafe modName = do diff --git a/src/Stackage/Database/Schema.hs b/src/Stackage/Database/Schema.hs index 6adedc2..bff3b22 100644 --- a/src/Stackage/Database/Schema.hs +++ b/src/Stackage/Database/Schema.hs @@ -50,7 +50,7 @@ import Database.Persist.Postgresql import Database.Persist.TH import Pantry (HasPantryConfig(..), Revision) import Pantry.Internal.Stackage as PS (BlobId, HackageCabalId, ModuleNameId, - PackageNameId, Tree(..), TreeEntry(..), + PackageNameId, Tree(..), TreeEntryId, TreeId, Unique(..), VersionId, unBlobKey) import Pantry.Internal.Stackage (PantryConfig(..), Storage(..)) diff --git a/src/Stackage/Database/Types.hs b/src/Stackage/Database/Types.hs index 4d2c756..8a47361 100644 --- a/src/Stackage/Database/Types.hs +++ b/src/Stackage/Database/Types.hs @@ -51,8 +51,7 @@ import qualified Data.Text as T import Data.Text.Read (decimal) import Network.AWS (Env, HasEnv(..)) import Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..), - HasPantryConfig(..), PackageIdentifierRevision(..), TreeKey(..)) -import Pantry.Internal.Stackage as Pantry (PantryConfig) + HasPantryConfig(..), PantryConfig, PackageIdentifierRevision(..), TreeKey(..)) import Pantry.SHA256 (fromHexText) import RIO import RIO.Process (HasProcessContext(..), ProcessContext) diff --git a/src/Stackage/Snapshot/Diff.hs b/src/Stackage/Snapshot/Diff.hs index 9e40bda..2b8f7bb 100644 --- a/src/Stackage/Snapshot/Diff.hs +++ b/src/Stackage/Snapshot/Diff.hs @@ -22,7 +22,7 @@ import Data.These import RIO import Stackage.Database (GetStackageDatabase, SnapshotId, getPackagesForSnapshot) -import Stackage.Database.Types (PackageListingInfo(..), SnapName) +import Stackage.Database.Types (PackageListingInfo(..)) import Types import Web.PathPieces diff --git a/src/Types.hs b/src/Types.hs index fdc8360..f1d68af 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -61,18 +61,16 @@ import Database.Persist import Database.Persist.Sql (PersistFieldSql(sqlType)) import qualified Distribution.ModuleName as DT (components, fromComponents, validModuleComponent) -import Distribution.PackageDescription (FlagName, GenericPackageDescription) +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.Parsec as DT (Parsec) import Distribution.Pretty as DT (Pretty) import qualified Distribution.Text as DT (display, simpleParse) import Distribution.Types.VersionRange (VersionRange) import Distribution.Version (mkVersion, versionNumbers) -import Pantry (Revision(..)) +import Pantry (FlagName, Revision(..), packageNameString, parsePackageName, + parseVersionThrowing, parseVersion, versionString) import Pantry.Internal.Stackage (ModuleNameP(..), PackageNameP(..), - SafeFilePath, VersionP(..), packageNameString, - parsePackageName, parseVersion, - parseVersionThrowing, unSafeFilePath, - versionString) + SafeFilePath, VersionP(..), unSafeFilePath) import RIO import qualified RIO.Map as Map import RIO.Time (Day) diff --git a/stack.yaml b/stack.yaml index c12175d..68bab6a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,7 +9,7 @@ extra-deps: - yesod-gitrepo-0.3.0@sha256:7aad996935065726ce615c395d735cc01dcef3993b1788f670f6bfc866085e02,1191 - lukko-0.1.1.1@sha256:5c674bdd8a06b926ba55d872abe254155ed49a58df202b4d842b643e5ed6bcc9,4289 - github: commercialhaskell/pantry - commit: 86462a97c4d8091993cc6e246fd0f2ae5aa608f0 + commit: ed48bebc30e539280ad7e13680480be2b87b97ea - github: fpco/casa commit: fc0ed26858bfc4f2966ed2dfb2871bae9266dda6 subdirs: