module Hadolint.Formatter.JUnit ( hWrite ) where


import qualified Data.ByteString.Lazy.Char8 as B
import Data.Foldable
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Time as Time
import Hadolint.Formatter.Format
  ( Result (..),
    errorBundlePretty,
    errorPosition,
    severityText,
  )
import Hadolint.Rule (CheckFailure (..), RuleCode (..))
import Hadolint.Meta (getShortVersion)
import System.IO (Handle)
import Text.Megaparsec (TraversableStream)
import Text.Megaparsec.Error
  ( ParseErrorBundle,
    ShowErrorComponent,
  )
import Text.Megaparsec.Pos (sourceColumn, sourceLine, unPos)
import Text.Megaparsec.Stream (VisualStream)
import qualified Text.XML as XML


providerName :: Text.Text
providerName :: Text
providerName = Text
"Hadolint " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
getShortVersion

providerID :: Text.Text
providerID :: Text
providerID = Text
"hadolint"


hWrite ::
  (Foldable f, VisualStream s, TraversableStream s, ShowErrorComponent e) =>
  Handle -> f (Result s e) -> Maybe FilePath -> IO ()
hWrite :: forall (f :: * -> *) s e.
(Foldable f, VisualStream s, TraversableStream s,
 ShowErrorComponent e) =>
Handle -> f (Result s e) -> Maybe String -> IO ()
hWrite Handle
handle f (Result s e)
results Maybe String
maybeFilepath = do
  time <- IO UTCTime
Time.getCurrentTime
  B.hPutStr handle $ XML.renderLBS settings $ document time

  where
    settings :: RenderSettings
settings = RenderSettings
forall a. Default a => a
XML.def

    document :: Time.UTCTime -> XML.Document
    document :: UTCTime -> Document
document UTCTime
t =
      XML.Document
        { documentPrologue :: Prologue
documentPrologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing [],
          documentRoot :: Element
documentRoot = UTCTime -> Element
root UTCTime
t,
          documentEpilogue :: [Miscellaneous]
documentEpilogue = []

        }

    root :: Time.UTCTime -> XML.Element
    root :: UTCTime -> Element
root UTCTime
t =
      XML.Element
        { elementName :: Name
elementName = Name
"testsuites",
          elementAttributes :: Map Name Text
elementAttributes =
            [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Name
"id", UTCTime -> Text
runID UTCTime
t),
                (Name
"name", UTCTime -> Text
runName UTCTime
t),
                (Name
"time", Text
"0.001")
              ],
          elementNodes :: [Node]
elementNodes = (Result s e -> Node) -> [Result s e] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( Result s e -> Maybe String -> Node
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Node
`renderResult` Maybe String
maybeFilepath ) ( f (Result s e) -> [Result s e]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Result s e)
results )
        }

    runID :: Time.UTCTime -> Text.Text
    runID :: UTCTime -> Text
runID UTCTime
t =
      String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"%Y%m%d_%H%M%S" UTCTime
t

    runName :: Time.UTCTime -> Text.Text
    runName :: UTCTime -> Text
runName UTCTime
t =
      String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Time.formatTime TimeLocale
Time.defaultTimeLocale String
"Hadolint run at %Y-%m-%d %H:%M:%S" UTCTime
t

renderResult ::
  (VisualStream s, TraversableStream s, ShowErrorComponent e) =>
  Result s e -> Maybe FilePath -> XML.Node
renderResult :: forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Node
renderResult (Result Text
filename Seq (ParseErrorBundle s e)
errors Failures
checks) Maybe String
maybeFilepath =
  Element -> Node
XML.NodeElement XML.Element
    { elementName :: Name
elementName = Name
"testsuite",
      elementAttributes :: Map Name Text
elementAttributes =
        [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Name
"id", Text
providerID),
            (Name
"name", Text
providerName),
            (Name
"time", Text
"0.001"),
            (Name
"failures", String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Linenumber -> String
forall a. Show a => a -> String
show (Linenumber -> String) -> Linenumber -> String
forall a b. (a -> b) -> a -> b
$ [Node] -> Linenumber
forall a. [a] -> Linenumber
forall (t :: * -> *) a. Foldable t => t a -> Linenumber
length [Node]
findings),
            (Name
"errors", String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Linenumber -> String
forall a. Show a => a -> String
show Linenumber
parseErrors)
          ],
      elementNodes :: [Node]
elementNodes = [Node]
findings
    }
  where
    findings :: [Node]
findings = Seq Node -> [Node]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ( Seq Node
errorNodes Seq Node -> Seq Node -> Seq Node
forall a. Semigroup a => a -> a -> a
<> Seq Node
checkNodes )
    parseErrors :: Linenumber
parseErrors = Seq Node -> Linenumber
forall a. Seq a -> Linenumber
forall (t :: * -> *) a. Foldable t => t a -> Linenumber
length Seq Node
errorNodes
    errorNodes :: Seq Node
