diff --git a/.github/workflows/ormolu.yaml b/.github/workflows/ormolu.yaml index 80e31c0..fc2c756 100644 --- a/.github/workflows/ormolu.yaml +++ b/.github/workflows/ormolu.yaml @@ -14,6 +14,3 @@ jobs: steps: - uses: actions/checkout@11bd71901bbe5b1630ceea73d27597364c9af683 # v4.2.2 - uses: haskell-actions/run-ormolu@c5eec49879ee294be01c787bcbf7b5a373a37060 # v17 - with: - respect-cabal-files: false - extra-args: '-o -XGHC2021 -o -XOverloadedStrings' diff --git a/.gitignore b/.gitignore index 4b4b7eb..fefc32a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ *~ -*.cabal .stack-work/ .vscode/ +dist-newstyle/ stack.yaml.lock diff --git a/README.md b/README.md index 48e23f8..ca9d2a3 100644 --- a/README.md +++ b/README.md @@ -55,6 +55,16 @@ Path for [HLint configuration file]. [Category] distinguishing multiple analyses at the same commit. +#### `fail-on` + +If not empty, then this disables code scanning and instead outputs annotations. +The value can be one of 'never', 'error', 'warning', or 'note', +which are based on the [levels specified by SARIF], +and it controls at what level a non-zero exit can happen. +Note that for pull requests, the non-zero exit can happen even if the issue +is in part of the code not changed by the pull request. +This is only intended for use in private GitHub repositories which do not have code scanning available. + ### Outputs #### `sarif-id` @@ -114,3 +124,5 @@ merchantability, or fitness for a particular purpose. [HLint configuration file]: https://github.com/ndmitchell/hlint#customizing-the-hints [write permission for `security-events`]: https://docs.github.com/en/rest/code-scanning/code-scanning?apiVersion=2022-11-28#upload-an-analysis-as-sarif-data + +[levels specified by SARIF]: https://github.com/microsoft/sarif-tutorials/blob/main/docs/2-Basics.md#level diff --git a/action.yaml b/action.yaml index 26e10ea..266b547 100644 --- a/action.yaml +++ b/action.yaml @@ -33,6 +33,12 @@ inputs: description: Access token to fetch the repository and write the code scanning results from HLint to GitHub code scanning. required: false default: ${{ github.token }} + fail-on: + description: | + If not empty, then this disables code scanning and instead outputs annotations. + The value can be one of 'never', 'error', 'warning', or 'note', which denotes at what level a non-zero exit can happen. + This is only intended for use in private GitHub repositories which do not have code scanning available. + required: false outputs: sarif-id: @@ -47,6 +53,7 @@ runs: - path=${{ inputs.path }} - category=${{ inputs.category }} - token=${{ inputs.token }} + - fail-on=${{ inputs.fail-on }} branding: icon: 'crosshair' diff --git a/hlint-scan.cabal b/hlint-scan.cabal new file mode 100644 index 0000000..635b14a --- /dev/null +++ b/hlint-scan.cabal @@ -0,0 +1,112 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: hlint-scan +version: 1.2.0 +synopsis: Code scanning GitHub action using HLint. +description: Scans code with HLint and uploads its analysis results to GitHub code scanning. + This is intended to be used as a standalone application on GitHub and not a library. + See . +category: GitHub, Development +homepage: https://github.com/haskell-actions/hlint-scan#readme +bug-reports: https://github.com/haskell-actions/hlint-scan/issues +author: Yoo Chung +maintainer: chungyc@google.com +copyright: Copyright 2023 Google LLC +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + action.yaml + Dockerfile + LICENSE + README.md + docs/CHANGELOG.md + docs/CODE_OF_CONDUCT.md + docs/CONTRIBUTING.md + docs/pull-scan.png + docs/security-scan.png + docs/SECURITY.md + +source-repository head + type: git + location: https://github.com/haskell-actions/hlint-scan + +library + exposed-modules: + Arguments + AutomationDetails + FilePath + Fingerprint + Format + Rules + Scan + SpecialOutput + Upload + other-modules: + Paths_hlint_scan + hs-source-dirs: + src + default-extensions: + OverloadedStrings + ghc-options: -Wall -Werror -O2 + build-depends: + aeson + , base + , base64 + , bytestring + , containers + , filepath + , github-rest + , process + , text + , vector + , zlib + default-language: GHC2021 + +executable hlint-scan + main-is: Main.hs + hs-source-dirs: + app + default-extensions: + OverloadedStrings + ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: + base + , hlint-scan + default-language: GHC2021 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + ArgumentsSpec + AutomationDetailsSpec + FilePathSpec + FingerprintSpec + FormatSpec + RulesSpec + SpecialOutputSpec + UploadSpec + hs-source-dirs: + test + default-extensions: + OverloadedStrings + ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , aeson + , base + , base64 + , bytestring + , github-rest + , hlint-scan + , hspec + , quickcheck-instances + , text + , vector + , zlib + default-language: GHC2021 diff --git a/src/Arguments.hs b/src/Arguments.hs index 55eb826..259ddb5 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -35,6 +35,7 @@ module Arguments (validate, translate) where import Data.List (group, sort) import Data.Maybe (mapMaybe) +import SpecialOutput qualified -- | Validate the program arguments. -- @@ -54,7 +55,14 @@ validate args | [] <- errors = Nothing | otherwise = Just $ unlines errors where - errors = notPairErrors ++ duplicateErrors ++ notAllowedErrors ++ badPathErrors + errors = + concat + [ notPairErrors, + duplicateErrors, + notAllowedErrors, + badValueErrors, + badPathErrors + ] -- Find arguments not in the form @keyword=value@. notPairErrors = mapMaybe forString args @@ -73,6 +81,16 @@ validate args | key `elem` allowedArgs = Nothing | otherwise = Just $ "\"" <> key <> "\" argument is not allowed" + -- Look for values that are not allowed. + badValueErrors = mapMaybe (badValue . toTuple) args + badValue ("fail-on", val) + | val `notElem` allowedValues = + Just $ "value \"" <> val <> "\" not allowed for \"fail-on\" argument" + | otherwise = Nothing + where + allowedValues = ["", "never", "error", "warning", "note"] + badValue _ = Nothing + -- Forbid paths which start with a '-' character, -- which could be confused as a flag. badPathErrors @@ -86,7 +104,7 @@ validate args -- | List of argument keywords which are allowed. -- In other words, these are arguments we know what to do with. allowedArgs :: [String] -allowedArgs = ["binary", "path", "hints", "category", "token"] +allowedArgs = ["binary", "path", "hints", "category", "token", "fail-on"] -- | Translate program arguments to arguments for HLint. -- Also derives the category and access token from the arguments. @@ -102,8 +120,9 @@ translate :: -- * Command-line arguments for HLint. -- * Category to upload with. -- * GitHub access token. - (FilePath, [String], Maybe String, Maybe String) -translate args = (executable', path' ++ hints' ++ requiredFlags, category', token') + (FilePath, [String], Maybe String, Maybe String, Maybe SpecialOutput.FailOn) +translate args = + (executable', path' ++ hints' ++ requiredFlags, category', token', failOn') where argsMap = map toTuple args @@ -135,6 +154,14 @@ translate args = (executable', path' ++ hints' ++ requiredFlags, category', toke | Just "" <- token = Nothing | otherwise = token + failOn = lookup "fail-on" argsMap + failOn' + | Just "never" <- failOn = Just SpecialOutput.Never + | Just "error" <- failOn = Just SpecialOutput.Error + | Just "warning" <- failOn = Just SpecialOutput.Warning + | Just "note" <- failOn = Just SpecialOutput.Note + | otherwise = Nothing + requiredFlags = ["-j", "--sarif", "--no-exit-code"] -- | Converts a program argument of the form @keyword=value@ diff --git a/src/Scan.hs b/src/Scan.hs index ca37799..bcec362 100644 --- a/src/Scan.hs +++ b/src/Scan.hs @@ -39,11 +39,13 @@ import Data.Aeson (Value, decode, encode) import Data.ByteString.Lazy import Data.Maybe (isJust) import Data.String +import Data.Text.IO qualified as TextIO import FilePath qualified import Fingerprint qualified import Format (formatMessages) import GitHub.REST import Rules qualified +import SpecialOutput qualified import System.Environment (getEnvironment) import System.Exit (ExitCode (ExitSuccess), die, exitWith) import System.Process (proc, readCreateProcessWithExitCode) @@ -80,7 +82,7 @@ main args = case Arguments.validate args of invoke :: [String] -> IO () invoke args = do - let (executable, flags, category, token) = Arguments.translate args + let (executable, flags, category, token, failOn) = Arguments.translate args (exitCode, out, err) <- readCreateProcessWithExitCode (proc executable flags) "" @@ -97,8 +99,16 @@ invoke args = do putStrLn out putStrLn "" + let out' = fromString out + case exitCode of - ExitSuccess -> annotate context $ fromString out + ExitSuccess -> + case failOn of + Nothing -> annotate context out' + Just failOn' -> do + let (specialOutput, exitCode') = SpecialOutput.output failOn' out' + TextIO.putStr specialOutput + exitWith exitCode' _ -> putStrLn err >> exitWith exitCode annotate :: Context -> ByteString -> IO () diff --git a/src/SpecialOutput.hs b/src/SpecialOutput.hs new file mode 100644 index 0000000..18de11c --- /dev/null +++ b/src/SpecialOutput.hs @@ -0,0 +1,220 @@ +{- +Copyright 2025 Google LLC + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +-} + +-- | +-- Description: Output GitHub annotations when code scanning uploads are disabled. +-- Copyright: Copyright 2025 Google LLC +-- License: Apache-2.0 +-- Maintainer: chungyc@google.com +-- +-- Responsible for the special case where code scanning result uploads are disabled. +-- Instead, the code scanning results are to be output as GitHub annotations instead, +-- and a non-zero exit should be done depending on the highest level present in the results. +-- +-- This is only intended for use in private GitHub repositories +-- which do not have code scanning available. +module SpecialOutput (FailOn (..), output) where + +import Data.Aeson hiding (Error) +import Data.Aeson.KeyMap hiding (map, mapMaybe) +import Data.ByteString.Lazy (ByteString) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text, pack, replace, stripPrefix) +import Data.Vector qualified as Vector +import System.Exit (ExitCode (..)) +import Prelude hiding (lookup) + +-- | Result level for when to fail with special case where code scanning is disabled. +data FailOn + = -- | Never fail. + Never + | -- | Fail only when there is an error. + Error + | -- | Fail when there is a warning or higher. + Warning + | -- | Fail when there is a note or higher. + Note + deriving (Eq, Show) + +-- | Return the GitHub annotations and exit code for the expected failure behavior and SARIF output. +output :: + -- | Failure behavior. + FailOn -> + -- | SARIF output from HLint. + ByteString -> + -- | Output and exit code. + (Text, ExitCode) +output failOn out + | [] <- rs = ("", ExitSuccess) + | otherwise = (annotations, exitCode) + where + rs = maybe [] fromValue value + value = decode out :: Maybe Value + + fromValue (Object v) = results v + fromValue _ = [] + + annotations = mconcat $ mapMaybe toAnnotation rs + exitCode = exitCodeFromResults failOn rs + +-- | Returns the result objects from a SARIF object as a list. +results :: Object -> [Object] +results v = maybe [] fromRuns $ lookup "runs" v + where + fromRuns (Array us) = concatMap fromRun $ Vector.toList us + fromRuns _ = [] + + fromRun (Object u) = maybe [] fromResults $ lookup "results" u + fromRun _ = [] + + fromResults (Array us) = mapMaybe fromResult $ Vector.toList us + fromResults _ = [] + + fromResult (Object u) = Just u + fromResult _ = Nothing + +-- | Returns which exit code to use for the given failure behavior and result objects. +exitCodeFromResults :: FailOn -> [Object] -> ExitCode +exitCodeFromResults Never _ = ExitSuccess +exitCodeFromResults Error vs = toExitCode ["error"] vs +exitCodeFromResults Warning vs = toExitCode ["error", "warning"] vs +exitCodeFromResults Note vs = toExitCode ["error", "warning", "note"] vs + +toExitCode :: [Text] -> [Object] -> ExitCode +toExitCode levels vs + | hasLevel levels vs = ExitFailure 1 + | otherwise = ExitSuccess + +hasLevel :: [Text] -> [Object] -> Bool +hasLevel levels = any has + where + has v = maybe False (`elem` levels) (toLevel $ lookup "level" v) + toLevel (Just (String s)) = Just s + toLevel _ = Nothing + +-- | Converts a result object into a GitHub workflow annotation. +toAnnotation :: Object -> Maybe Text +toAnnotation v = do + level' <- level + message' <- message + title' <- title + let annotation = + mconcat + [ "::" <> escapeSpecial level' <> " ", + location, + "title=" <> escapeSpecial title' <> "::", + escapeNewlines message' + ] + return $ escapeNewlines annotation <> "\n" + where + level = toGitHubLevel $ lookup "level" v + message = messageText $ lookup "message" v + title = ruleId $ lookup "ruleId" v + location = locationAnnotation v + + -- From SARIF levels to GitHub levels. + toGitHubLevel (Just (String "error")) = Just "error" + toGitHubLevel (Just (String "warning")) = Just "warning" + toGitHubLevel (Just (String "note")) = Just "notice" + toGitHubLevel _ = Nothing + + messageText (Just (Object u)) + | Just (String s) <- lookup "text" u = Just $ escapeNewlines s + | otherwise = Nothing + messageText _ = Nothing + + ruleId (Just (String s)) = Just s + ruleId _ = Nothing + +-- | Returns the annotations for the location in a result object. +-- If there are any location annotations, the return value will end with @","@, +-- otherwise the return value will be empty. +locationAnnotation :: Object -> Text +locationAnnotation v = + mconcat + [ fileAnnotation, + colAnnotation, + endColumnAnnotation, + lineAnnotation, + endLineAnnotation + ] + where + fileAnnotation + | (Just s) <- filename = "file=" <> escapeSpecial s <> "," + | otherwise = "" + + colAnnotation + | (Just n) <- col = "col=" <> pack (show n) <> "," + | otherwise = "" + + endColumnAnnotation + | (Just n) <- endColumn = "endColumn=" <> pack (show n) <> "," + | otherwise = "" + + lineAnnotation + | (Just n) <- line = "line=" <> pack (show n) <> "," + | otherwise = "" + + endLineAnnotation + | (Just n) <- endLine = "endLine=" <> pack (show n) <> "," + | otherwise = "" + + locations + | Just (Array us) <- lookup "locations" v = Just us + | otherwise = Nothing + + physicalLocation + | Just (Object u : _) <- Vector.toList <$> locations, + Just (Object l) <- lookup "physicalLocation" u = + Just l + | otherwise = Nothing + + filename + | Just (Object u) <- lookup "artifactLocation" =<< physicalLocation, + Just (String uri) <- lookup "uri" u = + Just $ fromMaybe uri $ stripPrefix "./" uri + | otherwise = Nothing + + region + | Just (Object u) <- lookup "region" =<< physicalLocation = Just u + | otherwise = Nothing + + col + | Just (Number n) <- lookup "startColumn" =<< region = Just (round n :: Int) + | otherwise = Nothing + + endColumn + | Just (Number n) <- lookup "endColumn" =<< region = Just (round n :: Int) + | otherwise = Nothing + + line + | Just (Number n) <- lookup "startLine" =<< region = Just (round n :: Int) + | otherwise = Nothing + + endLine + | Just (Number n) <- lookup "endLine" =<< region = Just (round n :: Int) + | otherwise = Nothing + +-- | Replace newlines in output so that they can be treated as newlines +-- despite being on a single line annotation. +-- +-- See https://github.com/actions/toolkit/issues/193. +escapeNewlines :: Text -> Text +escapeNewlines = replace "\n" "%0A" + +-- | Escape special characters which can interfere with the parsing of an annotation. +escapeSpecial :: Text -> Text +escapeSpecial = replace ":" "%3A" . replace "," "%2C" . replace "=" "%3D" . escapeNewlines diff --git a/test/ArgumentsSpec.hs b/test/ArgumentsSpec.hs index 93cdeb0..faa67d4 100644 --- a/test/ArgumentsSpec.hs +++ b/test/ArgumentsSpec.hs @@ -24,6 +24,7 @@ module ArgumentsSpec (spec) where import Arguments import Data.List (isPrefixOf) import Data.Maybe (isJust, isNothing) +import SpecialOutput qualified import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -40,28 +41,48 @@ spec = do "path=.", "hints=.hlint.yaml", "category=code-quality", - "token=AB12CD" + "token=AB12CD", + "fail-on=" ] `shouldBe` Nothing prop "argument must have '=' character" $ \s -> - ('=' `notElem` s) - ==> validate [s] - `shouldSatisfy` isJust + ('=' `notElem` s) ==> + validate [s] `shouldSatisfy` isJust prop "argument must not have duplicate keyword" $ \key v v' -> - '=' - `notElem` key ==> \keyValues -> - let otherArgs = map (\(x, y) -> x <> "=" <> y) keyValues - args' = [key <> "=" <> v, key <> "=" <> v'] ++ otherArgs - in forAll (shuffle args') $ \args -> - validate args `shouldSatisfy` isJust + '=' `notElem` key ==> \keyValues -> + let otherArgs = map (\(x, y) -> x <> "=" <> y) keyValues + args' = [key <> "=" <> v, key <> "=" <> v'] ++ otherArgs + in forAll (shuffle args') $ \args -> + validate args `shouldSatisfy` isJust prop "argument must have explicitly allowed keyword" $ \key v -> - ('=' `notElem` key) - ==> (key `notElem` ["binary", "path", "hints", "category", "token"]) - ==> validate [key <> "=" <> v] - `shouldSatisfy` isJust + ('=' `notElem` key) ==> + (key `notElem` ["binary", "path", "hints", "category", "token"]) ==> + validate [key <> "=" <> v] `shouldSatisfy` isJust + + describe "correct argument values" $ do + describe "fail-on" $ do + it "is nothing" $ do + validate [] `shouldBe` Nothing + validate ["fail-on="] `shouldBe` Nothing + + it "is never" $ + validate ["fail-on=never"] `shouldBe` Nothing + + it "is error" $ + validate ["fail-on=error"] `shouldBe` Nothing + + it "is warning" $ + validate ["fail-on=warning"] `shouldBe` Nothing + + it "is note" $ + validate ["fail-on=note"] `shouldBe` Nothing + + prop "rejects bad values" $ \v -> + v `notElem` ["", "never", "error", "warning", "note"] ==> + validate ["fail-on=" <> v] `shouldSatisfy` isJust prop "path may not look like a flag" $ \pathSuffix paths' -> forAll (shuffle $ ("-" <> pathSuffix) : paths') $ \paths -> @@ -74,39 +95,53 @@ spec = do "path=.", "hints=.hlint.yaml", "category=code-quality", - "token=XYZ123" + "token=XYZ123", + "fail-on=warning" ] `shouldBe` ( "/hlint", [".", "--hint=.hlint.yaml", "-j", "--sarif", "--no-exit-code"], Just "code-quality", - Just "XYZ123" + Just "XYZ123", + Just SpecialOutput.Warning ) prop "translates missing category to Nothing" $ - translate [] `shouldSatisfy` \(_, _, category, _) -> isNothing category + translate [] `shouldSatisfy` \(_, _, category, _, _) -> isNothing category prop "translates missing token to Nothing" $ - translate [] `shouldSatisfy` \(_, _, _, token) -> isNothing token + translate [] `shouldSatisfy` \(_, _, _, token, _) -> isNothing token prop "translates empty binary to default binary" $ translate ["binary="] - `shouldSatisfy` \(binary, _, _, _) -> binary == "/hlint" + `shouldSatisfy` \(binary, _, _, _, _) -> binary == "/hlint" prop "translates empty path to default path" $ translate ["path="] - `shouldSatisfy` \(_, args, _, _) -> args == [".", "-j", "--sarif", "--no-exit-code"] + `shouldSatisfy` \(_, args, _, _, _) -> args == [".", "-j", "--sarif", "--no-exit-code"] prop "translates empty hints to omitted hints file flag" $ translate ["hints="] - `shouldSatisfy` \(_, args, _, _) -> args == [".", "-j", "--sarif", "--no-exit-code"] + `shouldSatisfy` \(_, args, _, _, _) -> args == [".", "-j", "--sarif", "--no-exit-code"] prop "translates empty category to Nothing" $ translate ["category="] - `shouldSatisfy` \(_, _, category, _) -> isNothing category + `shouldSatisfy` \(_, _, category, _, _) -> isNothing category prop "translates empty token to Nothing" $ translate ["token="] - `shouldSatisfy` \(_, _, token, _) -> isNothing token + `shouldSatisfy` \(_, _, _, token, _) -> isNothing token + + prop "translates empty fail-on to Nothing" $ + translate ["fail-on="] + `shouldSatisfy` \(_, _, _, _, failOn) -> isNothing failOn + + let failOn (_, _, _, _, x) = x + in describe "translates fail-on arguments" $ do + it "empty string" $ failOn (translate ["fail-on="]) `shouldBe` Nothing + it "never" $ failOn (translate ["fail-on=never"]) `shouldBe` Just SpecialOutput.Never + it "error" $ failOn (translate ["fail-on=error"]) `shouldBe` Just SpecialOutput.Error + it "warning" $ failOn (translate ["fail-on=warning"]) `shouldBe` Just SpecialOutput.Warning + it "note" $ failOn (translate ["fail-on=note"]) `shouldBe` Just SpecialOutput.Note prop "translates general arguments" $ \binary paths hints category token -> (binary /= "") @@ -116,15 +151,15 @@ spec = do && (hints /= "") && (category /= "") && (token /= "") - ==> forAll - ( shuffle - [ "binary=" <> binary, - "path=" <> paths, - "hints=" <> hints, - "category=" <> category, - "token=" <> token - ] - ) + ==> forAll + ( shuffle + [ "binary=" <> binary, + "path=" <> paths, + "hints=" <> hints, + "category=" <> category, + "token=" <> token + ] + ) $ \args -> translate args `shouldBe` ( binary, @@ -135,5 +170,6 @@ spec = do "--no-exit-code" ], Just category, - Just token + Just token, + Nothing ) diff --git a/test/SpecialOutputSpec.hs b/test/SpecialOutputSpec.hs new file mode 100644 index 0000000..36a72d4 --- /dev/null +++ b/test/SpecialOutputSpec.hs @@ -0,0 +1,185 @@ +{- +Copyright 2025 Google LLC + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +-} + +-- | +-- Description: Tests for the "SpecialOutput" module. +-- Copyright: Copyright 2025 Google LLC +-- License: Apache-2.0 +-- Maintainer: chungyc@google.com +module SpecialOutputSpec where + +import Data.Aeson hiding (Error) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Vector qualified as Vector +import SpecialOutput +import System.Exit +import Test.Hspec + +spec :: Spec +spec = parallel $ do + it "outputs minimal annotation" $ + let v = encode $ Object $ KeyMap.singleton "runs" runs + runs = Array $ Vector.singleton run + run = Object $ KeyMap.singleton "results" results + results = Array $ Vector.singleton result + result = + Object $ + KeyMap.fromList + [ ("level", "error"), + ("ruleId", "redundant entity"), + ("message", Object $ KeyMap.singleton "text" "random comment") + ] + in output Never v `shouldBe` ("::error title=redundant entity::random comment\n", ExitSuccess) + + it "outputs annotation with some location information" $ + let v = encode $ Object $ KeyMap.singleton "runs" runs + runs = Array $ Vector.singleton run + run = Object $ KeyMap.singleton "results" results + results = Array $ Vector.singleton result + result = + Object $ + KeyMap.fromList + [ ("level", "error"), + ("ruleId", "redundant entity"), + ("message", Object $ KeyMap.singleton "text" "random comment"), + ("locations", Array $ Vector.singleton location) + ] + location = Object $ KeyMap.singleton "physicalLocation" physicalLocation + physicalLocation = Object $ KeyMap.singleton "artifactLocation" artifactLocation + artifactLocation = Object $ KeyMap.singleton "uri" "SpecialOutput.hs" + in output Never v + `shouldBe` ("::error file=SpecialOutput.hs,title=redundant entity::random comment\n", ExitSuccess) + + it "outputs annotation with full location information" $ + let v = encode $ Object $ KeyMap.singleton "runs" runs + runs = Array $ Vector.singleton run + run = Object $ KeyMap.singleton "results" results + results = Array $ Vector.singleton result + result = + Object $ + KeyMap.fromList + [ ("level", "error"), + ("ruleId", "redundant entity"), + ("message", Object $ KeyMap.singleton "text" "random comment"), + ("locations", Array $ Vector.singleton location) + ] + location = Object $ KeyMap.singleton "physicalLocation" physicalLocation + physicalLocation = + Object $ + KeyMap.fromList + [ ("artifactLocation", artifactLocation), + ( "region", + Object $ + KeyMap.fromList + [ ("startColumn", Number 12), + ("endColumn", Number 20), + ("startLine", Number 1020), + ("endLine", Number 1025) + ] + ) + ] + artifactLocation = Object $ KeyMap.singleton "uri" "./SpecialOutput.hs" + in output Never v + `shouldBe` ( mconcat + [ "::error ", + "file=SpecialOutput.hs,", + "col=12,", + "endColumn=20,", + "line=1020,", + "endLine=1025,", + "title=redundant entity::", + "random comment\n" + ], + ExitSuccess + ) + + it "escapes newlines in messages" $ + let v = encode $ Object $ KeyMap.singleton "runs" runs + runs = Array $ Vector.singleton run + run = Object $ KeyMap.singleton "results" results + results = Array $ Vector.singleton result + result = + Object $ + KeyMap.fromList + [ ("level", "error"), + ("ruleId", "redundant entity"), + ("message", Object $ KeyMap.singleton "text" "random\ncomment:2=2") + ] + in output Never v + `shouldBe` ("::error title=redundant entity::random%0Acomment:2=2\n", ExitSuccess) + + it "escapes special characters" $ + let v = encode $ Object $ KeyMap.singleton "runs" runs + runs = Array $ Vector.singleton run + run = Object $ KeyMap.singleton "results" results + results = Array $ Vector.singleton result + result = + Object $ + KeyMap.fromList + [ ("level", "error"), + ("ruleId", "redundant entity\n:="), + ("message", Object $ KeyMap.singleton "text" "random comment"), + ("locations", Array $ Vector.singleton location) + ] + location = Object $ KeyMap.singleton "physicalLocation" physicalLocation + physicalLocation = Object $ KeyMap.singleton "artifactLocation" artifactLocation + artifactLocation = Object $ KeyMap.singleton "uri" "./SpecialOutput.hs\n:=" + in output Never v + `shouldBe` ( mconcat + [ "::error ", + "file=SpecialOutput.hs%0A%3A%3D,", + "title=redundant entity%0A%3A%3D::", + "random comment\n" + ], + ExitSuccess + ) + + let sarif levels = encode $ Object $ KeyMap.singleton "runs" runs + where + runs = Array $ Vector.singleton run + run = Object $ KeyMap.singleton "results" $ results levels + results levels = Array $ Vector.fromList $ map result levels + result level = + Object $ + KeyMap.fromList + [ ("level", level), + ("ruleId", "a"), + ("message", Object $ KeyMap.singleton "text" "b") + ] + in describe "exit code" $ do + it "never : [error]" $ + snd (output Never $ sarif ["error"]) `shouldBe` ExitSuccess + + it "error : [note, warning]" $ + snd (output Error $ sarif ["note", "warning"]) `shouldBe` ExitSuccess + + it "error : [note, warning, error]" $ + snd (output Error $ sarif ["note", "warning", "error"]) `shouldBe` ExitFailure 1 + + it "warning : [note, note]" $ + snd (output Warning $ sarif ["note", "note"]) `shouldBe` ExitSuccess + + it "warning : [note, warning]" $ + snd (output Warning $ sarif ["note", "warning"]) `shouldBe` ExitFailure 1 + + it "note : []" $ + snd (output Note $ sarif []) `shouldBe` ExitSuccess + + it "note : [note]" $ + snd (output Note $ sarif ["note"]) `shouldBe` ExitFailure 1 + + it "note : [warning]" $ + snd (output Note $ sarif ["warning"]) `shouldBe` ExitFailure 1