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
      [ Text
"ruleId" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RuleCode -> Text
unRuleCode RuleCode
code,
        Text
"level" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= DLSeverity -> Text
toSeverity DLSeverity
severity,
        Text
"message"
          Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
            [ Text
"text" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
message
            ],
        Text
"locations"
          Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [ [Pair] -> Value
object
                 [ Text
"physicalLocation"
                     Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                       [ Text
"artifactLocation"
                           Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                             [ Text
"uri" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
filename
                             ],
                         Text
"region"
                           Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                             [ Text
"startLine" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Linenumber
line,
                               Text
"endLine" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Linenumber
line,
                               Text
"startColumn" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Linenumber
1 :: Int),
                               Text
"endColumn" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Linenumber
1 :: Int),
                               Text
"sourceLanguage" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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
      [ Text
"ruleId" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"DL1000",
        Text
"level" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"error",
        Text
"message"
          Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
            [ Text
"text" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ParseErrorBundle s e -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorMessage ParseErrorBundle s e
err
            ],
        Text
"locations"
          Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [ [Pair] -> Value
object
                 [ Text
"physicalLocation"
                     Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                       [ Text
"artifactLocation"
                           Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                             [ Text
"uri" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack (SourcePos -> String
sourceName SourcePos
pos)
                             ],
                         Text
"region"
                           Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                             [ Text
"startLine" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Linenumber
linenumber,
                               Text
"endLine" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Linenumber
linenumber,
                               Text
"startColumn" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Linenumber
column,
                               Text
"endColumn" Text -> Linenumber -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Linenumber
column,
                               Text
"sourceLanguage" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"dockerfile"
                             ]
                       ]
                 ]
             ]
      ]
    where
      pos :: SourcePos
pos = ParseErrorBundle s e -> SourcePos
forall s e.
TraversableStream s =>
ParseErrorBundle s e -> SourcePos
errorPosition ParseErrorBundle s e
err
      linenumber :: Linenumber
linenumber = Pos -> Linenumber
unPos (Pos -> Linenumber) -> Pos -> Linenumber
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
pos
      column :: Linenumber
column = Pos -> Linenumber
unPos (Pos -> Linenumber) -> Pos -> Linenumber
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
pos

formatResult :: Result s e -> Seq (SarifFormat s e)
formatResult :: 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 Seq (SarifFormat s e)
-> Seq (SarifFormat s e) -> Seq (SarifFormat s e)
forall a. Semigroup a => a -> a -> a
<> Seq (SarifFormat s e)
forall s e. Seq (SarifFormat s e)
checkMessages
    checkMessages :: Seq (SarifFormat s e)
checkMessages = (CheckFailure -> SarifFormat s e)
-> Failures -> Seq (SarifFormat s e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> CheckFailure -> SarifFormat s e
forall s e. Text -> CheckFailure -> SarifFormat s e
SarifCheck Text
filename) Failures
checks
    errorMessages :: Seq (SarifFormat s e)
errorMessages = (ParseErrorBundle s e -> SarifFormat s e)
-> Seq (ParseErrorBundle s e) -> Seq (SarifFormat s e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParseErrorBundle s e -> SarifFormat s e
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 :: f (Result s e) -> IO ()
printResults f (Result s e)
results =
  ByteString -> IO ()
B.putStr (ByteString -> IO ()) -> (Value -> ByteString) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Pair] -> Value
object
      [ (Text
"version", Value
"2.1.0"),
        Text
"$schema"
          Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"http://json.schemastore.org/sarif-2.1.0",
        Text
"runs"
          Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [ [Pair] -> Value
object
                 [ Text
"tool"
                     Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                       [ Text
"driver"
                           Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                             [ (Text
"name", Value
"Hadolint"),
                               (Text
"fullName", Value
"Haskell Dockerfile Linter"),
                               (Text
"downloadUri",
                                  Value
"https://github.com/hadolint/hadolint"),
                               Text
"version"
                                 Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
Hadolint.Meta.getShortVersion,
                               Text
"shortDescription"
                                 Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Pair] -> Value
object
                                   [ (Text
"text",
  Value
"Dockerfile linter, validate inline bash, written in Haskell")
                                   ]
                             ]
                       ],
                   Text
"results" Text -> Seq (SarifFormat s e) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Seq (SarifFormat s e)
flattened,
                   Text
"defaultSourceLanguage" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Text
Text.pack String
"dockerfile"
                 ]
             ]
      ]
  where
    flattened :: Seq (SarifFormat s e)
flattened = Fold (Result s e) (Seq (SarifFormat s e))
-> f (Result s e) -> Seq (SarifFormat s e)
forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b
Foldl.fold ((Result s e -> Seq (SarifFormat s e))
-> Fold (Seq (SarifFormat s e)) (Seq (SarifFormat s e))
-> Fold (Result s e) (Seq (SarifFormat s e))
forall a b r. (a -> b) -> Fold b r -> Fold a r
Foldl.premap Result s e -> Seq (SarifFormat s e)
forall s e. Result s e -> Seq (SarifFormat s e)
formatResult Fold (Seq (SarifFormat s e)) (Seq (SarifFormat s e))
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"