module Hadolint.Formatter.Codeclimate
  ( hWrite,
    hWriteGitLab,
  )
where

import qualified Control.Foldl as Foldl
import qualified Crypto.Hash.SHA1 as SHA1
import Data.Aeson hiding (Result)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as Char8
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 System.IO
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 -> ByteString
fingerprint :: Char8.ByteString
  }

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" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
path, Key
"lines" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"begin" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
l, Key
"end" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
l]]
  toJSON (LocPos Text
path Pos
pos) =
    [Pair] -> Value
object [Key
"path" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
path, Key
"positions" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Key
"begin" Key -> Pos -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Pos
pos, Key
"end" Key -> Pos -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> 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
$cfrom :: forall x. Pos -> Rep Pos x
from :: forall x. Pos -> Rep Pos x
$cto :: forall x. Rep Pos x -> Pos
to :: forall x. Rep Pos x -> Pos
Generic)

instance ToJSON Pos

instance ToJSON Issue where
  toJSON :: Issue -> Value
toJSON Issue {Text
Location
checkName :: Issue -> Text
description :: Issue -> Text
location :: Issue -> Location
impact :: Issue -> Text
checkName :: Text
description :: Text
location :: Location
impact :: Text
..} =
    [Pair] -> Value
object
      [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"issue" :: Text.Text),
        Key
"check_name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
checkName,
        Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
description,
        Key
"categories" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([Text
"Bug Risk"] :: [Text.Text]),
        Key
"location" Key -> Location -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Location
location,
        Key
"severity" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
impact
      ]

instance ToJSON FingerprintIssue where
  toJSON :: FingerprintIssue -> Value
toJSON FingerprintIssue {ByteString
Issue
issue :: FingerprintIssue -> Issue
fingerprint :: FingerprintIssue -> ByteString
issue :: Issue
fingerprint :: ByteString
..} =
    [Pair] -> Value
object
      [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"issue" :: Text.Text),
        Key
"fingerprint" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> String
Char8.unpack ByteString
fingerprint,
        Key
"check_name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Issue -> Text
checkName Issue
issue,
        Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Issue -> Text
description Issue
issue,
        Key
"categories" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ([Text
"Bug Risk"] :: [Text.Text]),
        Key
"location" Key -> Location -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Issue -> Location
location Issue
issue,
        Key
