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 [Text "path" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Text path, Text "lines" Text -> Value -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= [Pair] -> Value object [Text "begin" Text -> Int -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Int l, Text "end" Text -> Int -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Int l]] toJSON (LocPos Text path Pos pos) = [Pair] -> Value object [Text "path" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Text path, Text "positions" Text -> Value -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= [Pair] -> Value object [Text "begin" Text -> Pos -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Pos pos, Text "end" Text -> Pos -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 $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 [ Text "type" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= (Text "issue" :: Text.Text), Text "check_name" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Text checkName, Text "description" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Text description, Text "categories" Text -> [Text] -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= ([Text "Bug Risk"] :: [Text.Text]), Text "location" Text -> Location -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Location location, Text "severity" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 [ Text "type" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= (Text "issue" :: Text.Text), Text "fingerprint" Text -> String -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Digest SHA1 -> String forall a. Show a => a -> String show Digest SHA1 fingerprint, Text "check_name" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Issue -> Text checkName Issue issue, Text "description" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Issue -> Text description Issue issue, Text "categories" Text -> [Text] -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= ([Text "Bug Risk"] :: [Text.Text]), Text "location" Text -> Location -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Issue -> Location location Issue issue, Text "severity" Text -> Text -> Pair forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv .= Issue -> Text impact Issue issue ] errorToIssue :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> Issue errorToIssue :: ParseErrorBundle s e -> Issue errorToIssue ParseErrorBundle s e err = Issue :: Text -> Text -> Location -> Text -> Issue 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 -> Int -> Pos Pos {Int column :: Int line :: Int column :: Int line :: 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 line :: CheckFailure -> Int message :: CheckFailure -> Text severity :: CheckFailure -> DLSeverity code :: CheckFailure -> RuleCode line :: Int message :: Text severity :: DLSeverity code :: RuleCode ..} = Issue :: Text -> Text -> Location -> Text -> Issue 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 = ByteString -> Digest SHA1 forall ba a. (ByteArrayAccess ba, HashAlgorithm a) => ba -> Digest a hash (ByteString -> Digest SHA1) -> (Issue -> ByteString) -> Issue -> Digest SHA1 forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString B.toStrict (ByteString -> ByteString) -> (Issue -> ByteString) -> Issue -> ByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . Issue -> ByteString forall a. ToJSON a => a -> ByteString encode issueToFingerprintIssue :: Issue -> FingerprintIssue issueToFingerprintIssue :: Issue -> FingerprintIssue issueToFingerprintIssue Issue i = FingerprintIssue :: Issue -> Digest SHA1 -> FingerprintIssue 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 :: 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 :: 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 :: 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 ByteString -> IO () B.putStr (a -> ByteString 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 :: 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 :: f (Result s e) -> IO () printGitlabResults f (Result s e) results = ByteString -> IO () B.putStr (ByteString -> IO ()) -> (Seq FingerprintIssue -> ByteString) -> Seq FingerprintIssue -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . Seq FingerprintIssue -> ByteString forall a. ToJSON a => a -> ByteString 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