Commit a4fde52a authored by Andre Maroneze's avatar Andre Maroneze 💬
Browse files

Merge branch 'feature/andre/update-sarif' into 'master'

Feature/andre/update sarif

See merge request frama-c/frama-c!2754
parents 67c9b34c 726be74c
......@@ -20,6 +20,8 @@
(* *)
(**************************************************************************)
module Pervasives_string = String
include Plugin.Register(
struct
let name = "Markdown report"
......@@ -27,14 +29,6 @@ include Plugin.Register(
let help = "generates a report in markdown format"
end)
module Output = String(
struct
let option_name = "-mdr-out"
let arg_name = "f"
let default = "report.md"
let help = "sets the name of the output file to <f>"
end)
module Generate = String(
struct
let option_name = "-mdr-gen"
......@@ -45,6 +39,26 @@ module Generate = String(
none (default), md, draft and sarif"
end)
module Output : Parameter_sig.String =
struct
include String(
struct
let option_name = "-mdr-out"
let arg_name = "f"
let default = "report"
let help = "sets the name of the output file to <f>.@ \
If <f> has no extension, it is chosen automatically based on \
the report kind"
end)
let get () =
let s = get () in
if Pervasives_string.contains (Filename.basename s) '.' then s
else
let kind = Generate.get () in
let ext = if kind = "sarif" then ".sarif" else ".md" in
s ^ ext
end
let () =
Generate.set_possible_values [ "none"; "md"; "draft"; "sarif" ]
......
This diff is collapsed.
......@@ -29,8 +29,7 @@ let frama_c_sarif =
let fullName = name ^ "-" ^ version in
let downloadUri = "https://frama-c.com/download.html" in
Tool.create
~name ~version ~semanticVersion ~fullName ~downloadUri ()
(Driver.create ~name ~version ~semanticVersion ~fullName ~downloadUri ())
let get_remarks () =
let f = Mdr_params.Remarks.get () in
......@@ -63,22 +62,32 @@ let gen_remark alarm =
[ Block
[ Text
(plain
(Printf.sprintf "This alarms represents a potential %s."
(Printf.sprintf "This alarm represents a potential %s."
(Alarms.get_description alarm)
)
)
]
]
let level_of_status =
let kind_of_status =
let open Property_status.Feedback in
let open Sarif.Result_level in
let open Sarif.Result_kind in
function
| Never_tried -> notApplicable
| Considered_valid | Valid | Valid_under_hyp | Valid_but_dead -> pass
| Unknown | Unknown_but_dead -> warning
| Unknown | Unknown_but_dead -> open_
| Invalid | Invalid_under_hyp | Invalid_but_dead -> fail
| Inconsistent -> review
let level_of_status =
let open Property_status.Feedback in
let open Sarif.Result_level in
function
| Never_tried -> none
| Considered_valid | Valid | Valid_under_hyp | Valid_but_dead -> none
| Unknown | Unknown_but_dead -> none
| Invalid | Invalid_under_hyp | Invalid_but_dead -> error
| Inconsistent -> note
| Inconsistent -> none
let make_message alarm annot remark =
let open Markdown in
......@@ -92,11 +101,15 @@ let make_message alarm annot remark =
| [] -> summary :: gen_remark alarm
| _ -> summary :: remark
in
let richText =
let markdown =
String.trim
(Format.asprintf "@[%a@]" (Markdown.pp_elements ~page:"") markdown)
in
Message.create ~text ~richText ()
Message.create ~text ~markdown ()
let opt_physical_location_of_loc loc =
if loc = Cil_datatype.Location.unknown then []
else [ Location.of_loc loc ]
let gen_results remarks =
let treat_alarm _e kf s ~rank:_ alarm annot (i, rules, content) =
......@@ -106,12 +119,13 @@ let gen_results remarks =
Datatype.String.Map.add ruleId (Alarms.get_description alarm) rules
in
let label = "Alarm-" ^ string_of_int i in
let kind = kind_of_status (Property_status.Feedback.get prop) in
let level = level_of_status (Property_status.Feedback.get prop) in
let remark = get_remark remarks label in
let message = make_message alarm annot remark in
let locations = [ Location.of_loc (Cil_datatype.Stmt.loc s) ] in
let locations = opt_physical_location_of_loc (Cil_datatype.Stmt.loc s) in
let res =
Sarif_result.create ~level ~ruleId ~message ~locations ()
Sarif_result.create ~kind ~level ~ruleId ~message ~locations ()
in
(i+1, rules, res :: content)
in
......@@ -128,12 +142,14 @@ let make_ip_message ip =
let text = Format.asprintf "@[%a.@]" Property.short_pretty ip in
Message.plain_text ~text ()
let user_annot_id = "user-spec"
let gen_status ip =
let status = Property_status.Feedback.get ip in
let level = level_of_status status in
let locations = [ Location.of_loc (Property.location ip) ] in
let locations = opt_physical_location_of_loc (Property.location ip) in
let message = make_ip_message ip in
Sarif_result.create ~level ~locations ~message ()
Sarif_result.create ~ruleId:user_annot_id ~level ~locations ~message ()
let gen_statuses () =
let f ip content =
......@@ -141,29 +157,27 @@ let gen_statuses () =
in
List.rev (Property_status.fold f [])
let gen_files () =
let gen_artifacts () =
let add_src_file f =
let key =
let fname = Filepath.Normalized.to_pretty_string f in
Filename.chop_extension (Filename.basename fname)
in
let fileLocation = FileLocation.create ~uri:(f :> string) () in
let uri = (f:Filepath.Normalized.t :> string) in
let location = ArtifactLocation.create ~uri () in
let roles = [ Role.analysisTarget ] in
let mimeType = "text/x-csrc" in
key, File.create ~fileLocation ~roles ~mimeType ()
Artifact.create ~location ~roles ~mimeType ()
in
List.map add_src_file (Kernel.Files.get ())
let add_rule id desc l =
let text = desc ^ "." in
let shortDescription = Message.plain_text ~text () in
let rule = Rule.create ~id ~shortDescription () in
(id, rule) :: l
let shortDescription = MultiformatMessageString.create ~text () in
let rule = ReportingDescriptor.create ~id ~shortDescription () in
rule :: l
let make_rule_dictionary rules = Datatype.String.Map.fold add_rule rules []
let make_taxonomies rules = Datatype.String.Map.fold add_rule rules []
let gen_run remarks =
let tool = frama_c_sarif in
let name = "frama-c" in
let invocations = [gen_invocation ()] in
let rules, results = gen_results remarks in
let user_annot_results = gen_statuses () in
......@@ -172,13 +186,13 @@ let gen_run remarks =
| [] -> rules
| _ ->
Datatype.String.Map.add
"user-spec" "User written ACSL specification" rules
user_annot_id "User-written ACSL specification" rules
in
let rules = make_rule_dictionary rules in
let resources = Resources.create ~rules () in
let rules = make_taxonomies rules in
let taxonomies = [ToolComponent.create ~name ~rules ()] in
let results = results @ user_annot_results in
let files = gen_files () in
Run.create ~tool ~invocations ~results ~resources ~files ()
let artifacts = gen_artifacts () in
Run.create ~tool ~invocations ~results ~taxonomies ~artifacts ()
let generate () =
let remarks = get_remarks () in
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment