Add ability to disable code scanning

.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'

.gitignore

@@ -1,5 +1,5 @@
 *~
-*.cabal
 .stack-work/
 .vscode/
+dist-newstyle/
 stack.yaml.lock

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

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'

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 <https://github.com/haskell-actions/hlint-scan>.
+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:     [email protected]
+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

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@

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 ()