Skip to content

Commit f56baf0

Browse files
disassemblerdisassembler
authored
Merge pull request #5415 from input-output-hk/fraser-iohk/release-changelog-script
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
2 parents 1f19001 + 6b485a5 commit f56baf0

File tree

2 files changed

+272
-0
lines changed

2 files changed

+272
-0
lines changed

‎RELEASE.md‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -65,3 +65,15 @@ for running on production networks. The same version can be re-released without
6565

6666
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
6767
to open them up to the larger community. The release team also meets ad-hoc as needed and collaborates asynchronously throughout the week.
68+
69+
# Release notes
70+
71+
# Detailed changelog table
72+
73+
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.
74+
75+
> example usage (be sure to run `cabal build all` at least once beforehand):
76+
> ```
77+
> ./scripts/generate-release-changelog-links.hs ./dist-newstyle/cache/build.json $GITHUB_API_TOKEN
78+
> ```
79+
> for more information, including how to generate / retrieve a GitHub API token, use `./scripts/generate-release-changelog-links.hs --help`

‎scripts/generate-release-changelog-links.hs‎

Lines changed: 260 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,260 @@
1+
#!/usr/bin/env cabal
2+
{- cabal:
3+
build-depends:
4+
base,
5+
aeson,
6+
bytestring,
7+
cabal-plan,
8+
case-insensitive,
9+
containers,
10+
foldl,
11+
github,
12+
optparse-applicative,
13+
pandoc ^>= 3.1,
14+
prettyprinter,
15+
req,
16+
text,
17+
turtle ^>= 1.6.0,
18+
default-extensions:
19+
BlockArguments,
20+
DataKinds,
21+
ImportQualifiedPost,
22+
LambdaCase,
23+
OverloadedStrings,
24+
RecordWildCards
25+
ghc-options: -Wall -Wextra -Wcompat
26+
-}
27+
28+
module Main (main) where
29+
30+
import Cabal.Plan
31+
import qualified Control.Foldl as Foldl
32+
import Data.Aeson
33+
import Data.ByteString.Char8 (ByteString)
34+
import qualified Data.CaseInsensitive as CI
35+
import Data.Foldable
36+
import Data.Map.Strict (Map)
37+
import qualified Data.Map.Strict as Map
38+
import Data.Maybe
39+
import qualified Data.Text.Encoding as Text
40+
import Data.Version
41+
import qualified GitHub
42+
import Network.HTTP.Req
43+
import Options.Applicative
44+
import Prettyprinter
45+
import qualified Prettyprinter.Util as PP
46+
import qualified Text.Pandoc as Pandoc
47+
import Turtle
48+
49+
main :: IO ()
50+
main = sh do
51+
52+
(planJsonFilePath, gitHubAccessToken) <-
53+
options generateReleaseChangelogLinksDescription do
54+
(,) <$> argPath "plan_json_path" "Path of the plan.json file"
55+
<*> fmap (GitHubAccessToken . Text.encodeUtf8) (argText "github_access_token" "GitHub personal access token")
56+
57+
packagesMap <- getCHaPPackagesMap
58+
59+
changelogPaths <- reduce Foldl.list do
60+
61+
-- find all of the packages in the plan.json that are hosted on CHaP
62+
printf ("Reading Cabal plan from "%w%"\n") planJsonFilePath
63+
version@(PkgId n v) <- nub $ selectPackageVersion planJsonFilePath
64+
65+
-- from cardano-haskell-packages, retrieve the package repo / commit / subdir
66+
printf ("Looking up CHaP entry for "%repr version%"\n")
67+
chapEntry <- lookupCHaPEntry version packagesMap
68+
69+
-- from github, get the package's CHANGELOG.md location
70+
printf ("Searching for CHANGELOG.md on GitHub for "%repr version%"\n")
71+
changelogLocation <- findChangelogFromGitHub gitHubAccessToken chapEntry
72+
73+
pure (n, v, changelogLocation)
74+
75+
-- generate a massive markdown table
76+
let writerOptions =
77+
Pandoc.def { Pandoc.writerExtensions = Pandoc.githubMarkdownExtensions }
78+
pandocOutput = Pandoc.runPure do
79+
Pandoc.writeMarkdown writerOptions (generatePandoc changelogPaths)
80+
81+
case pandocOutput of
82+
Left pandocError -> die $
83+
"Failed to render markdown with error " <> Pandoc.renderError pandocError
84+
Right res -> printf (s%"\n") res
85+
86+
generateReleaseChangelogLinksDescription :: Description
87+
generateReleaseChangelogLinksDescription = Description $
88+
mconcat
89+
[ "generate-release-changelog-links.hs"
90+
, line, line
91+
, fillSep $ PP.words
92+
"This script requires a GitHub personal access token, which can be \
93+
\generated either at https://github.com/settings/tokens or retrieved \
94+
\using the GitHub CLI tool with `gh auth token` (after logging in)"
95+
]
96+
97+
selectPackageVersion :: FilePath -> Shell PkgId
98+
selectPackageVersion planJsonFilePath = do
99+
cabalPlan <- liftIO do
100+
eitherDecodeFileStrict planJsonFilePath >>= \case
101+
Left aesonError ->
102+
die $ "Failed to parse plan.json: " <> fromString aesonError
103+
Right res -> pure res
104+
105+
Unit{..} <- select (pjUnits cabalPlan)
106+
107+
-- we only care about packages which are hosted on CHaP
108+
guard (isProbablyCHaP Unit{..})
109+
110+
pure uPId
111+
112+
hackageURI :: URI
113+
hackageURI =
114+
URI "http://hackage.haskell.org/"
115+
116+
isProbablyCHaP :: Unit -> Bool
117+
isProbablyCHaP Unit{..} =
118+
case uPkgSrc of
119+
Just (RepoTarballPackage (RepoSecure repoUri)) -> repoUri /= hackageURI
120+
_ -> False
121+
122+
newtype CHaPPackages = CHaPPackages [PackageDescription]
123+
deriving (Show, Eq, Ord)
124+
125+
instance FromJSON CHaPPackages where
126+
parseJSON v = CHaPPackages <$> parseJSON v
127+
128+
data PackageDescription = PackageDescription
129+
{ packageName :: Text
130+
, packageVersion :: Version
131+
, packageURL :: Text
132+
}
133+
deriving (Show, Eq, Ord)
134+
135+
instance FromJSON PackageDescription where
136+
parseJSON = withObject "PackageDescription" $ \obj -> do
137+
PackageDescription <$> obj .: "pkg-name"
138+
<*> obj .: "pkg-version"
139+
<*> obj .: "url"
140+
141+
getCHaPPackages :: MonadIO m => m CHaPPackages
142+
getCHaPPackages = do
143+
fmap responseBody $ liftIO $ runReq defaultHttpConfig $
144+
req GET chapPackagesURL NoReqBody jsonResponse mempty
145+
146+
type PackagesMap = Map (Text, Version) Text
147+
148+
getCHaPPackagesMap :: MonadIO m => m PackagesMap
149+
getCHaPPackagesMap = do
150+
CHaPPackages ps <- getCHaPPackages
151+
pure $ Map.fromList $
152+
map (\PackageDescription{..} -> ((packageName, packageVersion), packageURL)) ps
153+
154+
chapPackagesURL :: Url 'Https
155+
chapPackagesURL =
156+
https "input-output-hk.github.io" /: "cardano-haskell-packages" /: "foliage" /: "packages.json"
157+
158+
lookupCHaPEntry :: PkgId -> PackagesMap -> Shell CHaPEntry
159+
lookupCHaPEntry (PkgId (PkgName n) (Ver v)) packagesMap = do
160+
chapURL <- maybe empty pure $ Map.lookup (n, Version v []) packagesMap
161+
162+
case match packagesJSONUrlPattern chapURL of
163+
[] -> do
164+
printf ("Skipping "%repr n%" as its packages.json URL could not be parsed\n")
165+
empty
166+
chapEntry : _ ->
167+
pure chapEntry
168+
169+
-- parses something like this:
170+
-- github:input-output-hk/cardano-ledger/760a73e89ef040d3ad91b4b0386b3bbace9431a9?dir=eras/byron/ledger/executable-spec
171+
packagesJSONUrlPattern :: Pattern CHaPEntry
172+
packagesJSONUrlPattern = do
173+
void "github:"
174+
owner <- plus (alphaNum <|> char '-')
175+
void "/"
176+
repo <- plus (alphaNum <|> char '-')
177+
void "/"
178+
revision <- plus hexDigit
179+
subdir <- optional do
180+
void "?dir="
181+
plus (alphaNum <|> char '.' <|> char '/' <|> char '-')
182+
eof
183+
pure $ CHaPEntry (GitHub.mkOwnerName owner) (GitHub.mkRepoName repo) revision subdir
184+
185+
data CHaPEntry =
186+
CHaPEntry { entryGitHubOwner :: GitHub.Name GitHub.Owner
187+
, entryGitHubRepo :: GitHub.Name GitHub.Repo
188+
, entryGitHubRevision :: Text
189+
, entrySubdir :: Maybe Text
190+
}
191+
deriving (Show)
192+
193+
findChangelogFromGitHub :: MonadIO m => GitHubAccessToken -> CHaPEntry -> m (Maybe (Text, Text))
194+
findChangelogFromGitHub accessToken CHaPEntry{..} = do
195+
contentDir <- liftIO (runGitHub accessToken (changelogLookupGitHub entryGitHubOwner entryGitHubRepo entrySubdir entryGitHubRevision)) >>= \case
196+
Left gitHubError -> die $
197+
"GitHub lookup failed with error " <> repr gitHubError
198+
Right (GitHub.ContentFile _) -> die
199+
"Expected changelogLookupGitHub to return a directory, but got a single file"
200+
Right (GitHub.ContentDirectory dir) -> pure dir
201+
202+
pure $ case Data.Foldable.find looksLikeChangelog contentDir of
203+
Nothing -> Nothing
204+
Just res -> do
205+
let name = GitHub.contentName (GitHub.contentItemInfo res)
206+
path = GitHub.contentPath (GitHub.contentItemInfo res)
207+
Just (name, constructGitHubPath entryGitHubOwner entryGitHubRepo entryGitHubRevision path)
208+
209+
changelogLookupGitHub :: GitHub.Name GitHub.Owner
210+
-> GitHub.Name GitHub.Repo
211+
-> Maybe Text
212+
-> Text
213+
-> GitHub.Request k GitHub.Content
214+
changelogLookupGitHub owner repo subdir revision =
215+
GitHub.contentsForR owner repo (fromMaybe "" subdir) (Just revision)
216+
217+
looksLikeChangelog :: GitHub.ContentItem -> Bool
218+
looksLikeChangelog GitHub.ContentItem{..} = do
219+
let caseInsensitiveName = CI.mk (GitHub.contentName contentItemInfo)
220+
contentItemType == GitHub.ItemFile && caseInsensitiveName == "CHANGELOG.md"
221+
222+
constructGitHubPath :: GitHub.Name GitHub.Owner
223+
-> GitHub.Name GitHub.Repo
224+
-> Text
225+
-> Text
226+
-> Text
227+
constructGitHubPath =
228+
format ("https://github.com/"%ghname%"/"%ghname%"/blob/"%s%"/"%s)
229+
where
230+
ghname = makeFormat GitHub.untagName
231+
232+
newtype GitHubAccessToken = GitHubAccessToken ByteString
233+
deriving (Show, Eq, Ord)
234+
235+
runGitHub :: GitHub.GitHubRW req res => GitHubAccessToken -> req -> res
236+
runGitHub (GitHubAccessToken tok) =
237+
GitHub.github (GitHub.OAuth tok)
238+
239+
generatePandoc :: [(PkgName, Ver, Maybe (Text, Text))] -> Pandoc.Pandoc
240+
generatePandoc ps =
241+
Pandoc.Pandoc mempty
242+
[ Pandoc.Plain [Pandoc.Str "Package changelogs"]
243+
, Pandoc.Table mempty (Pandoc.Caption Nothing []) colSpec tableHead [tableBody] (Pandoc.TableFoot mempty mempty)
244+
]
245+
where
246+
colSpec = replicate 3 (Pandoc.AlignDefault, Pandoc.ColWidthDefault)
247+
tableHead = Pandoc.TableHead mempty [Pandoc.Row mempty tableHeadCells]
248+
tableHeadCells =
249+
[ mkCell [Pandoc.Str "Package"]
250+
, mkCell [Pandoc.Str "Version"]
251+
, mkCell [Pandoc.Str "Changelog"]
252+
]
253+
tableBody = Pandoc.TableBody mempty 0 [] (fmap mkTableRow ps)
254+
mkTableRow (PkgName n, v, linkMaybe) =
255+
Pandoc.Row mempty
256+
[ mkCell [Pandoc.Str n]
257+
, mkCell [Pandoc.Str (dispVer v)]
258+
, mkCell (foldMap (\(fn, link) -> [Pandoc.Link mempty [Pandoc.Str fn] (link, fn)]) linkMaybe)
259+
]
260+
mkCell t = Pandoc.Cell mempty Pandoc.AlignDefault 1 1 [Pandoc.Plain t]

0 commit comments

Comments
 (0)