module Hadolint.Formatter.Checkstyle ( printResults, formatResult, ) where import qualified Control.Foldl as Foldl import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy.Char8 as B import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8Builder) import Hadolint.Formatter.Format ( Result (..), errorBundlePretty, errorPosition, severityText, ) import Hadolint.Rule (CheckFailure (..), DLSeverity (..), RuleCode (..)) import System.IO (stdout) import Text.Megaparsec (TraversableStream) import Text.Megaparsec.Error ( ParseErrorBundle, ShowErrorComponent, ) import Text.Megaparsec.Pos (sourceColumn, sourceLine, unPos) import Text.Megaparsec.Stream (VisualStream) data CheckStyle = CheckStyle { CheckStyle -> Int line :: Int, CheckStyle -> Int column :: Int, CheckStyle -> Text impact :: Text.Text, CheckStyle -> Text msg :: Text.Text, CheckStyle -> Text source :: Text.Text } errorToCheckStyle :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> CheckStyle errorToCheckStyle :: ParseErrorBundle s e -> CheckStyle errorToCheckStyle ParseErrorBundle s e err = CheckStyle :: Int -> Int -> Text -> Text -> Text -> CheckStyle CheckStyle { line :: Int line = Pos -> Int unPos (SourcePos -> Pos sourceLine SourcePos pos), column :: Int column = Pos -> Int unPos (SourcePos -> Pos sourceColumn SourcePos pos), impact :: Text impact = DLSeverity -> Text severityText DLSeverity DLErrorC, msg :: Text msg = String -> Text Text.pack (ParseErrorBundle s e -> String forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String errorBundlePretty ParseErrorBundle s e err), source :: Text source = Text "DL1000" } where pos :: SourcePos pos = ParseErrorBundle s e -> SourcePos forall s e. TraversableStream s => ParseErrorBundle s e -> SourcePos errorPosition ParseErrorBundle s e err ruleToCheckStyle :: CheckFailure -> CheckStyle ruleToCheckStyle :: CheckFailure -> CheckStyle ruleToCheckStyle 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 ..} = CheckStyle :: Int -> Int -> Text -> Text -> Text -> CheckStyle CheckStyle { line :: Int line = Int line, column :: Int column = Int 1, impact :: Text impact = DLSeverity -> Text severityText DLSeverity severity, msg :: Text msg = Text message, source :: Text source = RuleCode -> Text unRuleCode RuleCode code } toXml :: CheckStyle -> Builder.Builder toXml :: CheckStyle -> Builder toXml CheckStyle {Int Text source :: Text msg :: Text impact :: Text column :: Int line :: Int source :: CheckStyle -> Text msg :: CheckStyle -> Text impact :: CheckStyle -> Text column :: CheckStyle -> Int line :: CheckStyle -> Int ..} = Builder "<error " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder -> Builder attr Text "line" (Int -> Builder Builder.intDec Int line) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder -> Builder attr Text "column" (Int -> Builder Builder.intDec Int column) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder -> Builder attr Text "severity" (Text -> Builder encode Text impact) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder -> Builder attr Text "message" (Text -> Builder encode Text msg) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder -> Builder attr Text "source" (Text -> Builder encode Text source) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "/>" encode :: Text.Text -> Builder.Builder encode :: Text -> Builder encode = Text -> Builder encodeUtf8Builder (Text -> Builder) -> (Text -> Text) -> Text -> Builder forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> Text escape attr :: Text.Text -> Builder.Builder -> Builder.Builder attr :: Text -> Builder -> Builder attr Text name Builder value = Text -> Builder encodeUtf8Builder Text name Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "='" Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder value Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder "' " escape :: Text.Text -> Text.Text escape :: Text -> Text escape = (Char -> Text) -> Text -> Text Text.concatMap Char -> Text doEscape where doEscape :: Char -> Text doEscape Char c = if Char -> Bool isOk Char c then Char -> Text Text.singleton Char c else Text "&#" Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> String -> Text Text.pack (Int -> String forall a. Show a => a -> String show (Char -> Int ord Char c)) Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text ";" isOk :: Char -> Bool isOk Char x = ((Char -> Bool) -> Bool) -> [Char -> Bool] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any (\Char -> Bool check -> Char -> Bool check Char x) [Char -> Bool isAsciiUpper, Char -> Bool isAsciiLower, Char -> Bool isDigit, (Char -> String -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [Char ' ', Char '.', Char '/'])] formatResult :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Builder.Builder formatResult :: Result s e -> Builder formatResult (Result Text filename Seq (ParseErrorBundle s e) errors Failures checks) = Builder header Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder xmlBody Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder footer where xmlBody :: Builder xmlBody = Fold CheckStyle Builder -> Seq CheckStyle -> Builder forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b Foldl.fold ((CheckStyle -> Builder) -> Fold Builder Builder -> Fold CheckStyle Builder forall a b r. (a -> b) -> Fold b r -> Fold a r Foldl.premap CheckStyle -> Builder toXml Fold Builder Builder forall a. Monoid a => Fold a a Foldl.mconcat) Seq CheckStyle issues issues :: Seq CheckStyle issues = Seq CheckStyle checkstyleErrors Seq CheckStyle -> Seq CheckStyle -> Seq CheckStyle forall a. Semigroup a => a -> a -> a <> Seq CheckStyle checkstyleChecks checkstyleErrors :: Seq CheckStyle checkstyleErrors = (ParseErrorBundle s e -> CheckStyle) -> Seq (ParseErrorBundle s e) -> Seq CheckStyle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ParseErrorBundle s e -> CheckStyle forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> CheckStyle errorToCheckStyle Seq (ParseErrorBundle s e) errors checkstyleChecks :: Seq CheckStyle checkstyleChecks = (CheckFailure -> CheckStyle) -> Failures -> Seq CheckStyle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap CheckFailure -> CheckStyle ruleToCheckStyle Failures checks isEmpty :: Bool isEmpty = Failures -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null Failures checks Bool -> Bool -> Bool && Seq (ParseErrorBundle s e) -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null Seq (ParseErrorBundle s e) errors header :: Builder header = if Bool isEmpty then Builder "" else Builder "<file " Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Text -> Builder -> Builder attr Text "name" (Text -> Builder encode Text filename) Builder -> Builder -> Builder forall a. Semigroup a => a -> a -> a <> Builder ">" footer :: Builder footer = if Bool isEmpty then Builder "" else Builder "</file>" printResults :: (Foldable f, VisualStream s, TraversableStream s, ShowErrorComponent e) => f (Result s e) -> IO () printResults :: f (Result s e) -> IO () printResults f (Result s e) results = do ByteString -> IO () B.putStr ByteString header (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 () put f (Result s e) results ByteString -> IO () B.putStr ByteString footer where header :: ByteString header = ByteString "<?xml version='1.0' encoding='UTF-8'?><checkstyle version='4.3'>" footer :: ByteString footer = ByteString "</checkstyle>" put :: Result s e -> IO () put Result s e result = Handle -> Builder -> IO () Builder.hPutBuilder Handle stdout (Result s e -> Builder forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Builder formatResult Result s e result)