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

action.yaml

@@ -10,10 +10,6 @@ inputs:
     description: The owner of the repo in which to post the comment.
     default: "${{ github.repository }}"
     required: false
-  pull_request:
-    description: The pull request in which to post the comment.
-    default: "${{ github.event.pull_request.number }}"
-    required: false
   project_name:
     description: The name of the project to which the API pertains.
     required: true
@@ -27,18 +23,22 @@ inputs:
   new:
     description: The path to new specification of the API.
     required: true
+  sha:
+    description: The sha of the commit to post the check for.
+    required: false
+    default: "${{ github.event.pull_request.head.sha }}"
 runs:
   using: "docker"
   image: "typeable/comparest-github-action:latest"
   env:
     GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"
     REPO: "${{ inputs.repo }}"
-    PR_NUMBER: "${{ inputs.pull_request }}"
     PROJECT_NAME: "${{ inputs.project_name }}"
     FOOTER: "${{ inputs.footer }}"
     ROOT: "/github/workspace"
     OLD: "${{ inputs.old }}"
     NEW: "${{ inputs.new }}"
+    SHA: "${{ inputs.sha }}"
   pre-entrypoint: "/bin/pre"
   entrypoint: "/bin/run"
 

comparest.cabal

@@ -190,6 +190,7 @@ executable comparest-github-action
     , pandoc-types
     , envy
     , filepath
+    , bytestring
   ghc-options:         -threaded
                        -rtsopts
                        -with-rtsopts=-N
@@ -197,6 +198,8 @@ executable comparest-github-action
     Control.Monad.Freer.GitHub
     CompaREST.GitHub.API
     CompaREST.GitHub.Action.Config
+    GitHub.Data.Checks
+    GitHub.Endpoints.Checks
 
 test-suite comparest-tests
   import:              common-options

docs/Integration_guide.md