"severity" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e 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 (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
line :: Int
column :: Int
line :: Int
column :: 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 -> Maybe FilePath -> CheckFailure -> Issue
checkToIssue :: Text -> Maybe String -> CheckFailure -> Issue
checkToIssue Text
fileName Maybe String
filePathInReport CheckFailure {Int
Text
RuleCode
DLSeverity
code :: RuleCode
severity :: DLSeverity
message :: Text
line :: Int
line :: CheckFailure -> Int
message :: CheckFailure -> Text
severity :: CheckFailure -> DLSeverity
code :: CheckFailure -> RuleCode
..} =
  Issue
    { checkName :: Text
checkName = RuleCode -> Text
unRuleCode RuleCode
code,
      description :: Text
description = Text
message,
      location :: Location
location = Text -> Int -> Location
LocLine Text
reportFileName Int
line,
      impact :: Text
impact = DLSeverity -> Text
severityText DLSeverity
severity
    }
  where
    reportFileName :: Text
reportFileName = if Maybe String -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe String
filePathInReport then Text
fileName else Maybe String -> Text
getFilePath Maybe String
filePathInReport

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 -> Char8.ByteString
generateFingerprint :: Issue -> ByteString
generateFingerprint = ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (Issue -> ByteString) -> Issue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA1.hashlazy (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 :: Issue
issue = Issue
i,
      fingerprint :: ByteString
fingerprint = Issue -> ByteString
generateFingerprint Issue
i
    }

formatResult :: (VisualStream s, TraversableStream s, ShowErrorComponent e) => Result s e -> Maybe FilePath -> Seq Issue
formatResult :: forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Seq Issue
formatResult (Result Text
filename Seq (ParseErrorBundle s e)
errors Failures
checks) Maybe String
filePathInReport = (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 -> Maybe String -> CheckFailure -> Issue
checkToIssue Text
filename Maybe String
filePathInReport (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 -> Maybe FilePath ->
  Seq FingerprintIssue
formatGitLabResult :: forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Seq FingerprintIssue
formatGitLabResult Result s e
result Maybe String
filePathInReport = Issue -> FingerprintIssue
issueToFingerprintIssue (Issue -> FingerprintIssue) -> Seq Issue -> Seq FingerprintIssue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result s e -> Maybe String -> Seq Issue
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Seq Issue
formatResult Result s e
result Maybe String
filePathInReport

printResult :: (VisualStream s, TraversableStream s, ShowErrorComponent e) =>
  Handle -> Result s e -> Maybe FilePath -> IO ()
printResult :: forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Handle -> Result s e -> Maybe String -> IO ()
printResult Handle
handle Result s e
result Maybe String
filePathInReport = (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 -> Maybe String -> Seq Issue
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Seq Issue
formatResult Result s e
result Maybe String
filePathInReport)
  where
    output :: a -> IO ()
output a
value = do
      Handle -> ByteString -> IO ()
B.hPutStr Handle
handle (a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
value)
      Handle -> ByteString -> IO ()
B.hPutStr Handle
handle (Word8 -> ByteString
B.singleton Word8
0x00)

hWrite :: (VisualStream s, TraversableStream s, ShowErrorComponent e, Foldable f) =>
  Handle -> f (Result s e) -> Maybe FilePath -> IO ()
hWrite :: forall s e (f :: * -> *).
(VisualStream s, TraversableStream s, ShowErrorComponent e,
 Foldable f) =>
Handle -> f (Result s e) -> Maybe String -> IO ()
hWrite Handle
handle f (Result s e)
results Maybe String
filePathInReport = IO ()
flattened
  where
    flattened :: IO ()
flattened = Fold (Result s e) (Maybe String -> IO ())
-> f (Result s e) -> Maybe String -> IO ()
forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b
Foldl.fold ((Result s e -> Maybe String -> IO ())
-> Fold (Maybe String -> IO ()) (Maybe String -> IO ())
-> Fold (Result s e) (Maybe String -> IO ())
forall a b r. (a -> b) -> Fold b r -> Fold a r
Foldl.premap ( Handle -> Result s e -> Maybe String -> IO ()
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Handle -> Result s e -> Maybe String -> IO ()
printResult Handle
handle ) Fold (Maybe String -> IO ()) (Maybe String -> IO ())
forall a. Monoid a => Fold a a
Foldl.mconcat) f (Result s e)
results Maybe String
filePathInReport

hWriteGitLab ::
  (Foldable f, VisualStream s, TraversableStream s, ShowErrorComponent e) =>
  Handle -> f (Result s e) -> Maybe FilePath -> IO ()
hWriteGitLab :: forall (f :: * -> *) s e.
(Foldable f, VisualStream s, TraversableStream s,
 ShowErrorComponent e) =>
Handle -> f (Result s e) -> Maybe String -> IO ()
hWriteGitLab Handle
handle f (Result s e)
results Maybe String
filePathInReport = Handle -> ByteString -> IO ()
B.hPutStr Handle
handle (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) (Maybe String -> Seq FingerprintIssue)
-> f (Result s e) -> Maybe String -> Seq FingerprintIssue
forall (f :: * -> *) a b. Foldable f => Fold a b -> f a -> b
Foldl.fold ((Result s e -> Maybe String -> Seq FingerprintIssue)
-> Fold
     (Maybe String -> Seq FingerprintIssue)
     (Maybe String -> Seq FingerprintIssue)
-> Fold (Result s e) (Maybe String -> Seq FingerprintIssue)
forall a b r. (a -> b) -> Fold b r -> Fold a r
Foldl.premap Result s e -> Maybe String -> Seq FingerprintIssue
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
Result s e -> Maybe String -> Seq FingerprintIssue
formatGitLabResult Fold
  (Maybe String -> Seq FingerprintIssue)
  (Maybe String -> Seq FingerprintIssue)
forall a. Monoid a => Fold a a
Foldl.mconcat) f (Result s e)
results 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 m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> Text
Text.pack