git.iko.soy/typeable/compaREST
on master help sign in
Use checks instead of posting comments (#122)

* Fixed warnings * wip * wip * wip * sha * wip * Added project name * Made check not fail * Removed Pull Request * Removed testing things * Updated docs

commit6d8a67339c0e7b20a6c721eec7a2db093a0311fc authoriko <ilyakooo0@gmail.com> dateWed 8 Sep 2021, 18:07 (5 years ago) parenta1ea91f
12 files changed+276−80
action.yaml+5−5 comparest.cabal+3 docs/Integration_guide.md+3−3 docs/img/github-action-comment.png docs/img/github-action-report.png github-action/CompaREST/GitHub/API.hs+70−39 github-action/CompaREST/GitHub/Action/Config.hs+3−3 github-action/GitHub/Data/Checks.hs+173 github-action/GitHub/Endpoints/Checks.hs+12 github-action/Main.hs+7−28 src/Data/OpenApi/Compare/References.hs−1 src/Data/OpenApi/Compare/Validate/PathFragment.hs−1
action.yaml+5−5
@@ -10,10 +10,6 @@ inputs:
1010 description: The owner of the repo in which to post the comment.
1111 default: "${{ github.repository }}"
1212 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
1713 project_name:
1814 description: The name of the project to which the API pertains.
1915 required: true
@@ -27,18 +23,22 @@ inputs:
2723 new:
2824 description: The path to new specification of the API.
2925 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 }}"
3030runs:
3131 using: "docker"
3232 image: "typeable/comparest-github-action:latest"
3333 env:
3434 GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"
3535 REPO: "${{ inputs.repo }}"
36− PR_NUMBER: "${{ inputs.pull_request }}"
3736 PROJECT_NAME: "${{ inputs.project_name }}"
3837 FOOTER: "${{ inputs.footer }}"
3938 ROOT: "/github/workspace"
4039 OLD: "${{ inputs.old }}"
4140 NEW: "${{ inputs.new }}"
41+ SHA: "${{ inputs.sha }}"
4242 pre-entrypoint: "/bin/pre"
4343 entrypoint: "/bin/run"
4444
comparest.cabal+3
@@ -190,6 +190,7 @@ executable comparest-github-action
190190 , pandoc-types
191191 , envy
192192 , filepath
193+ , bytestring
193194 ghc-options: -threaded
194195 -rtsopts
195196 -with-rtsopts=-N
@@ -197,6 +198,8 @@ executable comparest-github-action
197198 Control.Monad.Freer.GitHub
198199 CompaREST.GitHub.API
199200 CompaREST.GitHub.Action.Config
201+ GitHub.Data.Checks
202+ GitHub.Endpoints.Checks
200203
201204test-suite comparest-tests
202205 import: common-options
docs/Integration_guide.md+3−3
@@ -38,11 +38,11 @@ We can now run our action:
3838 project_name: TEST
3939```
4040
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:
4242
43−![](img/github-action-comment.png)
43+![](img/github-action-report.png)
4444
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.
4646
4747## Integrating into something other than Github Actions
4848
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 @@
11module CompaREST.GitHub.API
2− ( mapComment,
3− createOrUpdateComment,
2+ ( postStatus,
3+ postStatusProcessing,
44 )
55where
66
77import CompaREST.GitHub.Action.Config
8−import Control.Monad
98import Control.Monad.Freer
109import Control.Monad.Freer.GitHub
1110import 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
1315import Data.Proxy
1416import Data.Text (Text)
15−import qualified Data.Text as T
16−import qualified Data.Vector as V
1717import GitHub
18−import qualified GitHub as GH
18+import GitHub.Data.Checks
19+import GitHub.Endpoints.Checks
1920
20−findComment :: Members '[GitHub, Reader Config] effs => Eff effs (Maybe GH.IssueComment)
21−findComment = do
21+postStatusProcessing ::
22+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>
23+ Eff effs ()
24+postStatusProcessing = do
2225 Config {..} <- ask
23− comments <- sendGitHub $ GH.commentsR repoOwner repoName issue GH.FetchAll
24− htmlComment <- getHTMLComment
25− let tryStripPrefix :: GH.IssueComment -> Maybe GH.IssueComment
26− tryStripPrefix c@GH.IssueComment {issueCommentBody = (T.stripSuffix htmlComment -> Just b)} =
27− Just $ c {GH.issueCommentBody = b}
28− tryStripPrefix _ = Nothing
29− pure . (V.!? 0) $ V.mapMaybe tryStripPrefix comments
26+ printJSON $
27+ sendGitHub $
28+ checkR
29+ repoOwner
30+ repoName
31+ Check
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+ }
3043
31−mapComment :: Members '[GitHub, Reader Config] effs => (Text -> Text) -> Eff effs ()
32−mapComment f = do
33− findComment
34− >>= traverse_
35− ( \comment -> do
36− Config {..} <- ask
37− htmlComment <- getHTMLComment
38− sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) ((<> htmlComment) . f $ GH.issueCommentBody comment)
39− pure ()
40− )
41−
42−createOrUpdateComment :: Members '[GitHub, Reader Config] effs => Text -> Eff effs ()
43−createOrUpdateComment body' = do
44+postStatus ::
45+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>
46+ -- | 'Nothing' means that there were no changes at all
47+ Maybe (Text, ReportStatus) ->
48+ Eff effs ()
49+postStatus x = do
50+ let (body, (title, conclusion)) = case x of
51+ Just (b, s) -> (b,) $ case s of
52+ BreakingChanges -> ("⚠️ Breaking changes found!", CheckNeutral)
53+ NoBreakingChanges -> ("No breaking changes found ✨", CheckSuccess)
54+ OnlyUnsupportedChanges -> ("🤷 Couldn't determine compatibility", CheckNeutral)
55+ Nothing -> ("", ("✅ The API did not change", CheckSuccess))
4456 Config {..} <- ask
45− htmlComment <- getHTMLComment
46− let body = body' <> htmlComment
47− void $
48− findComment >>= \case
49− Just comment -> sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) body
50− Nothing -> sendGitHub $ createCommentR repoOwner repoName issue body
57+ printJSON $
58+ sendGitHub $
59+ checkR
60+ repoOwner
61+ repoName
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+ }
5182
52−getHTMLComment :: Member (Reader Config) effs => Eff effs Text
53−getHTMLComment = do
54− name <- asks projectName
55− pure $ "\n\n<!-- compaREST comment – " <> name <> " -->"
83+printJSON :: MonadIO (Eff effs) => Eff effs Value -> Eff effs ()
84+printJSON m = do
85+ x <- m
86+ liftIO . BSLC.putStrLn $ encode x
github-action/CompaREST/GitHub/Action/Config.hs+3−3
@@ -14,10 +14,10 @@ data Config = Config
1414 { githubToken :: GH.Auth
1515 , repoOwner :: GH.Name GH.Owner
1616 , repoName :: GH.Name GH.Repo
17− , issue :: GH.IssueNumber
1817 , projectName :: Text
1918 , footerText :: Text
2019 , root :: FilePath
20+ , sha :: GH.Name GH.Commit
2121 }
2222
2323instance FromEnv Config where
@@ -27,17 +27,17 @@ instance FromEnv Config where
2727 T.split (== '/') <$> env "REPO" >>= \case
2828 [owner, name] -> pure (owner, name)
2929 _ -> fail "malformed repo"
30− issue <- GH.IssueNumber <$> env "PR_NUMBER"
3130 projectName <- env "PROJECT_NAME"
3231 footerText <- env "FOOTER"
3332 root <- envMaybe "ROOT" .!= "."
33+ sha <- env "SHA"
3434 pure $
3535 Config
3636 { githubToken = token
3737 , repoOwner = GH.mkName Proxy owner
3838 , repoName = GH.mkName Proxy repo
39− , issue = issue
4039 , projectName = projectName
4140 , footerText = footerText
4241 , root = root
42+ , sha = GH.mkName Proxy sha
4343 }
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 =
3737 . runGitHub (githubToken cfg)
3838
3939runPre :: Config -> IO ()
40−runPre cfg =
41− runner cfg $
42− mapComment
43− (markdown (header 4 "⏳ Report might not be accurate. Attempting to update." <> horizontalRule) <>)
40+runPre cfg = runner cfg postStatusProcessing
4441
4542runRun :: Config -> FilePath -> FilePath -> IO ()
4643runRun cfg old' new' = runner cfg $ do
@@ -53,31 +50,13 @@ runRun cfg old' new' = runner cfg $ do
5350 }
5451 (report, status) = runReport reportConfig (old, new)
5552
56− summaryDetail s d =
57− rawHtml "<details>"
58− <> rawHtml "<summary>"
59− <> s
60− <> rawHtml "</summary>"
61− <> d
62− <> rawHtml "</details>"
63− where
64− rawHtml = rawBlock "html"
53+ body = markdown report <> "\n\n" <> footerText cfg
6554
66− message =
67− header 3 (text $ "⛄ compaREST – " <> projectName cfg)
68− <> if old == new
69− then header 1 "✅ The API did not change"
70− else
71− header
72− 1
73− ( case status of
74− BreakingChanges -> "⚠️ Breaking changes found!"
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
55+ result =
56+ if old == new
57+ then Nothing
58+ else Just (body, status)
59+ postStatus result
8160
8261markdown :: Blocks -> Text
8362markdown =
src/Data/OpenApi/Compare/References.hs−1
@@ -13,7 +13,6 @@ import Data.Maybe
1313import Data.OpenApi
1414import Data.OpenApi.Compare.Orphans ()
1515import Data.OpenApi.Compare.Subtree
16−import Data.Typeable
1716
1817instance Typeable a => Steppable (Referenced a) a where
1918 data Step (Referenced a) a = InlineStep
src/Data/OpenApi/Compare/Validate/PathFragment.hs−1
@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Subtree
1212import Data.OpenApi.Compare.Validate.Param
1313import Data.Text (Text)
1414import qualified Data.Text as T
15−import Data.Typeable
1615
1716-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
1817-- #23