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 -> Maybe FilePath -> Builder.Builder
formatResult :: Result s e -> Maybe String -> Builder
formatResult (Result Text
filename Seq (ParseErrorBundle s e)
errors Failures
checks) Maybe String
filePathInReport = 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
    name :: Text
name = if Maybe String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe String
filePathInReport then Text
filename else Maybe String -> Text
getFilePath Maybe String
filePathInReport
    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
name) 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) -> Maybe FilePath ->
  IO ()
printResults :: f (Result s e) -> Maybe String -> IO ()
printResults f (Result s e)
results Maybe String
filePathInReport = 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 -> Maybe String -> Builder
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Builder
formatResult Result s e
result Maybe String
filePathInReport)

getFilePath :: Maybe FilePath -> Text.Text 
getFilePath :: Maybe String -> Text
getFilePath Maybe String
Nothing = Text
""
getFilePath (Just String
filePath) = [String] -> Text
toText [String
filePath]

toText :: [FilePath] -> Text.Text 
toText :: [String] -> Text
toText = (String -> Text) -> [String] -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> Text
Text.pack