module Hadolint.Formatter.Sarif
  ( printResults,
    formatResult,
  )
where

import qualified Control.Foldl as Foldl
import Data.Aeson hiding (Result)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Sequence as Seq
import qualified Data.Text as Text
import Hadolint.Formatter.Format
  ( Result (..),
    errorMessage,
    errorPosition,
  )
import Hadolint.Meta
  ( getShortVersion,
  )
import Hadolint.Rule
  ( CheckFailure (..),
    DLSeverity (..),
    unRuleCode,
  )
import Text.Megaparsec (TraversableStream)
import Text.Megaparsec.Error
import Text.Megaparsec.Pos
  ( sourceColumn,
    sourceLine,
    sourceName,
    unPos,
  )
import Text.Megaparsec.Stream (VisualStream)

data SarifFormat s e
  = SarifCheck Text.Text CheckFailure
  | SarifError (ParseErrorBundle s e)

instance
  ( VisualStream s,
    TraversableStream s,
    ShowErrorComponent e
  ) =>
  ToJSON (SarifFormat s e)
  where
  toJSON :: SarifFormat s e -> Value
toJSON (SarifCheck Text
filename CheckFailure {Linenumber
Text
RuleCode
DLSeverity
line :: CheckFailure -> Linenumber
message :: CheckFailure -> Text
severity :: CheckFailure -> DLSeverity
code :: CheckFailure -> RuleCode
line :: Linenumber
message :: Text
severity :: DLSeverity
code :: RuleCode
..}) =
    [Pair] -> Value
object
      [ Key
"ruleId" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RuleCode -> Text
unRuleCode RuleCode
code,
        Key
"level" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DLSeverity -> Text
toSeverity DLSeverity
severity,
        Key
"message"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"text" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
message
            ],
        Key
"locations"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object
                 [ Key
"physicalLocation"
                     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                       [ Key
"artifactLocation"
                           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                             [ Key
"uri" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
filename
                             ],
                         Key
"region"
                           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                             [ Key
"startLine" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Linenumber
line,
                               Key
"endLine" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Linenumber
line,
                               Key
"startColumn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Linenumber
1 :: Int),
                               Key
"endColumn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Linenumber
1 :: Int),
                               Key
"sourceLanguage" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
language
                             ]
                       ]
                 ]
             ]
      ]
    where
      language :: String
language = if Text
"DL" Text -> Text -> Bool
`Text.isPrefixOf` RuleCode -> Text
unRuleCode RuleCode
code
                    then String
"dockerfile"
                    else String
"sh"
  toJSON (SarifError ParseErrorBundle s e
err) =
    [Pair] -> Value
object
      [ Key
"ruleId" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
"DL1000",
        Key
"level" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
"error",
        Key
"message"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"text" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorMessage ParseErrorBundle s e
err
            ],
        Key
"locations"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object
                 [ Key
"physicalLocation"
                     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                       [ Key
"artifactLocation"
                           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                             [ Key
"uri" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack (SourcePos -> String
sourceName SourcePos
pos)
                             ],
                         Key
"region"
                           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                             [ Key
"startLine" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Linenumber
linenumber,
                               Key
"endLine" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Linenumber
linenumber,
                               Key
"startColumn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Linenumber
column,
                               Key
"endColumn" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Linenumber
column,
                               Key
"sourceLanguage" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
"dockerfile"
                             ]
                       ]
                 ]
             ]
      ]
    where
      pos :: SourcePos
pos = forall s e.
TraversableStream s =>
ParseErrorBundle s e -> SourcePos
errorPosition ParseErrorBundle s e
err
      linenumber :: Linenumber
linenumber = Pos -> Linenumber
unPos forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
pos
      column :: Linenumber
column = Pos -> Linenumber
unPos forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
pos

formatResult :: Result s e -> Seq (SarifFormat s e)
formatResult :: forall s e. Result s e -> Seq (SarifFormat s e)
formatResult (Result Text
filename Seq (ParseErrorBundle s e)
errors Failures
checks) = Seq (SarifFormat s e)
allMessages
  where
    allMessages :: Seq (SarifFormat s e)
allMessages = Seq (SarifFormat s e)
errorMessages forall a. Semigroup a => a -> a -> a
<> forall {s} {e}. Seq (SarifFormat s e)
checkMessages
    checkMessages :: Seq (SarifFormat s e)
checkMessages = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s e. Text -> CheckFailure -> SarifFormat s e
SarifCheck Text
filename) Failures
checks
    errorMessages :: Seq (SarifFormat s e)
errorMessages = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s e. ParseErrorBundle s e -> SarifFormat s e
SarifError Seq (ParseErrorBundle s e)
errors

printResults ::
  ( VisualStream s,
    TraversableStream s,
    ShowErrorComponent e,
    Foldable f
  ) =>
  f (Result s e) ->
  IO ()
printResults :: forall s e (f :: * -> *).
(VisualStream s, TraversableStream s, ShowErrorComponent e,
 Foldable f) =>
f (Result s e) -> IO ()
printResults f (Result s e)
results =
  ByteString -> IO ()
B.putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object
      [ (Key
"version", Value
"2.1.0"),
        Key
"$schema"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
"http://json.schemastore.org/sarif-2.1.0",
        Key
"runs"
          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ [Pair] -> Value
object
                 [ Key
"tool"
                     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                       [ Key
"driver"
                           forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                             [ (Key
"name", Value
"Hadolint"),
                               (Key
"fullName", Value
"Haskell Dockerfile Linter"),
                               (Key
"downloadUri",
                                  Value
"https://github.com/hadolint/hadolint"),
                               Key
"version"
                                 forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
Hadolint.Meta.getShortVersion,
                               Key
"shortDescription"
                                 forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                                   [ (Key
"text",
  Value
"Dockerfile linter, validate inline bash, written in Haskell")
                                   ]
                             ]
                       ],
                   Key
"results" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Seq (SarifFormat s e)
flattened,
                   Key
"defaultSourceLanguage" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String -> Text
Text.pack String
"dockerfile"
                 ]
             ]
      ]
  where
    flattened :: Seq (SarifFormat s e)
flattened = forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b
Foldl.fold (forall a b r. (a -> b) -> Fold b r -> Fold a r
Foldl.premap forall s e. Result s e -> Seq (SarifFormat s e)
formatResult forall a. Monoid a => Fold a a
Foldl.mconcat) f (Result s e)
results

-- | SARIF only specifies three severities "error", "warning" and "note"
-- We pack our "info" and "style" severities together into the "note" severity
-- here.
toSeverity :: DLSeverity -> Text.Text
toSeverity :: DLSeverity -> Text
toSeverity DLSeverity
DLErrorC = Text
"error"
toSeverity DLSeverity
DLWarningC = Text
"warning"
toSeverity DLSeverity
_ = Text
"note"