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