6d8a673 · typeable/compaREST

action.yaml+5−5

compare with master

unifiedsplit

@@ -10,10 +10,6 @@ inputs:

10 description: The owner of the repo in which to post the comment.

11 default: "${{ github.repository }}"

12 required: false

13− pull_request:

14− description: The pull request in which to post the comment.

15− default: "${{ github.event.pull_request.number }}"

16− required: false

17 project_name:

13 project_name:

18 description: The name of the project to which the API pertains.

14 description: The name of the project to which the API pertains.

19 required: true

15 required: true

@@ -27,18 +23,22 @@ inputs:

27 new:

23 new:

28 description: The path to new specification of the API.

24 description: The path to new specification of the API.

29 required: true

25 required: true

26+ sha:

27+ description: The sha of the commit to post the check for.

28+ required: false

29+ default: "${{ github.event.pull_request.head.sha }}"

30runs:

31 using: "docker"

32 image: "typeable/comparest-github-action:latest"

33 env:

34 GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"

35 REPO: "${{ inputs.repo }}"

36− PR_NUMBER: "${{ inputs.pull_request }}"

37 PROJECT_NAME: "${{ inputs.project_name }}"

36 PROJECT_NAME: "${{ inputs.project_name }}"

38 FOOTER: "${{ inputs.footer }}"

37 FOOTER: "${{ inputs.footer }}"

39 ROOT: "/github/workspace"

38 ROOT: "/github/workspace"

40 OLD: "${{ inputs.old }}"

39 OLD: "${{ inputs.old }}"

41 NEW: "${{ inputs.new }}"

40 NEW: "${{ inputs.new }}"

41+ SHA: "${{ inputs.sha }}"

42 pre-entrypoint: "/bin/pre"

43 entrypoint: "/bin/run"

44

comparest.cabal+3

@@ -190,6 +190,7 @@ executable comparest-github-action

190 , pandoc-types

191 , envy

192 , filepath

193+ , bytestring

193 ghc-options: -threaded

194 ghc-options: -threaded

194 -rtsopts

195 -rtsopts

195 -with-rtsopts=-N

196 -with-rtsopts=-N

@@ -197,6 +198,8 @@ executable comparest-github-action

197 Control.Monad.Freer.GitHub

198 Control.Monad.Freer.GitHub

198 CompaREST.GitHub.API

199 CompaREST.GitHub.API

199 CompaREST.GitHub.Action.Config

200 CompaREST.GitHub.Action.Config

201+ GitHub.Data.Checks

202+ GitHub.Endpoints.Checks

200

203

201test-suite comparest-tests

204test-suite comparest-tests

202 import: common-options

205 import: common-options

docs/Integration_guide.md+3−3

@@ -38,11 +38,11 @@ We can now run our action:

38 project_name: TEST

