haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-12 04:08:29 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upgrade all the way to lts-22.6

Browse Source 
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.
This commit is contained in:
Bryan Richter 2024-02-12 15:15:22 +02:00
parent c1c7d14e15
commit 33e5cb2589
No known key found for this signature in database
GPG Key ID: B202264020068BFB
9 changed files with 87 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Handler/DownloadStack.hs
View File

@ -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

4
src/Handler/MirrorStatus.hs
View File

@ -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

144
src/Stackage/Database/Cron.hs
View File

@ -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

4
src/Stackage/Database/PackageInfo.hs
View File

@ -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

2
src/Stackage/Database/Query.hs
View File

@ -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)

1
src/Stackage/Database/Schema.hs
View File

@ -15,6 +15,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
module Stackage.Database.Schema
( -- * Database
run

5
src/Stackage/Database/Types.hs
View File

@ -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})

3
src/Stackage/Snapshot/Diff.hs
View File

@ -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 ]

23
stack.yaml
View File

@ -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