errorNodes = (ParseErrorBundle s e -> Node)
-> Seq (ParseErrorBundle s e) -> Seq Node
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( ParseErrorBundle s e -> Text -> Node
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> Text -> Node
`errorToNode` Text
file ) Seq (ParseErrorBundle s e)
errors
    checkNodes :: Seq Node
checkNodes = (CheckFailure -> Node) -> Failures -> Seq Node
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( CheckFailure -> Text -> Node
`checkToNode` Text
file ) Failures
checks
    file :: Text
file = if Maybe String -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe String
maybeFilepath then Text
filename else String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
maybeFilepath

errorToNode ::
  (VisualStream s, TraversableStream s, ShowErrorComponent e) =>
  ParseErrorBundle s e -> Text.Text -> XML.Node
errorToNode :: forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> Text -> Node
errorToNode ParseErrorBundle s e
err Text
filename =
  Element -> Node
XML.NodeElement XML.Element
    { elementName :: Name
elementName = Name
"testcase",
      elementAttributes :: Map Name Text
elementAttributes =
        [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Name
"id", Text
providerID Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".error"),
            (Name
"name", Text
"DL1000"),
            (Name
"time", Text
"0.001")
          ],
      elementNodes :: [Node]
elementNodes =
        [ Element -> Node
XML.NodeElement XML.Element
            { elementName :: Name
elementName = Name
"failure",
              elementAttributes :: Map Name Text
elementAttributes =
                [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (Name
"type", Text
"error"),
                    (Name
"message", Text
"parse error at line " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", column " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
column)
                  ],
              elementNodes :: [Node]
elementNodes =
                [ Text -> Node
XML.NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$
                    [Text] -> Text
Text.unlines
                      [ Text
"Parse Error in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
filename,
                        Text
"Line: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line,
                        Text
"Column: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
column,
                        Text
"Parse Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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 )
                      ]
                ]
            }
        ]
    }
  where
    line :: Text
line = String -> Text
Text.pack ( Linenumber -> String
forall a. Show a => a -> String
show (Linenumber -> String) -> Linenumber -> String
forall a b. (a -> b) -> a -> b
$ Pos -> Linenumber
unPos (Pos -> Linenumber) -> Pos -> Linenumber
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine (SourcePos -> Pos) -> SourcePos -> Pos
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle s e -> SourcePos
forall s e.
TraversableStream s =>
ParseErrorBundle s e -> SourcePos
errorPosition ParseErrorBundle s e
err )
    column :: Text
column = String -> Text
Text.pack ( Linenumber -> String
forall a. Show a => a -> String
show (Linenumber -> String) -> Linenumber -> String
forall a b. (a -> b) -> a -> b
$ Pos -> Linenumber
unPos (Pos -> Linenumber) -> Pos -> Linenumber
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn (SourcePos -> Pos) -> SourcePos -> Pos
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle s e -> SourcePos
forall s e.
TraversableStream s =>
ParseErrorBundle s e -> SourcePos
errorPosition ParseErrorBundle s e
err )

checkToNode :: CheckFailure -> Text.Text -> XML.Node
checkToNode :: CheckFailure -> Text -> Node
checkToNode CheckFailure {Linenumber
Text
RuleCode
DLSeverity
code :: RuleCode
severity :: DLSeverity
message :: Text
line :: Linenumber
line :: CheckFailure -> Linenumber
message :: CheckFailure -> Text
severity :: CheckFailure -> DLSeverity
code :: CheckFailure -> RuleCode
..} Text
filename =
  Element -> Node
XML.NodeElement XML.Element
    { elementName :: Name
elementName = Name
"testcase",
      elementAttributes :: Map Name Text
elementAttributes =
        [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Name
"id", Text
providerID Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".rule." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RuleCode -> Text
unRuleCode RuleCode
code),
            (Name
"time", Text
"0.001")
          ],
      elementNodes :: [Node]
elementNodes =
        [ Element -> Node
XML.NodeElement XML.Element
            { elementName :: Name
elementName = Name
"failure",
              elementAttributes :: Map Name Text
elementAttributes =
                [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (Name
"type", DLSeverity -> Text
severityText DLSeverity
severity),
                    (Name
"message", Text
message),
                    (Name
"id", RuleCode -> Text
unRuleCode RuleCode
code)
                  ],
              elementNodes :: [Node]
elementNodes =
                [ Text -> Node
XML.NodeContent (Text -> Node) -> Text -> Node
forall a b. (a -> b) -> a -> b
$
                    [Text] -> Text
Text.unlines
                      [ Text
"File: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
filename,
                        Text
"Line: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack ( Linenumber -> String
forall a. Show a => a -> String
show Linenumber
line ),
                        Text
"Category: Hadolint - Dockerfile Static Analysis",
                        DLSeverity -> Text
severityText DLSeverity
severity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message
                      ]
                ]
            }
        ]
    }