module Hadolint.Formatter.Codeclimate ( printResults, printGitlabResults, formatResult, formatGitlabResult, ) where import qualified Control.Foldl as Foldl import Crypto.Hash (Digest, SHA1 (..), hash) import Data.Aeson hiding (Result) import qualified Data.ByteString.Lazy as B import Data.Sequence (Seq) import qualified Data.Text as Text import GHC.Generics import Hadolint.Formatter.Format (Result (..), errorPosition) import Hadolint.Rule (CheckFailure (..), DLSeverity (..), RuleCode (..)) import Text.Megaparsec (TraversableStream) import Text.Megaparsec.Error import Text.Megaparsec.Pos (sourceColumn, sourceLine, sourceName, unPos) import Text.Megaparsec.Stream (VisualStream) data Issue = Issue { Issue -> Text checkName :: Text.Text, Issue -> Text description :: Text.Text, Issue -> Location location :: Location, Issue -> Text impact :: Text.Text } data FingerprintIssue = FingerprintIssue { FingerprintIssue -> Issue issue :: Issue, FingerprintIssue -> Digest SHA1 fingerprint :: Digest SHA1 } data Location = LocLine Text.Text Int | LocPos Text.Text Pos instance ToJSON Location where toJSON :: Location -> Value toJSON (LocLine Text path Int l) = [Pair] -> Value object [Key "path" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Text path, Key "lines" Key -> Value -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= [Pair] -> Value object [Key "begin" Key -> Int -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Int l, Key "end" Key -> Int -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Int l]] toJSON (LocPos Text path Pos pos) = [Pair] -> Value object [Key "path" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Text path, Key "positions" Key -> Value -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= [Pair] -> Value object [Key "begin" Key -> Pos -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Pos pos, Key "end" Key -> Pos -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Pos pos]] data Pos = Pos { Pos -> Int line :: Int, Pos -> Int column :: Int } deriving ((forall x. Pos -> Rep Pos x) -> (forall x. Rep Pos x -> Pos) -> Generic Pos forall x. Rep Pos x -> Pos forall x. Pos -> Rep Pos x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall x. Pos -> Rep Pos x from :: forall x. Pos -> Rep Pos x $cto :: forall x. Rep Pos x -> Pos to :: forall x. Rep Pos x -> Pos Generic) instance ToJSON Pos instance ToJSON Issue where toJSON :: Issue -> Value toJSON Issue {Text Location checkName :: Issue -> Text description :: Issue -> Text location :: Issue -> Location impact :: Issue -> Text checkName :: Text description :: Text location :: Location impact :: Text ..} = [Pair] -> Value object [ Key "type" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= (Text "issue" :: Text.Text), Key "check_name" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Text checkName, Key "description" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Text description, Key "categories" Key -> [Text] -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= ([Text "Bug Risk"] :: [Text.Text]), Key "location" Key -> Location -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Location location, Key "severity" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Text impact ] instance ToJSON FingerprintIssue where toJSON :: FingerprintIssue -> Value toJSON FingerprintIssue {Digest SHA1 Issue issue :: FingerprintIssue -> Issue fingerprint :: FingerprintIssue -> Digest SHA1 issue :: Issue fingerprint :: Digest SHA1 ..} = [Pair] -> Value object [ Key "type" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= (Text "issue" :: Text.Text), Key "fingerprint" Key -> String -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Digest SHA1 -> String forall a. Show a => a -> String show Digest SHA1 fingerprint, Key "check_name" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Issue -> Text checkName Issue issue, Key "description" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Issue -> Text description Issue issue, Key "categories" Key -> [Text] -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= ([Text "Bug Risk"] :: [Text.Text]), Key "location" Key -> Location -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Issue -> Location location Issue issue, Key "severity" Key -> Text -> Pair forall v. ToJSON v => Key -> v -> Pair forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv .= Issue -> Text impact Issue issue ] errorToIssue :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> Issue errorToIssue :: forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> Issue errorToIssue ParseErrorBundle s e err = Issue { checkName :: Text checkName = Text "DL1000", description :: Text description = String -> Text Text.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ ParseErrorBundle s e -> String forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String errorBundlePretty ParseErrorBundle s e err, location :: Location location = Text -> Pos -> Location LocPos (String -> Text Text.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ SourcePos -> String sourceName SourcePos pos) Pos {Int line :: Int column :: Int line :: Int column :: Int ..}, impact :: Text impact = DLSeverity -> Text severityText DLSeverity DLErrorC } where pos :: SourcePos pos = ParseErrorBundle s e -> SourcePos forall s e. TraversableStream s => ParseErrorBundle s e -> SourcePos errorPosition ParseErrorBundle s e err line :: Int line = Pos -> Int unPos (SourcePos -> Pos sourceLine SourcePos pos) column :: Int column = Pos -> Int unPos (SourcePos -> Pos sourceColumn SourcePos pos) checkToIssue :: Text.Text -> CheckFailure -> Issue checkToIssue :: Text -> CheckFailure -> Issue checkToIssue Text fileName CheckFailure {Int Text RuleCode DLSeverity code :: RuleCode severity :: DLSeverity message :: Text line :: Int line :: CheckFailure -> Int message :: CheckFailure -> Text severity :: CheckFailure -> DLSeverity code :: CheckFailure -> RuleCode ..} = Issue { checkName :: Text checkName = RuleCode -> Text unRuleCode RuleCode code, description :: Text description = Text message, location :: Location location = Text -> Int -> Location LocLine Text fileName Int line, impact :: Text impact = DLSeverity -> Text severityText DLSeverity severity } severityText :: DLSeverity -> Text.Text severityText :: DLSeverity -> Text severityText DLSeverity severity = case DLSeverity severity of DLSeverity DLErrorC -> Text "blocker" DLSeverity DLWarningC -> Text "major" DLSeverity DLInfoC -> Text "info" DLSeverity DLStyleC -> Text "minor" DLSeverity _ -> Text "" generateFingerprint :: Issue -> Digest SHA1 generateFingerprint :: Issue -> Digest SHA1 generateFingerprint = StrictByteString -> Digest SHA1 forall ba a. (ByteArrayAccess ba, HashAlgorithm a) => ba -> Digest a hash (StrictByteString -> Digest SHA1) -> (Issue -> StrictByteString) -> Issue -> Digest SHA1 forall b c a. (b -> c) -> (a -> b) -> a -> c . LazyByteString -> StrictByteString B.toStrict (LazyByteString -> StrictByteString) -> (Issue -> LazyByteString) -> Issue -> StrictByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . Issue -> LazyByteString forall a. ToJSON a => a -> LazyByteString encode issueToFingerprintIssue :: Issue -> FingerprintIssue issueToFingerprintIssue :: Issue -> FingerprintIssue issueToFingerprintIssue Issue i = FingerprintIssue { issue :: Issue issue = Issue i, fingerprint :: Digest SHA1 fingerprint = Issue -> Digest SHA1 generateFingerprint Issue i } formatResult :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq Issue formatResult :: forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq Issue formatResult (Result Text filename Seq (ParseErrorBundle s e) errors Failures checks) = (ParseErrorBundle s e -> Issue forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> Issue errorToIssue (ParseErrorBundle s e -> Issue) -> Seq (ParseErrorBundle s e) -> Seq Issue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Seq (ParseErrorBundle s e) errors) Seq Issue -> Seq Issue -> Seq Issue forall a. Semigroup a => a -> a -> a <> (Text -> CheckFailure -> Issue checkToIssue Text filename (CheckFailure -> Issue) -> Failures -> Seq Issue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Failures checks) formatGitlabResult :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq FingerprintIssue formatGitlabResult :: forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq FingerprintIssue formatGitlabResult Result s e result = Issue -> FingerprintIssue issueToFingerprintIssue (Issue -> FingerprintIssue) -> Seq Issue -> Seq FingerprintIssue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Result s e -> Seq Issue forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq Issue formatResult Result s e result printResult :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> IO () printResult :: forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> IO () printResult Result s e result = (Issue -> IO ()) -> Seq Issue -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Issue -> IO () forall {a}. ToJSON a => a -> IO () output (Result s e -> Seq Issue forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq Issue formatResult Result s e result) where output :: a -> IO () output a value = do LazyByteString -> IO () B.putStr (a -> LazyByteString forall a. ToJSON a => a -> LazyByteString encode a value) LazyByteString -> IO () B.putStr (Word8 -> LazyByteString B.singleton Word8 0x00) 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 = (Result s e -> IO ()) -> f (Result s e) -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ Result s e -> IO () forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> IO () printResult printGitlabResults :: (Foldable f, VisualStream s, TraversableStream s, ShowErrorComponent e) => f (Result s e) -> IO () printGitlabResults :: forall (f :: * -> *) s e. (Foldable f, VisualStream s, TraversableStream s, ShowErrorComponent e) => f (Result s e) -> IO () printGitlabResults f (Result s e) results = LazyByteString -> IO () B.putStr (LazyByteString -> IO ()) -> (Seq FingerprintIssue -> LazyByteString) -> Seq FingerprintIssue -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . Seq FingerprintIssue -> LazyByteString forall a. ToJSON a => a -> LazyByteString encode (Seq FingerprintIssue -> IO ()) -> Seq FingerprintIssue -> IO () forall a b. (a -> b) -> a -> b $ Seq FingerprintIssue flattened where flattened :: Seq FingerprintIssue flattened = Fold (Result s e) (Seq FingerprintIssue) -> f (Result s e) -> Seq FingerprintIssue forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b Foldl.fold ((Result s e -> Seq FingerprintIssue) -> Fold (Seq FingerprintIssue) (Seq FingerprintIssue) -> Fold (Result s e) (Seq FingerprintIssue) forall a b r. (a -> b) -> Fold b r -> Fold a r Foldl.premap Result s e -> Seq FingerprintIssue forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq FingerprintIssue formatGitlabResult Fold (Seq FingerprintIssue) (Seq FingerprintIssue) forall a. Monoid a => Fold a a Foldl.mconcat) f (Result s e) results