From 6b485a5fe61b80065ae5dc2e76888417fad69860 Mon Sep 17 00:00:00 2001 From: Fraser Murray Date: Thu, 27 Jul 2023 15:03:10 +0100 Subject: [PATCH] Add a script that reads cabal's plan.json (and a CHaP index) and generates a markdown table of links to changelogs for each package fix script so it builds on GHC 8.10.7 remove hardcoded github access token and add help to describe how it can be generated / retrieved detect CHaP packages based on "is this not from hackage?" rather than "is this from CHaP?" to accomodate nix-built plan.jsons hlint fixes stylish-haskell formatting add information about the script to RELEASE.md look for package versions using foliage/packages.json rather than meta.tomls remove mention of cardano-haskell-packages from RELEASE.md, since we're now using packages.json --- RELEASE.md | 12 + scripts/generate-release-changelog-links.hs | 260 ++++++++++++++++++++ 2 files changed, 272 insertions(+) create mode 100755 scripts/generate-release-changelog-links.hs diff --git a/RELEASE.md b/RELEASE.md index a99a9a776c1..1a8965bfb36 100644 --- a/RELEASE.md +++ b/RELEASE.md @@ -65,3 +65,15 @@ for running on production networks. The same version can be re-released without The release team meets for a quick touch-point weekly where all team leads are invited. Currently these calls are closed to the public, but in the future we expect to open them up to the larger community. The release team also meets ad-hoc as needed and collaborates asynchronously throughout the week. + +# Release notes + +# Detailed changelog table + +There's a script (`scripts/generate-release-changelog-links.hs`) that generates a table of changelogs for each of the package versions included in a given `cardano-node` release. The script takes a cabal-generated `plan.json` and a GitHub API access token, and outputs a large table which contains links to the `CHANGELOG.md` file (if one exists) for each of the package versions contained in the build plan. + +> example usage (be sure to run `cabal build all` at least once beforehand): +> ``` +> ./scripts/generate-release-changelog-links.hs ./dist-newstyle/cache/build.json $GITHUB_API_TOKEN +> ``` +> for more information, including how to generate / retrieve a GitHub API token, use `./scripts/generate-release-changelog-links.hs --help` diff --git a/scripts/generate-release-changelog-links.hs b/scripts/generate-release-changelog-links.hs new file mode 100755 index 00000000000..ddd0c854999 --- /dev/null +++ b/scripts/generate-release-changelog-links.hs @@ -0,0 +1,260 @@ +#!/usr/bin/env cabal +{- cabal: + build-depends: + base, + aeson, + bytestring, + cabal-plan, + case-insensitive, + containers, + foldl, + github, + optparse-applicative, + pandoc ^>= 3.1, + prettyprinter, + req, + text, + turtle ^>= 1.6.0, + default-extensions: + BlockArguments, + DataKinds, + ImportQualifiedPost, + LambdaCase, + OverloadedStrings, + RecordWildCards + ghc-options: -Wall -Wextra -Wcompat +-} + +module Main (main) where + +import Cabal.Plan +import qualified Control.Foldl as Foldl +import Data.Aeson +import Data.ByteString.Char8 (ByteString) +import qualified Data.CaseInsensitive as CI +import Data.Foldable +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text.Encoding as Text +import Data.Version +import qualified GitHub +import Network.HTTP.Req +import Options.Applicative +import Prettyprinter +import qualified Prettyprinter.Util as PP +import qualified Text.Pandoc as Pandoc +import Turtle + +main :: IO () +main = sh do + + (planJsonFilePath, gitHubAccessToken) <- + options generateReleaseChangelogLinksDescription do + (,) <$> argPath "plan_json_path" "Path of the plan.json file" + <*> fmap (GitHubAccessToken . Text.encodeUtf8) (argText "github_access_token" "GitHub personal access token") + + packagesMap <- getCHaPPackagesMap + + changelogPaths <- reduce Foldl.list do + + -- find all of the packages in the plan.json that are hosted on CHaP + printf ("Reading Cabal plan from "%w%"\n") planJsonFilePath + version@(PkgId n v) <- nub $ selectPackageVersion planJsonFilePath + + -- from cardano-haskell-packages, retrieve the package repo / commit / subdir + printf ("Looking up CHaP entry for "%repr version%"\n") + chapEntry <- lookupCHaPEntry version packagesMap + + -- from github, get the package's CHANGELOG.md location + printf ("Searching for CHANGELOG.md on GitHub for "%repr version%"\n") + changelogLocation <- findChangelogFromGitHub gitHubAccessToken chapEntry + + pure (n, v, changelogLocation) + + -- generate a massive markdown table + let writerOptions = + Pandoc.def { Pandoc.writerExtensions = Pandoc.githubMarkdownExtensions } + pandocOutput = Pandoc.runPure do + Pandoc.writeMarkdown writerOptions (generatePandoc changelogPaths) + + case pandocOutput of + Left pandocError -> die $ + "Failed to render markdown with error " <> Pandoc.renderError pandocError + Right res -> printf (s%"\n") res + +generateReleaseChangelogLinksDescription :: Description +generateReleaseChangelogLinksDescription = Description $ + mconcat + [ "generate-release-changelog-links.hs" + , line, line + , fillSep $ PP.words + "This script requires a GitHub personal access token, which can be \ + \generated either at https://github.com/settings/tokens or retrieved \ + \using the GitHub CLI tool with `gh auth token` (after logging in)" + ] + +selectPackageVersion :: FilePath -> Shell PkgId +selectPackageVersion planJsonFilePath = do + cabalPlan <- liftIO do + eitherDecodeFileStrict planJsonFilePath >>= \case + Left aesonError -> + die $ "Failed to parse plan.json: " <> fromString aesonError + Right res -> pure res + + Unit{..} <- select (pjUnits cabalPlan) + + -- we only care about packages which are hosted on CHaP + guard (isProbablyCHaP Unit{..}) + + pure uPId + +hackageURI :: URI +hackageURI = + URI "http://hackage.haskell.org/" + +isProbablyCHaP :: Unit -> Bool +isProbablyCHaP Unit{..} = + case uPkgSrc of + Just (RepoTarballPackage (RepoSecure repoUri)) -> repoUri /= hackageURI + _ -> False + +newtype CHaPPackages = CHaPPackages [PackageDescription] + deriving (Show, Eq, Ord) + +instance FromJSON CHaPPackages where + parseJSON v = CHaPPackages <$> parseJSON v + +data PackageDescription = PackageDescription + { packageName :: Text + , packageVersion :: Version + , packageURL :: Text + } + deriving (Show, Eq, Ord) + +instance FromJSON PackageDescription where + parseJSON = withObject "PackageDescription" $ \obj -> do + PackageDescription <$> obj .: "pkg-name" + <*> obj .: "pkg-version" + <*> obj .: "url" + +getCHaPPackages :: MonadIO m => m CHaPPackages +getCHaPPackages = do + fmap responseBody $ liftIO $ runReq defaultHttpConfig $ + req GET chapPackagesURL NoReqBody jsonResponse mempty + +type PackagesMap = Map (Text, Version) Text + +getCHaPPackagesMap :: MonadIO m => m PackagesMap +getCHaPPackagesMap = do + CHaPPackages ps <- getCHaPPackages + pure $ Map.fromList $ + map (\PackageDescription{..} -> ((packageName, packageVersion), packageURL)) ps + +chapPackagesURL :: Url 'Https +chapPackagesURL = + https "input-output-hk.github.io" /: "cardano-haskell-packages" /: "foliage" /: "packages.json" + +lookupCHaPEntry :: PkgId -> PackagesMap -> Shell CHaPEntry +lookupCHaPEntry (PkgId (PkgName n) (Ver v)) packagesMap = do + chapURL <- maybe empty pure $ Map.lookup (n, Version v []) packagesMap + + case match packagesJSONUrlPattern chapURL of + [] -> do + printf ("Skipping "%repr n%" as its packages.json URL could not be parsed\n") + empty + chapEntry : _ -> + pure chapEntry + +-- parses something like this: +-- github:input-output-hk/cardano-ledger/760a73e89ef040d3ad91b4b0386b3bbace9431a9?dir=eras/byron/ledger/executable-spec +packagesJSONUrlPattern :: Pattern CHaPEntry +packagesJSONUrlPattern = do + void "github:" + owner <- plus (alphaNum <|> char '-') + void "/" + repo <- plus (alphaNum <|> char '-') + void "/" + revision <- plus hexDigit + subdir <- optional do + void "?dir=" + plus (alphaNum <|> char '.' <|> char '/' <|> char '-') + eof + pure $ CHaPEntry (GitHub.mkOwnerName owner) (GitHub.mkRepoName repo) revision subdir + +data CHaPEntry = + CHaPEntry { entryGitHubOwner :: GitHub.Name GitHub.Owner + , entryGitHubRepo :: GitHub.Name GitHub.Repo + , entryGitHubRevision :: Text + , entrySubdir :: Maybe Text + } + deriving (Show) + +findChangelogFromGitHub :: MonadIO m => GitHubAccessToken -> CHaPEntry -> m (Maybe (Text, Text)) +findChangelogFromGitHub accessToken CHaPEntry{..} = do + contentDir <- liftIO (runGitHub accessToken (changelogLookupGitHub entryGitHubOwner entryGitHubRepo entrySubdir entryGitHubRevision)) >>= \case + Left gitHubError -> die $ + "GitHub lookup failed with error " <> repr gitHubError + Right (GitHub.ContentFile _) -> die + "Expected changelogLookupGitHub to return a directory, but got a single file" + Right (GitHub.ContentDirectory dir) -> pure dir + + pure $ case Data.Foldable.find looksLikeChangelog contentDir of + Nothing -> Nothing + Just res -> do + let name = GitHub.contentName (GitHub.contentItemInfo res) + path = GitHub.contentPath (GitHub.contentItemInfo res) + Just (name, constructGitHubPath entryGitHubOwner entryGitHubRepo entryGitHubRevision path) + +changelogLookupGitHub :: GitHub.Name GitHub.Owner + -> GitHub.Name GitHub.Repo + -> Maybe Text + -> Text + -> GitHub.Request k GitHub.Content +changelogLookupGitHub owner repo subdir revision = + GitHub.contentsForR owner repo (fromMaybe "" subdir) (Just revision) + +looksLikeChangelog :: GitHub.ContentItem -> Bool +looksLikeChangelog GitHub.ContentItem{..} = do + let caseInsensitiveName = CI.mk (GitHub.contentName contentItemInfo) + contentItemType == GitHub.ItemFile && caseInsensitiveName == "CHANGELOG.md" + +constructGitHubPath :: GitHub.Name GitHub.Owner + -> GitHub.Name GitHub.Repo + -> Text + -> Text + -> Text +constructGitHubPath = + format ("https://github.com/"%ghname%"/"%ghname%"/blob/"%s%"/"%s) + where + ghname = makeFormat GitHub.untagName + +newtype GitHubAccessToken = GitHubAccessToken ByteString + deriving (Show, Eq, Ord) + +runGitHub :: GitHub.GitHubRW req res => GitHubAccessToken -> req -> res +runGitHub (GitHubAccessToken tok) = + GitHub.github (GitHub.OAuth tok) + +generatePandoc :: [(PkgName, Ver, Maybe (Text, Text))] -> Pandoc.Pandoc +generatePandoc ps = + Pandoc.Pandoc mempty + [ Pandoc.Plain [Pandoc.Str "Package changelogs"] + , Pandoc.Table mempty (Pandoc.Caption Nothing []) colSpec tableHead [tableBody] (Pandoc.TableFoot mempty mempty) + ] + where + colSpec = replicate 3 (Pandoc.AlignDefault, Pandoc.ColWidthDefault) + tableHead = Pandoc.TableHead mempty [Pandoc.Row mempty tableHeadCells] + tableHeadCells = + [ mkCell [Pandoc.Str "Package"] + , mkCell [Pandoc.Str "Version"] + , mkCell [Pandoc.Str "Changelog"] + ] + tableBody = Pandoc.TableBody mempty 0 [] (fmap mkTableRow ps) + mkTableRow (PkgName n, v, linkMaybe) = + Pandoc.Row mempty + [ mkCell [Pandoc.Str n] + , mkCell [Pandoc.Str (dispVer v)] + , mkCell (foldMap (\(fn, link) -> [Pandoc.Link mempty [Pandoc.Str fn] (link, fn)]) linkMaybe) + ] + mkCell t = Pandoc.Cell mempty Pandoc.AlignDefault 1 1 [Pandoc.Plain t]