|
| 1 | +(** The Sarif format is a standardised output format for static analysis tools. https://docs.oasis-open.org/sarif/sarif/v2.1.0/sarif-v2.1.0.html *) |
| 2 | +open Prelude |
| 3 | + |
| 4 | +open SarifType |
| 5 | +open SarifRules |
| 6 | + |
| 7 | +module Region = SarifType.Region (* TODO: why is this needed if SarifType is opened? *) |
| 8 | + |
| 9 | + |
| 10 | +(*matches the Goblint severity to the Sarif property level.*) |
| 11 | +let severityToLevel (severity:Messages.Severity.t)= match severity with |
| 12 | + | Error -> "error" |
| 13 | + | Warning -> "warning" |
| 14 | + | Info -> "note" |
| 15 | + | Debug -> "none" |
| 16 | + | Success -> "none" |
| 17 | + |
| 18 | + |
| 19 | +let createMessageObject (text:String.t) = |
| 20 | + { |
| 21 | + Message.text=text; |
| 22 | + } |
| 23 | +(*A reportingDescriptor offers a lot of information about a Goblint rule *) |
| 24 | +let createReportingDescriptor categoryInformation = |
| 25 | + { |
| 26 | + ReportingDescriptor.ruleId=categoryInformation.ruleId; |
| 27 | + ReportingDescriptor.ruleName=categoryInformation.name; |
| 28 | + ReportingDescriptor.helpUri=categoryInformation.helpUri; |
| 29 | + ReportingDescriptor.help=(createMessageObject categoryInformation.helpText); |
| 30 | + ReportingDescriptor.shortDescription=(createMessageObject categoryInformation.shortDescription); |
| 31 | + ReportingDescriptor.fullDescription=(createMessageObject categoryInformation.longDescription); |
| 32 | + } |
| 33 | + |
| 34 | +let transformToReportingDescriptor (id:String.t)= |
| 35 | + createReportingDescriptor (getRuleInformation id) |
| 36 | + |
| 37 | +let (driverObject:ToolComponent.t) = |
| 38 | + { |
| 39 | + ToolComponent.name="Goblint"; |
| 40 | + ToolComponent.fullName= "Goblint static analyser"; |
| 41 | + ToolComponent.informationUri="https://goblint.in.tum.de/home"; |
| 42 | + ToolComponent.organization="TUM - i2 and UTartu - SWS"; |
| 43 | + ToolComponent.version=Version.goblint; |
| 44 | + ToolComponent.rules=List.map transformToReportingDescriptor (List.map (fun rule -> rule.name) rules) |
| 45 | + } |
| 46 | +let (toolObject:Tool.t) = |
| 47 | + { |
| 48 | + Tool.driver=driverObject; |
| 49 | + } |
| 50 | + |
| 51 | + |
| 52 | +(*returns the Rule corresponding to a message entry *) |
| 53 | +let getCategoryInformationID (tags:Messages.Tags.t) = |
| 54 | + let getCWE (tag:Messages.Tag.t) = match tag with |
| 55 | + | CWE cwe-> Some cwe; |
| 56 | + | Category cat -> None; |
| 57 | + in |
| 58 | + (* if a CWE is present only the CWE is used, since using multiple ones for the same result doesn' make sense. |
| 59 | + If only Categorys are present, all of them are displayed.*) |
| 60 | + match List.find_map_opt getCWE tags with |
| 61 | + | Some cwe -> string_of_int cwe; |
| 62 | + | None -> match tags with |
| 63 | + | [] -> "" |
| 64 | + | x::xs -> match x with |
| 65 | + |Category cat-> MessageCategory.categoryName cat |
| 66 | + | CWE c-> "" (*this case should not be reachable *) |
| 67 | + |
| 68 | + |
| 69 | +let createArtifact (uri:string) = |
| 70 | + { |
| 71 | + Artifact.location={ |
| 72 | + ArtifactLocation.uri=uri; |
| 73 | + } |
| 74 | + } |
| 75 | +let createArtifactObject (uri:string) = |
| 76 | + { |
| 77 | + ArtifactLocation.uri=uri; |
| 78 | + } |
| 79 | +let hasLocation (piece:Messages.Piece.t) = match piece.loc with |
| 80 | + |Some loc -> true |
| 81 | + |None -> false |
| 82 | +(*should only be called after hasLocation*) |
| 83 | +let deOptionalizeLocation (piece:Messages.Piece.t)= match piece.loc with |
| 84 | + | Some loc ->loc |
| 85 | + | None -> assert false |
| 86 | + |
| 87 | +let createPhysicalLocationObject (piece:Messages.Piece.t) = |
| 88 | + let createRegionObject (line,column)= |
| 89 | + { |
| 90 | + Region.startLine=line; |
| 91 | + Region.startColumn=column; |
| 92 | + Region.endLine=line+4; |
| 93 | + Region.endColumn=column+4; |
| 94 | + } |
| 95 | + in |
| 96 | + { |
| 97 | + Location.physicalLocation={ |
| 98 | + PhysicalLocation.artifactLocation= createArtifactObject (deOptionalizeLocation piece).file; |
| 99 | + PhysicalLocation.region=createRegionObject ((deOptionalizeLocation piece).line,(deOptionalizeLocation piece).column); |
| 100 | + } |
| 101 | + } |
| 102 | + |
| 103 | + |
| 104 | +let createLocationsObject (multiPiece:Messages.MultiPiece.t) = match multiPiece with |
| 105 | + | Single piece ->List.map createPhysicalLocationObject (List.filter hasLocation [piece]); |
| 106 | + | Group {group_text = n; pieces = e} ->List.map createPhysicalLocationObject (List.take 10 (List.filter hasLocation e)) |
| 107 | + |
| 108 | + |
| 109 | + |
| 110 | +let createResult (message:Messages.Message.t) = |
| 111 | + let getMessage (multiPiece:Messages.MultiPiece.t)= match multiPiece with |
| 112 | + | Single piece ->piece.text; |
| 113 | + | Group {group_text = n; pieces = e} ->n |
| 114 | + in |
| 115 | + { |
| 116 | + Result.ruleId=(getRuleInformation (getCategoryInformationID message.tags)).ruleId; |
| 117 | + Result.level=severityToLevel message.severity; |
| 118 | + Result.message=createMessageObject (getMessage message.multipiece); |
| 119 | + Result.locations=createLocationsObject message.multipiece; |
| 120 | + } |
| 121 | + |
| 122 | +let getFileLocation (multipiece:Messages.MultiPiece.t)= |
| 123 | + let getFile (loc:Cil.location) = |
| 124 | + loc.file |
| 125 | + in |
| 126 | + let toLocation = match multipiece with |
| 127 | + |
| 128 | + | Single piece ->[deOptionalizeLocation piece]; |
| 129 | + | Group {group_text = n; pieces = e} -> |
| 130 | + List.map deOptionalizeLocation (List.filter hasLocation e); |
| 131 | + in |
| 132 | + List.map getFile toLocation |
| 133 | + |
| 134 | +let collectAllFileLocations (msgList:Messages.Message.t list)= |
| 135 | + let getUris= |
| 136 | + List.flatten (List.map (fun (msg:Messages.Message.t)-> getFileLocation msg.multipiece) msgList) |
| 137 | + in |
| 138 | + let uniques x xs = if List.mem x xs then xs else x::xs; |
| 139 | + in |
| 140 | + List.fold_right uniques getUris [] |
| 141 | +let runObject msgList= |
| 142 | + { |
| 143 | + Run.invocations=[{ |
| 144 | + Invocation.commandLine=String.concat ", " (BatArray.to_list BatSys.argv) ; |
| 145 | + Invocation.executionSuccessful=true; |
| 146 | + }]; |
| 147 | + Run.artifacts= List.map createArtifact (collectAllFileLocations msgList); |
| 148 | + Run.tool=toolObject; |
| 149 | + Run.defaultSourceLanguage="C"; |
| 150 | + Run.results=List.map createResult (List.take 5000 msgList); |
| 151 | + } |
| 152 | + |
| 153 | +let sarifObject msgList={SarifLog.version="2.1.0"; |
| 154 | + SarifLog.schema="https://schemastore.azurewebsites.net/schemas/json/sarif-2.1.0-rtm.5.json"; |
| 155 | + SarifLog.runs=[runObject msgList] } |
| 156 | + |
| 157 | +let to_yojson msgList= [%to_yojson: SarifLog.t] (sarifObject msgList) |
0 commit comments