From 33e5cb2589d0dfcbcb55b3e10f78fa8a43c5f4f2 Mon Sep 17 00:00:00 2001 From: Bryan Richter Date: Mon, 12 Feb 2024 15:15:22 +0200 Subject: [PATCH] Upgrade all the way to lts-22.6 I stopped at 22.6 because I'm using NixOS and ghc-9.6.3 is the last version available on the stable channel right now. Later snapshots use 9.6.4. --- src/Handler/DownloadStack.hs | 7 +- src/Handler/MirrorStatus.hs | 4 +- src/Stackage/Database/Cron.hs | 144 +++++++++++++-------------- src/Stackage/Database/PackageInfo.hs | 4 +- src/Stackage/Database/Query.hs | 2 +- src/Stackage/Database/Schema.hs | 1 + src/Stackage/Database/Types.hs | 5 +- src/Stackage/Snapshot/Diff.hs | 3 +- stack.yaml | 23 +---- 9 files changed, 87 insertions(+), 106 deletions(-) diff --git a/src/Handler/DownloadStack.hs b/src/Handler/DownloadStack.hs index ecd8e14..154c1e9 100644 --- a/src/Handler/DownloadStack.hs +++ b/src/Handler/DownloadStack.hs @@ -11,6 +11,7 @@ import Data.Conduit.Attoparsec (sinkParser) import Data.WebsiteContent import Import import Yesod.GitRepo +import qualified Data.Aeson.KeyMap as Aeson getDownloadStackListR :: Handler Html getDownloadStackListR = track "Handler.DownloadStack.getDownloadStackListR" $ do @@ -35,14 +36,14 @@ getLatestMatcher man = do return $ \pattern' -> do let pattern'' = pattern' ++ "." Object top <- return val - Array assets <- lookup "assets" top + Array assets <- Aeson.lookup "assets" top headMay $ preferZip $ catMaybes $ map (findMatch pattern'') assets where findMatch pattern' (Object o) = do - String name <- lookup "name" o + String name <- Aeson.lookup "name" o guard $ not $ ".asc" `isSuffixOf` name guard $ pattern' `isInfixOf` name - String url <- lookup "browser_download_url" o + String url <- Aeson.lookup "browser_download_url" o Just url findMatch _ _ = Nothing diff --git a/src/Handler/MirrorStatus.hs b/src/Handler/MirrorStatus.hs index 036573a..7dad1c9 100644 --- a/src/Handler/MirrorStatus.hs +++ b/src/Handler/MirrorStatus.hs @@ -12,6 +12,8 @@ import RIO.Time (diffUTCTime, addUTCTime, getCurrentTime) import Text.XML.Stream.Parse import Data.XML.Types (Event (EventContent), Content (ContentText)) import qualified Prelude +import qualified Data.Aeson.Key as Aeson +import qualified Data.Aeson.KeyMap as Aeson getMirrorStatusR :: Handler Html getMirrorStatusR = do @@ -148,7 +150,7 @@ getLastModifiedGit org repo ref = do lookupJ :: MonadThrow m => Text -> Value -> m Value lookupJ key (Object o) = - case lookup key o of + case Aeson.lookup (Aeson.fromText key) o of Nothing -> error $ "Key not found: " ++ show key Just x -> return x lookupJ key val = error $ concat diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index a1e2215..8c3ab6c 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} module Stackage.Database.Cron ( stackageServerCron , newHoogleLocker @@ -16,7 +17,6 @@ module Stackage.Database.Cron import Conduit import Control.DeepSeq -import qualified Control.Monad.Trans.AWS as AWS (paginate) import Control.SingleRun import qualified Data.ByteString.Char8 as BS8 import qualified Data.Conduit.Binary as CB @@ -29,9 +29,12 @@ import Data.Yaml (decodeFileEither) import Database.Persist hiding (exists) import Database.Persist.Postgresql hiding (exists) import qualified Hoogle -import Network.AWS hiding (Request, Response) -import Network.AWS.Data.Text (toText) -import Network.AWS.S3 +import Amazonka hiding (Request, length, error) +import Amazonka.Data.Text (toText) +import Amazonka.S3 +import Amazonka.S3.ListObjectsV2 +import Amazonka.S3.Lens +import Amazonka.Lens import Network.HTTP.Client import Network.HTTP.Client.Conduit (bodyReaderSource) import Network.HTTP.Simple (getResponseBody, httpJSONEither) @@ -39,9 +42,9 @@ import Network.HTTP.Types (status200, status404) import Pantry (CabalFileInfo(..), DidUpdateOccur(..), HpackExecutable(HpackBundled), PackageIdentifierRevision(..), defaultCasaMaxPerRequest, defaultCasaRepoPrefix, - defaultHackageSecurityConfig, defaultSnapshotLocation) -import Pantry.Internal.Stackage (HackageTarballResult(..), PantryConfig(..), - Storage(..), forceUpdateHackageIndex, + defaultPackageIndexConfig, + defaultSnapshotLocation, withPantryConfig, PantryConfig) +import Pantry.Internal.Stackage (HackageTarballResult(..), forceUpdateHackageIndex, getHackageTarball, packageTreeKey) import Path (parseAbsDir, toFilePath) import RIO @@ -54,7 +57,6 @@ import RIO.Process (mkDefaultProcessContext) import qualified RIO.Set as Set import qualified RIO.Text as T import RIO.Time -import Settings import Stackage.Database.Github import Stackage.Database.PackageInfo import Stackage.Database.Query @@ -86,11 +88,6 @@ hoogleUrl n haddockBucketUrl = T.concat hackageDeprecatedUrl :: Request hackageDeprecatedUrl = "https://hackage.haskell.org/packages/deprecated.json" -withStorage :: (Storage -> IO a) -> IO a -withStorage inner = do - as <- getAppSettings - withStackageDatabase False (appDatabase as) (\db -> inner (Storage (runDatabase db) id)) - getStackageSnapshotsDir :: RIO StackageCron FilePath getStackageSnapshotsDir = do cron <- ask @@ -154,58 +151,52 @@ stackageServerCron StackageCronOptions {..} = do catchIO (bindPortTCP 17834 "127.0.0.1") $ const $ throwString "Stackage Cron loader process already running, exiting." connectionCount <- getNumCapabilities - withStorage $ \storage -> do - lo <- logOptionsHandle stdout True - stackageRootDir <- getAppUserDataDirectory "stackage" - pantryRootDir <- parseAbsDir (stackageRootDir "pantry") - createDirectoryIfMissing True (toFilePath pantryRootDir) - updateRef <- newMVar True - cabalImmutable <- newIORef Map.empty - cabalMutable <- newIORef Map.empty - gpdCache <- newIORef IntMap.empty - defaultProcessContext <- mkDefaultProcessContext - aws <- do - aws' <- newEnv Discover - endpoint <- lookup "AWS_S3_ENDPOINT" <$> getEnvironment - pure $ case endpoint of - Nothing -> aws' - Just ep -> configure (setEndpoint True (BS8.pack ep) 443 s3) aws' - withLogFunc (setLogMinLevel scoLogLevel lo) $ \logFunc -> do - let pantryConfig = - PantryConfig - { pcHackageSecurity = defaultHackageSecurityConfig - , pcHpackExecutable = HpackBundled - , pcRootDir = pantryRootDir - , pcStorage = storage - , pcUpdateRef = updateRef - , pcParsedCabalFilesRawImmutable = cabalImmutable - , pcParsedCabalFilesMutable = cabalMutable - , pcConnectionCount = connectionCount - , pcCasaRepoPrefix = defaultCasaRepoPrefix - , pcCasaMaxPerRequest = defaultCasaMaxPerRequest - , pcSnapshotLocation = defaultSnapshotLocation - } - currentHoogleVersionId <- runRIO logFunc $ do + lo <- logOptionsHandle stdout True + stackageRootDir <- getAppUserDataDirectory "stackage" + pantryRootDir <- parseAbsDir (stackageRootDir "pantry") + createDirectoryIfMissing True (toFilePath pantryRootDir) + gpdCache <- newIORef IntMap.empty + defaultProcessContext <- mkDefaultProcessContext + aws <- do + aws' <- newEnv discover + endpoint <- lookup "AWS_S3_ENDPOINT" <$> getEnvironment + pure $ case endpoint of + Nothing -> aws' + Just ep -> configureService (setEndpoint True (BS8.pack ep) 443 Amazonka.S3.defaultService) aws' + withLogFunc (setLogMinLevel scoLogLevel lo) $ \logFunc -> do + let cronWithPantryConfig :: HasLogFunc env => (PantryConfig -> RIO env a) -> RIO env a + cronWithPantryConfig = + withPantryConfig + pantryRootDir + defaultPackageIndexConfig + HpackBundled + connectionCount + defaultCasaRepoPrefix + defaultCasaMaxPerRequest + defaultSnapshotLocation + + currentHoogleVersionId <- runRIO logFunc $ do + cronWithPantryConfig $ \pantryConfig -> do runStackageMigrations' pantryConfig getCurrentHoogleVersionIdWithPantryConfig pantryConfig - let stackage = - StackageCron - { scPantryConfig = pantryConfig - , scStackageRoot = stackageRootDir - , scProcessContext = defaultProcessContext - , scLogFunc = logFunc - , scForceFullUpdate = scoForceUpdate - , scCachedGPD = gpdCache - , scEnvAWS = aws - , scDownloadBucketName = scoDownloadBucketName - , scDownloadBucketUrl = scoDownloadBucketUrl - , scUploadBucketName = scoUploadBucketName - , scSnapshotsRepo = scoSnapshotsRepo - , scReportProgress = scoReportProgress - , scCacheCabalFiles = scoCacheCabalFiles - , scHoogleVersionId = currentHoogleVersionId - } - runRIO stackage (runStackageUpdate scoDoNotUpload) + let stackage pantryConfig = + StackageCron + { scPantryConfig = pantryConfig + , scStackageRoot = stackageRootDir + , scProcessContext = defaultProcessContext + , scLogFunc = logFunc + , scForceFullUpdate = scoForceUpdate + , scCachedGPD = gpdCache + , scEnvAWS = aws + , scDownloadBucketName = scoDownloadBucketName + , scDownloadBucketUrl = scoDownloadBucketUrl + , scUploadBucketName = scoUploadBucketName + , scSnapshotsRepo = scoSnapshotsRepo + , scReportProgress = scoReportProgress + , scCacheCabalFiles = scoCacheCabalFiles + , scHoogleVersionId = currentHoogleVersionId + } + runRIO logFunc $ cronWithPantryConfig $ \pantryConfig -> runRIO (stackage pantryConfig) (runStackageUpdate scoDoNotUpload) runStackageUpdate :: Bool -> RIO StackageCron () @@ -393,10 +384,11 @@ addPantryPackage sid compiler isHidden flags (PantryPackage pc treeKey) = do checkForDocs :: SnapshotId -> SnapName -> ResourceT (RIO StackageCron) () checkForDocs snapshotId snapName = do bucketName <- lift (scDownloadBucketName <$> ask) + env <- asks scEnvAWS mods <- runConduit $ - AWS.paginate (req bucketName) .| concatMapC (^. lovrsContents) .| - mapC (\obj -> toText (obj ^. oKey)) .| + paginate env (req bucketName) .| concatMapC (fromMaybe [] . (^. listObjectsV2Response_contents)) .| + mapC (\obj -> toText (obj ^. object_key)) .| 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 @@ -414,7 +406,7 @@ checkForDocs snapshotId snapName = do display snapName where prefix = textDisplay snapName <> "/" - req bucketName = listObjectsV2 (BucketName bucketName) & lovPrefix .~ Just prefix + req bucketName = newListObjectsV2 (BucketName bucketName) & listObjectsV2_prefix .~ Just prefix -- | This function records all package modules that have documentation available, the ones -- that are not found in the snapshot reported back as an error. Besides being run -- concurrently this function optimizes the SnapshotPackageId lookup as well, since that can @@ -670,9 +662,9 @@ uploadSnapshotsJSON = do uploadBucket <- scUploadBucketName <$> ask let key = ObjectKey "snapshots.json" uploadFromRIO key $ - set poACL (Just OPublicRead) $ - set poContentType (Just "application/json") $ - putObject (BucketName uploadBucket) key (toBody snapshots) + set putObject_acl (Just ObjectCannedACL_Public_read) $ + set putObject_contentType (Just "application/json") $ + newPutObject (BucketName uploadBucket) key (toBody snapshots) -- | Writes a gzipped version of hoogle db into temporary file onto the file system and then uploads -- it to S3. Temporary file is removed upon completion @@ -684,14 +676,14 @@ uploadHoogleDB fp key = body <- toBody <$> readFileBinary fpgz uploadBucket <- scUploadBucketName <$> ask uploadFromRIO key $ - set poACL (Just OPublicRead) $ putObject (BucketName uploadBucket) key body + set putObject_acl (Just ObjectCannedACL_Public_read) $ newPutObject (BucketName uploadBucket) key body -uploadFromRIO :: AWSRequest a => ObjectKey -> a -> RIO StackageCron () +uploadFromRIO :: (AWSRequest a, Typeable a, Typeable (AWSResponse a)) => ObjectKey -> a -> RIO StackageCron () uploadFromRIO key po = do logInfo $ "Uploading " <> displayShow key <> " to S3 bucket." - env <- ask - eres <- runResourceT $ runAWS env $ trying _Error $ send po + env <- asks scEnvAWS + eres <- runResourceT $ trying _Error $ send env po case eres of Left e -> logError $ "Couldn't upload " <> displayShow key <> " to S3 becuase " <> displayShow e @@ -701,8 +693,9 @@ buildAndUploadHoogleDB :: Bool -> RIO StackageCron () buildAndUploadHoogleDB doNotUpload = do snapshots <- lastLtsNightlyWithoutHoogleDb 5 5 env <- ask + awsEnv <- asks scEnvAWS bucketUrl <- asks scDownloadBucketUrl - locker <- newHoogleLocker (env ^. logFuncL) (env ^. envManager) bucketUrl + locker <- newHoogleLocker (env ^. logFuncL) (awsEnv ^. env_manager) bucketUrl for_ snapshots $ \(snapshotId, snapName) -> unlessM (checkInsertSnapshotHoogleDb False snapshotId) $ do logInfo $ "Starting Hoogle database download: " <> display (hoogleKey snapName) @@ -738,7 +731,8 @@ createHoogleDB snapshotId snapName = -- is present it is not in a corrupted state unlessM (doesFileExist tarFP) $ do req <- parseRequest $ T.unpack tarUrl - man <- view envManager + env <- asks scEnvAWS + let man = env ^. env_manager withResponseUnliftIO req {decompress = const True} man $ \res -> do throwErrorStatusCodes req res createDirectoryIfMissing True $ takeDirectory tarFP diff --git a/src/Stackage/Database/PackageInfo.hs b/src/Stackage/Database/PackageInfo.hs index f47a563..80ecad0 100644 --- a/src/Stackage/Database/PackageInfo.hs +++ b/src/Stackage/Database/PackageInfo.hs @@ -23,7 +23,7 @@ import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Package (Dependency(..)) import Distribution.PackageDescription (CondTree(..), Condition(..), ConfVar(..), - Flag(flagDefault, flagName), FlagName, + PackageFlag(..), flagDefault, flagName, FlagName, GenericPackageDescription, author, condExecutables, condLibrary, description, genPackageFlags, homepage, @@ -152,7 +152,7 @@ getCheckCond compiler overrideFlags gpd = go where go (Var (OS os)) = os == Linux -- arbitrary go (Var (Arch arch)) = arch == X86_64 -- arbitrary - go (Var (Flag flag)) = fromMaybe False $ Map.lookup flag flags + go (Var (PackageFlag flag)) = fromMaybe False $ Map.lookup flag flags go (Var (Impl flavor range)) = flavor == compilerFlavor && compilerVersion `withinRange` range go (Lit b) = b go (CNot c) = not $ go c diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 7f2b5e5..4f94c6e 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -206,7 +206,7 @@ snapshotsJSON = do Just n -> (("nightly" A..= printNightly n) :) return $ A.object $ nightly lts where - toObj lts@(major, _) = T.pack ("lts-" <> show major) A..= printLts lts + toObj lts@(major, _) = fromString ("lts-" <> show major) A..= printLts lts printLts (major, minor) = "lts-" <> show major <> "." <> show minor printNightly day = "nightly-" <> T.pack (show day) diff --git a/src/Stackage/Database/Schema.hs b/src/Stackage/Database/Schema.hs index f5ef5a8..b4cb87d 100644 --- a/src/Stackage/Database/Schema.hs +++ b/src/Stackage/Database/Schema.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} module Stackage.Database.Schema ( -- * Database run diff --git a/src/Stackage/Database/Types.hs b/src/Stackage/Database/Types.hs index 9fd9e79..c42ef55 100644 --- a/src/Stackage/Database/Types.hs +++ b/src/Stackage/Database/Types.hs @@ -50,7 +50,7 @@ module Stackage.Database.Types import Data.Aeson import qualified Data.Text as T import Data.Text.Read (decimal) -import Network.AWS (Env, HasEnv(..)) +import Amazonka (Env) import Pantry (BlobKey(..), CabalFileInfo(..), FileSize(..), HasPantryConfig(..), PantryConfig, PackageIdentifierRevision(..), TreeKey(..)) import Pantry.SHA256 (fromHexText) @@ -97,9 +97,6 @@ data StackageCron = StackageCron , scHoogleVersionId :: !VersionId } -instance HasEnv StackageCron where - environment = lens scEnvAWS (\c f -> c {scEnvAWS = f}) - instance HasLogFunc StackageCron where logFuncL = lens scLogFunc (\c f -> c {scLogFunc = f}) diff --git a/src/Stackage/Snapshot/Diff.hs b/src/Stackage/Snapshot/Diff.hs index 641812c..7371f7a 100644 --- a/src/Stackage/Snapshot/Diff.hs +++ b/src/Stackage/Snapshot/Diff.hs @@ -15,6 +15,7 @@ module Stackage.Snapshot.Diff import ClassyPrelude (sortOn, toCaseFold) import Data.Aeson +import Data.Aeson.Key import qualified Data.Text as T (commonPrefixes) import Data.These import RIO @@ -61,7 +62,7 @@ newtype VersionChange = VersionChange { unVersionChange :: These VersionP Versio deriving (Show, Eq, Generic, Typeable) instance ToJSON (WithSnapshotNames VersionChange) where - toJSON (WithSnapshotNames (toPathPiece -> aKey) (toPathPiece -> bKey) change) = + toJSON (WithSnapshotNames (fromText . toPathPiece -> aKey) (fromText . toPathPiece -> bKey) change) = case change of VersionChange (This a) -> object [ aKey .= a ] VersionChange (That b) -> object [ bKey .= b ] diff --git a/stack.yaml b/stack.yaml index e16eb11..2bc5b89 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,25 +1,10 @@ -resolver: lts-18.28 +resolver: lts-22.6 extra-deps: -- amazonka-1.6.1 -- github: chreekat/amazonka - commit: b/1.6.1-r2-compat - subdirs: [core] -- barrier-0.1.1 -- classy-prelude-yesod-1.5.0 -- unliftio-core-0.1.2.0 -- yesod-gitrepo-0.3.0 -- static-bytes-0.1.0 -- companion-0.1.0 -- aeson-warning-parser-0.1.0 -- hpack-0.35.0 -- http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 -- git: https://github.com/commercialhaskell/pantry.git - commit: 5df643cc1deb561d9c52a9cb6f593aba2bc4c08e - -drop-packages: -- Cabal +- hoogle-5.0.18.4@sha256:1372458e97dff541fcda099236af7936bf93ee6b8c5d15695ee6d9426dff5eed,3171 +- safe-0.3.20@sha256:7813ad56161f57d5162a924de5597d454162a2faed06be6e268b37bb5c19d48d,2312 nix: packages: - zlib - postgresql + - pkg-config