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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Text path, Key "lines" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= [Pair] -> Value object [Key "begin" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Int l, Key "end" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Int l]] toJSON (LocPos Text path Pos pos) = [Pair] -> Value object [Key "path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Text path, Key "positions" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= [Pair] -> Value object [Key "begin" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Pos pos, Key "end" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Pos pos]] data Pos = Pos { Pos -> Int line :: Int, Pos -> Int column :: Int } deriving (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 $cto :: forall x. Rep Pos x -> Pos $cfrom :: forall x. Pos -> Rep Pos x Generic) instance ToJSON Pos instance ToJSON Issue where toJSON :: Issue -> Value toJSON Issue {Text Location impact :: Text location :: Location description :: Text checkName :: Text impact :: Issue -> Text location :: Issue -> Location description :: Issue -> Text checkName :: Issue -> Text ..} = [Pair] -> Value object [ Key "type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= (Text "issue" :: Text.Text), Key "check_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Text checkName, Key "description" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Text description, Key "categories" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= ([Text "Bug Risk"] :: [Text.Text]), Key "location" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Location location, Key "severity" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Text impact ] instance ToJSON FingerprintIssue where toJSON :: FingerprintIssue -> Value toJSON FingerprintIssue {Digest SHA1 Issue fingerprint :: Digest SHA1 issue :: Issue fingerprint :: FingerprintIssue -> Digest SHA1 issue :: FingerprintIssue -> Issue ..} = [Pair] -> Value object [ Key "type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= (Text "issue" :: Text.Text), Key "fingerprint" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= forall a. Show a => a -> String show Digest SHA1 fingerprint, Key "check_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Issue -> Text checkName Issue issue, Key "description" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Issue -> Text description Issue issue, Key "categories" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= ([Text "Bug Risk"] :: [Text.Text]), Key "location" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv .= Issue -> Location location Issue issue, Key "severity" forall kv v. (KeyValue 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 forall a b. (a -> b) -> a -> b $ 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 forall a b. (a -> b) -> a -> b $ SourcePos -> String sourceName SourcePos pos) Pos {Int column :: Int line :: Int column :: Int line :: Int ..}, impact :: Text impact = DLSeverity -> Text severityText DLSeverity DLErrorC } where pos :: SourcePos pos = 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 line :: CheckFailure -> Int message :: CheckFailure -> Text severity :: CheckFailure -> DLSeverity code :: CheckFailure -> RuleCode line :: Int message :: Text severity :: DLSeverity code :: 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 = forall ba a. (ByteArrayAccess ba, HashAlgorithm a) => ba -> Digest a hash forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString B.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ToJSON a => a -> ByteString 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) = (forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> Issue errorToIssue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Seq (ParseErrorBundle s e) errors) forall a. Semigroup a => a -> a -> a <> (Text -> CheckFailure -> Issue checkToIssue Text filename 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> 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 = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall {a}. ToJSON a => a -> IO () output (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 ByteString -> IO () B.putStr (forall a. ToJSON a => a -> ByteString encode a value) ByteString -> IO () B.putStr (Word8 -> ByteString 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 = forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ 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 = 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 $ Seq FingerprintIssue flattened where flattened :: Seq FingerprintIssue 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. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Seq FingerprintIssue formatGitlabResult forall a. Monoid a => Fold a a Foldl.mconcat) f (Result s e) results