@@ -38,11 +38,11 @@ We can now run our action:
       project_name: TEST
 ```
 
-This will create a comment on the pull request displaying the changes (if there are any) similar to this:
+This will create a check on the pull request displaying the changes (if there are any) similar to this:
 
-![](img/github-action-comment.png)
+![](img/github-action-report.png)
 
-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.
+The check will show success when there are no breaking changes, and be neutral otherwise.
 
 ## Integrating into something other than Github Actions
 

github-action/CompaREST/GitHub/API.hs

@@ -1,55 +1,86 @@
 module CompaREST.GitHub.API
-  ( mapComment,
-    createOrUpdateComment,
+  ( postStatus,
+    postStatusProcessing,
   )
 where
 
 import CompaREST.GitHub.Action.Config
-import Control.Monad
 import Control.Monad.Freer
 import Control.Monad.Freer.GitHub
 import Control.Monad.Freer.Reader
-import Data.Foldable
+import Control.Monad.IO.Class
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as BSLC
+import Data.OpenApi.Compare.Report
 import Data.Proxy
 import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Vector as V
 import GitHub
-import qualified GitHub as GH
+import GitHub.Data.Checks
+import GitHub.Endpoints.Checks
 
-findComment :: Members '[GitHub, Reader Config] effs => Eff effs (Maybe GH.IssueComment)
-findComment = do
+postStatusProcessing ::
+  (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>
+  Eff effs ()
+postStatusProcessing = do
   Config {..} <- ask
-  comments <- sendGitHub $ GH.commentsR repoOwner repoName issue GH.FetchAll
-  htmlComment <- getHTMLComment
-  let tryStripPrefix :: GH.IssueComment -> Maybe GH.IssueComment
-      tryStripPrefix c@GH.IssueComment {issueCommentBody = (T.stripSuffix htmlComment -> Just b)} =
-        Just $ c {GH.issueCommentBody = b}
-      tryStripPrefix _ = Nothing
-  pure . (V.!? 0) $ V.mapMaybe tryStripPrefix comments
+  printJSON $
+    sendGitHub $
+      checkR
+        repoOwner
+        repoName
+        Check
+          { checkName = mkName Proxy $ "compaREST – " <> projectName
+          , checkSha = sha
+          , checkDetailsURL = Nothing
+          , checkExternalId = Nothing
+          , checkStatus = Just CheckInProgress
+          , checkStartedAt = Nothing
+          , checkConclusion = Nothing
+          , checkCompletedAt = Nothing
+          , checkOutput = Nothing
+          , checkActions = Nothing
+          }
 
-mapComment :: Members '[GitHub, Reader Config] effs => (Text -> Text) -> Eff effs ()
-mapComment f = do
-  findComment
-    >>= traverse_
-      ( \comment -> do
-          Config {..} <- ask
-          htmlComment <- getHTMLComment
-          sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) ((<> htmlComment) . f $ GH.issueCommentBody comment)
-          pure ()
-      )
-
-createOrUpdateComment :: Members '[GitHub, Reader Config] effs => Text -> Eff effs ()
-createOrUpdateComment body' = do
+postStatus ::
+  (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>
+  -- | 'Nothing' means that there were no changes at all
+  Maybe (Text, ReportStatus) ->
+  Eff effs ()
+postStatus x = do
+  let (body, (title, conclusion)) = case x of
+        Just (b, s) -> (b,) $ case s of
+          BreakingChanges -> ("⚠️ Breaking changes found!", CheckNeutral)
+          NoBreakingChanges -> ("No breaking changes found ✨", CheckSuccess)
+          OnlyUnsupportedChanges -> ("🤷 Couldn't determine compatibility", CheckNeutral)
+        Nothing -> ("", ("✅ The API did not change", CheckSuccess))
   Config {..} <- ask
-  htmlComment <- getHTMLComment
-  let body = body' <> htmlComment
-  void $
-    findComment >>= \case
-      Just comment -> sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) body
-      Nothing -> sendGitHub $ createCommentR repoOwner repoName issue body
+  printJSON $
+    sendGitHub $
+      checkR
+        repoOwner
+        repoName
+        Check
+          { checkName = mkName Proxy $ "compaREST – " <> projectName
+          , checkSha = sha
+          , checkDetailsURL = Nothing
+          , checkExternalId = Nothing
+          , checkStatus = Just CheckCompleted
+          , checkStartedAt = Nothing
+          , checkConclusion = Just conclusion
+          , checkCompletedAt = Nothing
+          , checkOutput =
+              Just $
+                CheckOutput
+                  { checkTitle = title
+                  , checkSummary = body
+                  , checkText = Nothing
+                  , checkAnnotations = Nothing
+                  , checkImages = Nothing
+                  }
+          , checkActions = Nothing
+          }
 
-getHTMLComment :: Member (Reader Config) effs => Eff effs Text
-getHTMLComment = do
-  name <- asks projectName
-  pure $ "\n\n<!-- compaREST comment – " <> name <> " -->"
+printJSON :: MonadIO (Eff effs) => Eff effs Value -> Eff effs ()
+printJSON m = do
+  x <- m
+  liftIO . BSLC.putStrLn $ encode x

github-action/CompaREST/GitHub/Action/Config.hs

@@ -14,10 +14,10 @@ data Config = Config
   { githubToken :: GH.Auth
   , repoOwner :: GH.Name GH.Owner
   , repoName :: GH.Name GH.Repo
-  , issue :: GH.IssueNumber
   , projectName :: Text
   , footerText :: Text
   , root :: FilePath
+  , sha :: GH.Name GH.Commit
   }
 
 instance FromEnv Config where
@@ -27,17 +27,17 @@ instance FromEnv Config where
       T.split (== '/') <$> env "REPO" >>= \case
         [owner, name] -> pure (owner, name)
         _ -> fail "malformed repo"
-    issue <- GH.IssueNumber <$> env "PR_NUMBER"
     projectName <- env "PROJECT_NAME"
     footerText <- env "FOOTER"
     root <- envMaybe "ROOT" .!= "."
+    sha <- env "SHA"
     pure $
       Config
         { githubToken = token
         , repoOwner = GH.mkName Proxy owner
         , repoName = GH.mkName Proxy repo
-        , issue = issue
         , projectName = projectName
         , footerText = footerText
         , root = root
+        , sha = GH.mkName Proxy sha
         }

github-action/GitHub/Data/Checks.hs

@@ -0,0 +1,173 @@
+module GitHub.Data.Checks
+  ( Check (..),
+    CheckStatus (..),
+    CheckConclusion (..),
+    CheckOutput (..),
+    CheckAnnotation (..),
+    CheckAnnotationLevel (..),
+    CheckImage (..),
+    CheckAction (..),
+  )
+where
+
+import Data.Aeson
+import Data.Aeson.Types
+import Data.Text (Text)
+import Data.Vector (Vector)
+import GHC.Generics (Generic)
+import GitHub
+import GitHub.Internal.Prelude (UTCTime)
+
+data Check = Check
+  { checkName :: !(Name Check)
+  , checkSha :: !(Name Commit)
+  , checkDetailsURL :: !(Maybe URL)
+  , checkExternalId :: !(Maybe (Id Check))
+  , checkStatus :: !(Maybe CheckStatus)
+  , checkStartedAt :: !(Maybe UTCTime)
+  , checkConclusion :: !(Maybe CheckConclusion)
+  , checkCompletedAt :: !(Maybe UTCTime)
+  , checkOutput :: !(Maybe CheckOutput)
+  , checkActions :: !(Maybe (Vector CheckAction))
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON Check where
+  toJSON (Check n sha durl eid s sa c ca o a) =
+    object'
+      [ "name" .= n
+      , "head_sha" .= sha
+      , "details_url" .= durl
+      , "external_id" .= eid
+      , "status" .= s
+      , "started_at" .= sa
+      , "conclusion" .= c
+      , "completed_at" .= ca
+      , "output" .= o
+      , "actions" .= a
+      ]
+
+data CheckStatus
+  = CheckQueued
+  | CheckInProgress
+  | CheckCompleted
+  deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)
+
+instance ToJSON CheckStatus where
+  toJSON CheckQueued = String "queued"
+  toJSON CheckInProgress = String "in_progress"
+  toJSON CheckCompleted = String "completed"
+
+data CheckConclusion
+  = CheckActionRequired
+  | CheckCancelled
+  | CheckFailure
+  | CheckNeutral
+  | CheckSuccess
+  | CheckSkipped
+  | CheckStale
+  | CheckTimedOut
+  deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)
+
+instance ToJSON CheckConclusion where
+  toJSON CheckActionRequired = String "action_required"
+  toJSON CheckCancelled = String "cancelled"
+  toJSON CheckFailure = String "failure"
+  toJSON CheckNeutral = String "neutral"
+  toJSON CheckSuccess = String "success"
+  toJSON CheckSkipped = String "skipped"
+  toJSON CheckStale = String "stale"
+  toJSON CheckTimedOut = String "timed_out"
+
+data CheckOutput = CheckOutput
+  { checkTitle :: !Text
+  , checkSummary :: !Text
+  , checkText :: !(Maybe Text)
+  , checkAnnotations :: !(Maybe (Vector CheckAnnotation))
+  , checkImages :: !(Maybe (Vector CheckImage))
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckOutput where
+  toJSON (CheckOutput t s txt a i) =
+    object'
+      [ "title" .= t
+      , "summary" .= s
+      , "text" .= txt
+      , "annotations" .= a
+      , "images" .= i
+      ]
+
+data CheckAnnotation = CheckAnnotation
+  { checkPath :: !Text
+  , checkStartLine :: !Int
+  , checkEndLine :: !Int
+  , checkStartColumn :: !(Maybe Int)
+  , checkEndColumn :: !(Maybe Int)
+  , checkAnnotationLevel :: !CheckAnnotationLevel
+  , checkMessage :: !Text
+  , checkTitle :: !(Maybe Text)
+  , checkRawDetails :: !(Maybe Text)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckAnnotation where
+  toJSON (CheckAnnotation p sl el sc ec al m t rd) =
+    object'
+      [ "path" .= p
+      , "start_line" .= sl
+      , "end_line" .= el
+      , "start_column" .= sc
+      , "end_column" .= ec
+      , "annotation_level" .= al
+      , "message" .= m
+      , "title" .= t
+      , "raw_details" .= rd
+      ]
+
+data CheckAnnotationLevel
+  = NoticeAnnotation
+  | WarningAnnotation
+  | FailureAnnotation
+  deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)
+
+instance ToJSON CheckAnnotationLevel where
+  toJSON NoticeAnnotation = String "notice"
+  toJSON WarningAnnotation = String "warning"
+  toJSON FailureAnnotation = String "failure"
+
+data CheckImage = CheckImage
+  { checkImageAlt :: !Text
+  , checkImageURL :: !URL
+  , checkImageCaption :: !(Maybe Text)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckImage where
+  toJSON (CheckImage a url c) =
+    object'
+      [ "alt" .= a
+      , "image_url" .= url
+      , "caption" .= c
+      ]
+
+data CheckAction = CheckAction
+  { checkActionLabel :: !Text
+  , checkActionDescription :: !Text
+  , checkActionIdentifier :: !Text
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+
+instance ToJSON CheckAction where
+  toJSON (CheckAction l d i) =
+    object'
+      [ "label" .= l
+      , "description" .= d
+      , "identifier" .= i
+      ]
+
+object' :: [Pair] -> Value
+object' = object . filter notNull
+  where
+    notNull (_, Null) = False
+    notNull (_, _) = True

github-action/GitHub/Endpoints/Checks.hs

@@ -0,0 +1,12 @@
+module GitHub.Endpoints.Checks
+  ( checkR,
+  )
+where
+
+import Data.Aeson
+import GitHub
+import GitHub.Data.Checks
+
+checkR :: Name Owner -> Name Repo -> Check -> Request 'RW Value
+checkR user repo =
+  command Post ["repos", toPathPart user, toPathPart repo, "check-runs"] . encode

github-action/Main.hs

@@ -37,10 +37,7 @@ runner cfg =
     . runGitHub (githubToken cfg)
 
 runPre :: Config -> IO ()
-runPre cfg =
-  runner cfg $
-    mapComment
-      (markdown (header 4 "⏳ Report might not be accurate. Attempting to update." <> horizontalRule) <>)
+runPre cfg = runner cfg postStatusProcessing
 
 runRun :: Config -> FilePath -> FilePath -> IO ()
 runRun cfg old' new' = runner cfg $ do
@@ -53,31 +50,13 @@ runRun cfg old' new' = runner cfg $ do
           }
       (report, status) = runReport reportConfig (old, new)
 
-      summaryDetail s d =
-        rawHtml "<details>"
-          <> rawHtml "<summary>"
-          <> s
-          <> rawHtml "</summary>"
-          <> d
-          <> rawHtml "</details>"
-        where
-          rawHtml = rawBlock "html"
+      body = markdown report <> "\n\n" <> footerText cfg
 
-      message =
-        header 3 (text $ "⛄ compaREST – " <> projectName cfg)
-          <> if old == new
-            then header 1 "✅ The API did not change"
-            else
-              header
-                1
-                ( case status of
-                    BreakingChanges -> "⚠️ Breaking changes found!"
-                    NoBreakingChanges -> "No breaking changes found ✨"
-                    OnlyUnsupportedChanges -> "🤷 Couldn't determine compatibility"
-                )
-                <> summaryDetail (plain "ℹ️ Details") report
-      messageBody = markdown message <> "\n\n" <> footerText cfg
-  createOrUpdateComment messageBody
+      result =
+        if old == new
+          then Nothing
+          else Just (body, status)
+  postStatus result
 
 markdown :: Blocks -> Text
 markdown =

src/Data/OpenApi/Compare/References.hs

@@ -13,7 +13,6 @@ import Data.Maybe
 import Data.OpenApi
 import Data.OpenApi.Compare.Orphans ()
 import Data.OpenApi.Compare.Subtree
-import Data.Typeable
 
 instance Typeable a => Steppable (Referenced a) a where
   data Step (Referenced a) a = InlineStep

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

@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Subtree
 import Data.OpenApi.Compare.Validate.Param
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Typeable
 
 -- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
 -- #23