39```

40

41−This will create a comment on the pull request displaying the changes (if there are any) similar to this:

41+This will create a check on the pull request displaying the changes (if there are any) similar to this:

42

43−![](img/github-action-comment.png)

43+![](img/github-action-report.png)

44

45−Consecutive runs of the action will update the comment instead of creating new ones. This will prevent the pile-up of compaREST comments and save you from distracting notifications.

45+The check will show success when there are no breaking changes, and be neutral otherwise.

46

47## Integrating into something other than Github Actions

48

docs/img/github-action-comment.pngdeleted

Binary file not shown.

docs/img/github-action-report.pngnew file

Binary file not shown.

github-action/CompaREST/GitHub/API.hs+70−39

@@ -1,55 +1,86 @@

1module CompaREST.GitHub.API

2− ( mapComment,

2+ ( postStatus,

3− createOrUpdateComment,

3+ postStatusProcessing,

4 )

5where

6

7import CompaREST.GitHub.Action.Config

8−import Control.Monad

9import Control.Monad.Freer

8import Control.Monad.Freer

10import Control.Monad.Freer.GitHub

9import Control.Monad.Freer.GitHub

11import Control.Monad.Freer.Reader

10import Control.Monad.Freer.Reader

12−import Data.Foldable

11+import Control.Monad.IO.Class

12+import Data.Aeson

13+import qualified Data.ByteString.Lazy.Char8 as BSLC

14+import Data.OpenApi.Compare.Report

13import Data.Proxy

15import Data.Proxy

14import Data.Text (Text)

16import Data.Text (Text)

15−import qualified Data.Text as T

16−import qualified Data.Vector as V

17import GitHub

18−import qualified GitHub as GH

18+import GitHub.Data.Checks

19+import GitHub.Endpoints.Checks

19

20

21+postStatusProcessing ::

20−findComment :: Members '[GitHub, Reader Config] effs => Eff effs (Maybe GH.IssueComment)

22+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>

21−findComment = do

23+ Eff effs ()

24+postStatusProcessing = do

22 Config {..} <- ask

25 Config {..} <- ask

23− comments <- sendGitHub $ GH.commentsR repoOwner repoName issue GH.FetchAll

26+ printJSON $

24− htmlComment <- getHTMLComment

27+ sendGitHub $

25− let tryStripPrefix :: GH.IssueComment -> Maybe GH.IssueComment

28+ checkR

26− tryStripPrefix c@GH.IssueComment {issueCommentBody = (T.stripSuffix htmlComment -> Just b)} =

29+ repoOwner

27− Just $ c {GH.issueCommentBody = b}

30+ repoName

28− tryStripPrefix _ = Nothing

31+ Check

29− pure . (V.!? 0) $ V.mapMaybe tryStripPrefix comments

32+ { checkName = mkName Proxy $ "compaREST – " <> projectName

33+ , checkSha = sha

34+ , checkDetailsURL = Nothing

35+ , checkExternalId = Nothing

36+ , checkStatus = Just CheckInProgress

37+ , checkStartedAt = Nothing

38+ , checkConclusion = Nothing

39+ , checkCompletedAt = Nothing

40+ , checkOutput = Nothing

41+ , checkActions = Nothing

42+ }

30

43

44+postStatus ::

31−mapComment :: Members '[GitHub, Reader Config] effs => (Text -> Text) -> Eff effs ()

45+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>

32−mapComment f = do

46+ -- | 'Nothing' means that there were no changes at all

33− findComment

47+ Maybe (Text, ReportStatus) ->

34− >>= traverse_

48+ Eff effs ()

35− ( \comment -> do

49+postStatus x = do

36− Config {..} <- ask

50+ let (body, (title, conclusion)) = case x of

37− htmlComment <- getHTMLComment

51+ Just (b, s) -> (b,) $ case s of

38− sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) ((<> htmlComment) . f $ GH.issueCommentBody comment)

52+ BreakingChanges -> ("⚠️ Breaking changes found!", CheckNeutral)

39− pure ()

53+ NoBreakingChanges -> ("No breaking changes found ✨", CheckSuccess)

40− )

54+ OnlyUnsupportedChanges -> ("🤷 Couldn't determine compatibility", CheckNeutral)

41−

55+ Nothing -> ("", ("✅ The API did not change", CheckSuccess))

42−createOrUpdateComment :: Members '[GitHub, Reader Config] effs => Text -> Eff effs ()

43−createOrUpdateComment body' = do

44 Config {..} <- ask

56 Config {..} <- ask

45− htmlComment <- getHTMLComment

57+ printJSON $

46− let body = body' <> htmlComment

58+ sendGitHub $

47− void $

59+ checkR

48− findComment >>= \case

60+ repoOwner

49− Just comment -> sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) body

61+ repoName

50− Nothing -> sendGitHub $ createCommentR repoOwner repoName issue body

62+ Check

63+ { checkName = mkName Proxy $ "compaREST – " <> projectName

64+ , checkSha = sha

65+ , checkDetailsURL = Nothing

66+ , checkExternalId = Nothing

67+ , checkStatus = Just CheckCompleted

68+ , checkStartedAt = Nothing

69+ , checkConclusion = Just conclusion

70+ , checkCompletedAt = Nothing

71+ , checkOutput =

72+ Just $

73+ CheckOutput

74+ { checkTitle = title

75+ , checkSummary = body

76+ , checkText = Nothing

77+ , checkAnnotations = Nothing

78+ , checkImages = Nothing

79+ }

80+ , checkActions = Nothing

81+ }

51

82

52−getHTMLComment :: Member (Reader Config) effs => Eff effs Text

83+printJSON :: MonadIO (Eff effs) => Eff effs Value -> Eff effs ()

53−getHTMLComment = do

84+printJSON m = do

54− name <- asks projectName

85+ x <- m

55− pure $ "\n\n"

86+ liftIO . BSLC.putStrLn $ encode x

github-action/CompaREST/GitHub/Action/Config.hs+3−3

@@ -14,10 +14,10 @@ data Config = Config

14 { githubToken :: GH.Auth

15 , repoOwner :: GH.Name GH.Owner

16 , repoName :: GH.Name GH.Repo

17− , issue :: GH.IssueNumber

18 , projectName :: Text

17 , projectName :: Text

19 , footerText :: Text

18 , footerText :: Text

20 , root :: FilePath

19 , root :: FilePath

20+ , sha :: GH.Name GH.Commit

21 }

22

23instance FromEnv Config where

@@ -27,17 +27,17 @@ instance FromEnv Config where

27 T.split (== '/') <$> env "REPO" >>= \case

28 [owner, name] -> pure (owner, name)

29 _ -> fail "malformed repo"

30− issue <- GH.IssueNumber <$> env "PR_NUMBER"

31 projectName <- env "PROJECT_NAME"

30 projectName <- env "PROJECT_NAME"

32 footerText <- env "FOOTER"

31 footerText <- env "FOOTER"

33 root <- envMaybe "ROOT" .!= "."

32 root <- envMaybe "ROOT" .!= "."

33+ sha <- env "SHA"

34 pure $

35 Config

36 { githubToken = token

37 , repoOwner = GH.mkName Proxy owner

38 , repoName = GH.mkName Proxy repo

39− , issue = issue

40 , projectName = projectName

39 , projectName = projectName

41 , footerText = footerText

40 , footerText = footerText

42 , root = root

41 , root = root

42+ , sha = GH.mkName Proxy sha

43 }

github-action/GitHub/Data/Checks.hsnew file+173

@@ -0,0 +1,173 @@

1+module GitHub.Data.Checks

2+ ( Check (..),

3+ CheckStatus (..),

4+ CheckConclusion (..),

5+ CheckOutput (..),

6+ CheckAnnotation (..),

7+ CheckAnnotationLevel (..),

8+ CheckImage (..),

9+ CheckAction (..),

10+ )

11+where

12+

13+import Data.Aeson

14+import Data.Aeson.Types

15+import Data.Text (Text)

16+import Data.Vector (Vector)

17+import GHC.Generics (Generic)

18+import GitHub

19+import GitHub.Internal.Prelude (UTCTime)

20+

21+data Check = Check

22+ { checkName :: !(Name Check)

23+ , checkSha :: !(Name Commit)

24+ , checkDetailsURL :: !(Maybe URL)

25+ , checkExternalId :: !(Maybe (Id Check))

26+ , checkStatus :: !(Maybe CheckStatus)

27+ , checkStartedAt :: !(Maybe UTCTime)

28+ , checkConclusion :: !(Maybe CheckConclusion)

29+ , checkCompletedAt :: !(Maybe UTCTime)

30+ , checkOutput :: !(Maybe CheckOutput)

31+ , checkActions :: !(Maybe (Vector CheckAction))

32+ }

33+ deriving stock (Show, Eq, Ord, Generic)

34+

35+instance ToJSON Check where

36+ toJSON (Check n sha durl eid s sa c ca o a) =

37+ object'

38+ [ "name" .= n

39+ , "head_sha" .= sha

40+ , "details_url" .= durl

41+ , "external_id" .= eid

42+ , "status" .= s

43+ , "started_at" .= sa

44+ , "conclusion" .= c

45+ , "completed_at" .= ca

46+ , "output" .= o

47+ , "actions" .= a

48+ ]

49+

50+data CheckStatus

51+ = CheckQueued

52+ | CheckInProgress

53+ | CheckCompleted

54+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

55+

56+instance ToJSON CheckStatus where

57+ toJSON CheckQueued = String "queued"

58+ toJSON CheckInProgress = String "in_progress"

59+ toJSON CheckCompleted = String "completed"

60+

61+data CheckConclusion

62+ = CheckActionRequired

63+ | CheckCancelled

64+ | CheckFailure

65+ | CheckNeutral

66+ | CheckSuccess

67+ | CheckSkipped

68+ | CheckStale

69+ | CheckTimedOut

70+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

71+

72+instance ToJSON CheckConclusion where

73+ toJSON CheckActionRequired = String "action_required"

74+ toJSON CheckCancelled = String "cancelled"

75+ toJSON CheckFailure = String "failure"

76+ toJSON CheckNeutral = String "neutral"

77+ toJSON CheckSuccess = String "success"

78+ toJSON CheckSkipped = String "skipped"

79+ toJSON CheckStale = String "stale"

80+ toJSON CheckTimedOut = String "timed_out"

81+

82+data CheckOutput = CheckOutput

83+ { checkTitle :: !Text

84+ , checkSummary :: !Text

85+ , checkText :: !(Maybe Text)

86+ , checkAnnotations :: !(Maybe (Vector CheckAnnotation))

87+ , checkImages :: !(Maybe (Vector CheckImage))

88+ }

89+ deriving stock (Show, Eq, Ord, Generic)

90+

91+instance ToJSON CheckOutput where

92+ toJSON (CheckOutput t s txt a i) =

93+ object'

94+ [ "title" .= t

95+ , "summary" .= s

96+ , "text" .= txt

97+ , "annotations" .= a

98+ , "images" .= i

99+ ]

100+

101+data CheckAnnotation = CheckAnnotation

102+ { checkPath :: !Text

103+ , checkStartLine :: !Int

104+ , checkEndLine :: !Int

105+ , checkStartColumn :: !(Maybe Int)

106+ , checkEndColumn :: !(Maybe Int)

107+ , checkAnnotationLevel :: !CheckAnnotationLevel

108+ , checkMessage :: !Text

109+ , checkTitle :: !(Maybe Text)

110+ , checkRawDetails :: !(Maybe Text)

111+ }

112+ deriving stock (Show, Eq, Ord, Generic)

113+

114+instance ToJSON CheckAnnotation where

115+ toJSON (CheckAnnotation p sl el sc ec al m t rd) =

116+ object'

117+ [ "path" .= p

118+ , "start_line" .= sl

119+ , "end_line" .= el

120+ , "start_column" .= sc

121+ , "end_column" .= ec

122+ , "annotation_level" .= al

123+ , "message" .= m

124+ , "title" .= t

125+ , "raw_details" .= rd

126+ ]

127+

128+data CheckAnnotationLevel

129+ = NoticeAnnotation

130+ | WarningAnnotation

131+ | FailureAnnotation

132+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

133+

134+instance ToJSON CheckAnnotationLevel where

135+ toJSON NoticeAnnotation = String "notice"

136+ toJSON WarningAnnotation = String "warning"

137+ toJSON FailureAnnotation = String "failure"

138+

139+data CheckImage = CheckImage

140+ { checkImageAlt :: !Text

141+ , checkImageURL :: !URL

142+ , checkImageCaption :: !(Maybe Text)

143+ }

144+ deriving stock (Show, Eq, Ord, Generic)

145+

146+instance ToJSON CheckImage where

147+ toJSON (CheckImage a url c) =

148+ object'

149+ [ "alt" .= a

150+ , "image_url" .= url

151+ , "caption" .= c

152+ ]

153+

154+data CheckAction = CheckAction

155+ { checkActionLabel :: !Text

156+ , checkActionDescription :: !Text

157+ , checkActionIdentifier :: !Text

158+ }

159+ deriving stock (Show, Eq, Ord, Generic)

160+

161+instance ToJSON CheckAction where

162+ toJSON (CheckAction l d i) =

163+ object'

164+ [ "label" .= l

165+ , "description" .= d

166+ , "identifier" .= i

167+ ]

168+

169+object' :: [Pair] -> Value

170+object' = object . filter notNull

171+ where

172+ notNull (_, Null) = False

173+ notNull (_, _) = True

github-action/GitHub/Endpoints/Checks.hsnew file+12

@@ -0,0 +1,12 @@

1+module GitHub.Endpoints.Checks

2+ ( checkR,

3+ )

4+where

5+

6+import Data.Aeson

7+import GitHub

8+import GitHub.Data.Checks

9+

10+checkR :: Name Owner -> Name Repo -> Check -> Request 'RW Value

11+checkR user repo =

12+ command Post ["repos", toPathPart user, toPathPart repo, "check-runs"] . encode

github-action/Main.hs+7−28

@@ -37,10 +37,7 @@ runner cfg =

37 . runGitHub (githubToken cfg)

38

39runPre :: Config -> IO ()

40−runPre cfg =

40+runPre cfg = runner cfg postStatusProcessing

41− runner cfg $

42− mapComment

43− (markdown (header 4 "⏳ Report might not be accurate. Attempting to update." <> horizontalRule) <>)

44

41

45runRun :: Config -> FilePath -> FilePath -> IO ()

42runRun :: Config -> FilePath -> FilePath -> IO ()

46runRun cfg old' new' = runner cfg $ do

43runRun cfg old' new' = runner cfg $ do

@@ -53,31 +50,13 @@ runRun cfg old' new' = runner cfg $ do

53 }

50 }

54 (report, status) = runReport reportConfig (old, new)

51 (report, status) = runReport reportConfig (old, new)

55

52

56− summaryDetail s d =

53+ body = markdown report <> "\n\n" <> footerText cfg

57− rawHtml "<details>"

58− <> rawHtml "<summary>"

59− <> s

60− <> rawHtml "</summary>"

61− <> d

62− <> rawHtml "</details>"

63− where

64− rawHtml = rawBlock "html"

65

54

66− message =

55+ result =

67− header 3 (text $ "⛄ compaREST – " <> projectName cfg)

68− <> if old == new

56+ if old == new

69− then header 1 "✅ The API did not change"

57+ then Nothing

70− else

71− header

72− 1

73− ( case status of

58+ else Just (body, status)

74− BreakingChanges -> "⚠️ Breaking changes found!"

59+ postStatus result

75− NoBreakingChanges -> "No breaking changes found ✨"

76− OnlyUnsupportedChanges -> "🤷 Couldn't determine compatibility"

77− )

78− <> summaryDetail (plain "ℹ️ Details") report

79− messageBody = markdown message <> "\n\n" <> footerText cfg

80− createOrUpdateComment messageBody

81

60

82markdown :: Blocks -> Text

61markdown :: Blocks -> Text

83markdown =

62markdown =

src/Data/OpenApi/Compare/References.hs−1

@@ -13,7 +13,6 @@ import Data.Maybe

13import Data.OpenApi

14import Data.OpenApi.Compare.Orphans ()

15import Data.OpenApi.Compare.Subtree

16−import Data.Typeable

17

16

18instance Typeable a => Steppable (Referenced a) a where

17instance Typeable a => Steppable (Referenced a) a where

19 data Step (Referenced a) a = InlineStep

18 data Step (Referenced a) a = InlineStep

src/Data/OpenApi/Compare/Validate/PathFragment.hs−1

@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Subtree

12import Data.OpenApi.Compare.Validate.Param

13import Data.Text (Text)

14import qualified Data.Text as T

15−import Data.Typeable

16

15

17-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

16-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

18-- #23

17-- #23