(analyzer): add analyses and injection tests

src/analyzer/analysis/callers.ml

@@ -35,10 +35,10 @@ let compute_call_arguments (callers : t) (mdg : Mdg.t) (l_func : Node.t)
       ls_args |> List.filter_map f |> List.iter (add callers l_param) )
 
 let compute_call (callers : t) (mdg : Mdg.t) (l_call : Node.t) : unit =
-  let l_func = Mdg.get_call_function mdg l_call in
-  Fun.flip List.iter l_func (fun l_func' ->
-      add callers l_func' l_call;
-      compute_call_arguments callers mdg l_func' l_call )
+  let ls_func = Mdg.get_called_functions mdg l_call in
+  Fun.flip List.iter ls_func (fun l_func ->
+      add callers l_func l_call;
+      compute_call_arguments callers mdg l_func l_call )
 
 let compute (mdg : Mdg.t) : t =
   let callers = create () in

src/analyzer/analysis/interactability.ml

@@ -32,6 +32,9 @@ let mem (interactability : t) (node : Node.t) : bool =
 let find_opt (interactability : t) (node : Node.t) : Interaction.t option =
   Option.map snd (Hashtbl.find_opt interactability node.uid)
 
+let find (interactability : t) (node : Node.t) : Interaction.t =
+  Option.value ~default:[] (find_opt interactability node)
+
 let replace (interactability : t) (node : Node.t) (interaction : Interaction.t)
     : unit =
   Hashtbl.replace interactability node.uid (node, interaction)
@@ -83,7 +86,7 @@ let rec compute_object (interactability : t) (mdg : Mdg.t)
 
 let set_taint (mdg : Mdg.t) (l_taint : Node.t) (node : Node.t) : unit =
   match node.kind with
-  | Object _ | Function _ | Parameter _ ->
+  | Object _ | Function _ | Parameter _ | TaintSink _ ->
     Mdg.add_edge mdg (Edge.create_dependency () l_taint node)
   | _ -> ()
 

src/analyzer/analysis/reachability.ml

@@ -5,20 +5,21 @@ module Source = struct
   type t =
     | Param of Node.t * string option list
     | Ret of Node.t
-    | Tainted
+    | TaintSink of Node.t
+    | TaintSource
 
   let id : t -> int = function
-    | Param (n, _) | Ret n -> n.uid
-    | Tainted -> Location.taint_source_loc ()
+    | Param (n, _) | Ret n | TaintSink n -> n.uid
+    | TaintSource -> Location.taint_source_loc ()
 
+  let is_taint_source : t -> bool = function TaintSource -> true | _ -> false
   let hash (src : t) : int = Location.hash (id src)
   let equal (src1 : t) (src2 : t) : bool = Location.equal (id src1) (id src2)
   let compare (src1 : t) (src2 : t) : int = Location.compare (id src1) (id src2)
 
   let extend (prop : string option) : t -> t = function
     | Param (node, props) -> Param (node, props @ [ prop ])
-    | Ret _ as reach -> reach
-    | Tainted as tainted -> tainted
+    | source -> source
 
   let pp_props (ppf : Fmt.t) (props : string option list) =
     let pp_prop ppf prop = Fmt.pp_str ppf (Option.value ~default:"*" prop) in
@@ -29,12 +30,13 @@ module Source = struct
     | Param (node, props) ->
       Fmt.fmt ppf "P(%s%a)" (Node.name node) pp_props props
     | Ret node -> Fmt.fmt ppf "Ret(%s)" (Node.name node)
-    | Tainted -> Fmt.pp_str ppf "Tainted"
+    | TaintSink node -> Fmt.fmt ppf "Sink(%s)" (Node.name node)
+    | TaintSource -> Fmt.pp_str ppf "TaintSource"
 
   let str (reach : t) : string = Fmt.str "%a" pp reach [@@inline]
 end
 
-module Set = struct
+module Sources = struct
   include Set.Make (struct
     type elt = Source.t
 
@@ -48,60 +50,74 @@ module Set = struct
   let str (nodes : t) : string = Fmt.str "%a" pp nodes [@@inline]
 end
 
-type t = (Location.t, Set.t) Hashtbl.t
+type t = (Location.t, Sources.t) Hashtbl.t
 
 let create () : t = Hashtbl.create Config.(!dflt_htbl_sz)
 
 let mem (reachability : t) (node : Node.t) : bool =
   Hashtbl.mem reachability node.uid
 
-let find_opt (reachability : t) (node : Node.t) : Set.t option =
+let find_opt (reachability : t) (node : Node.t) : Sources.t option =
   Hashtbl.find_opt reachability node.uid
 
-let find (reachability : t) (node : Node.t) : Set.t =
-  Option.value ~default:Set.empty (find_opt reachability node)
+let find (reachability : t) (node : Node.t) : Sources.t =
+  Option.value ~default:Sources.empty (find_opt reachability node)
 
-let replace (reachability : t) (node : Node.t) (sources : Set.t) : unit =
+let replace (reachability : t) (node : Node.t) (sources : Sources.t) : unit =
   Hashtbl.replace reachability node.uid sources
 
-let add (reachability : t) (node : Node.t) (source : Source.t) : bool * Set.t =
-  let sources = Set.singleton source in
+let set (reachability : t) (node : Node.t) (sources : Sources.t) :
+    bool * Sources.t =
   replace reachability node sources;
   (true, sources)
 
+let is_tainted (mdg : Mdg.t) (node : Node.t) =
+  let f edge = Edge.is_dependency edge && Node.is_taint_source edge.tar in
+  let edges = Mdg.get_trans mdg node.uid in
+  if Edge.Set.exists f edges then Sources.singleton TaintSource
+  else Sources.empty
+
 let rec compute_node (reachability : t) (mdg : Mdg.t) (ls_visited : Node.Set.t)
-    (props : string option list) (node : Node.t) : bool * Set.t =
-  match (find_opt reachability node, node.kind) with
-  | (Some sources, _) -> (true, sources)
-  | (None, TaintSource) -> add reachability node Tainted
-  | (None, Parameter _) -> add reachability node (Param (node, []))
-  | (None, Return _) -> add reachability node (Ret node)
-  | (None, _) ->
+    (props : string option list) (node : Node.t) : bool * Sources.t =
+  match find_opt reachability node with
+  | Some sources -> (true, sources)
+  | None -> compute_unknown_node reachability mdg ls_visited props node
+
+and compute_unknown_node (reachability : t) (mdg : Mdg.t)
+    (ls_visited : Node.Set.t) (props : string option list) (node : Node.t) :
+    bool * Sources.t =
+  let add_f source = Sources.add source (is_tainted mdg node) in
+  match node.kind with
+  | TaintSource -> set reachability node (Sources.singleton TaintSource)
+  | Parameter _ -> set reachability node (add_f (Param (node, [])))
+  | Return _ -> set reachability node (add_f (Ret node))
+  | TaintSink _ -> set reachability node (add_f (TaintSink node))
+  | _ ->
     let ls_visited' = Node.Set.add node ls_visited in
     let res = compute_edges reachability mdg ls_visited' props node in
     let (resolved, sources) = res in
     if resolved then replace reachability node sources;
     res
 
 and compute_edges (reachability : t) (mdg : Mdg.t) (ls_visited : Node.Set.t)
-    (props : string option list) (node : Node.t) : bool * Set.t =
+    (props : string option list) (node : Node.t) : bool * Sources.t =
   let edges = Mdg.get_trans mdg node.uid in
-  Fun.flip2 Edge.Set.fold edges (true, Set.empty)
+  Fun.flip2 Edge.Set.fold edges (true, Sources.empty)
     (fun edge (resolved, sources) ->
       match (Node.Set.mem edge.tar ls_visited, edge.kind) with
-      | (true, _) -> (false, Set.union sources (find reachability edge.tar))
+      | (true, _) -> (false, Sources.union sources (find reachability edge.tar))
       | (false, (Dependency | Argument _)) ->
         let (resolved', sources') =
           compute_node reachability mdg ls_visited props edge.tar in
-        (resolved && resolved', Set.union sources sources')
+        (resolved && resolved', Sources.union sources sources')
       | (false, Property prop) ->
         let (resolved', sources') =
           compute_node reachability mdg ls_visited props edge.tar in
-        let sources'' = Set.map (Source.extend prop) sources' in
-        (resolved && resolved', Set.union sources sources'')
-      | _ -> (true, Set.empty) )
+        let sources'' = Sources.map (Source.extend prop) sources' in
+        (resolved && resolved', Sources.union sources sources'')
+      | _ -> (true, Sources.empty) )
 
-let compute (reachability : t) (mdg : Mdg.t) (node : Node.t) : Set.t =
+let compute (reachability : t) (mdg : Mdg.t) (node : Node.t) : Sources.t =
   match find_opt reachability node with
   | Some sources -> sources
   | None ->

src/analyzer/analysis_engine.ml

@@ -1,20 +1,81 @@
-(* open Graphjs_base *)
+open Graphjs_base
+open Graphjs_ast
 open Graphjs_mdg
 
+module Worklist = struct
+  type t =
+    { queue : Node.t Queue.t
+    ; visited : Node.Set.t
+    ; result : Node.t option
+    }
+
+  let create () : t =
+    { queue = Queue.create (); visited = Node.Set.empty; result = None }
+
+  let dequeue (worklist : t) : Node.t option = Queue.take_opt worklist.queue
+
+  let enqueue (worklist : t) (node : Node.t) : t =
+    if not (Node.Set.mem node worklist.visited) then
+      let _ = Queue.push node worklist.queue in
+      { worklist with visited = Node.Set.add node worklist.visited }
+    else worklist
+
+  let get_result (worklist : t) : Node.t option = worklist.result
+
+  let set_result (worklist : t) (result : Node.t) =
+    { worklist with result = Some result }
+end
+
 type t =
   { mdg : Mdg.t
   ; properties : Properties.t
   ; callers : Callers.t
   ; interactability : Interactability.t
   ; reachability : Reachability.t
+  ; worklist : Worklist.t
   }
 
 let initialize (mdg : Mdg.t) : t =
   let properties = Properties.create () in
   let callers = Callers.compute mdg in
   let interactability = Interactability.compute mdg in
   let reachability = Reachability.create () in
-  { mdg; properties; callers; interactability; reachability }
+  let worklist = Worklist.create () in
+  { mdg; properties; callers; interactability; reachability; worklist }
+
+let rec run (f : Node.t -> t) (engine : t) : Node.t option =
+  match Worklist.get_result engine.worklist with
+  | Some _ as result -> result
+  | None -> (
+    match Worklist.dequeue engine.worklist with
+    | Some node -> f node |> (run f [@tailcall])
+    | None -> None )
+
+let enqueue (engine : t) (node : Node.t) : t =
+  { engine with worklist = Worklist.enqueue engine.worklist node }
+
+let result (engine : t) (node : Node.t) : t =
+  { engine with worklist = Worklist.set_result engine.worklist node }
+
+let vulnerability (engine : t) (sink : Tainted.sink) (node : Node.t) :
+    Vulnerability.t =
+  (* HACK: vulnerabilities without a lineno are update with the lineno of the corresponding property *)
+  (* this is useful, for example, when a sensitive sink is exported by the module *)
+  let vuln = Vulnerability.make sink node in
+  if vuln.line == Region.invalid then
+    Mdg.object_of_property engine.mdg node
+    |> List.hd_opt
+    |> Option.fold ~none:vuln ~some:(Vulnerability.update vuln)
+  else vuln
+
+let get_sinks (engine : t) : Node.Set.t =
+  Fun.flip2 Node.Set.fold engine.mdg.calls Node.Set.empty (fun l_call acc ->
+      let ls_func = Mdg.get_called_functions engine.mdg l_call in
+      Fun.flip2 List.fold_right ls_func acc (fun l_func acc ->
+          if Node.is_taint_sink l_func then Node.Set.add l_func acc else acc ) )
+
+let is_attacker_controlled (reachability : Reachability.Sources.t) : bool =
+  Reachability.Sources.exists Reachability.Source.is_taint_source reachability
 
 let lookup (engine : t) (node : Node.t) (prop : string option) : Node.Set.t =
   Properties.compute engine.properties engine.mdg node [ prop ]
@@ -26,5 +87,8 @@ let nested_lookup (engine : t) (node : Node.t) (props : string option list) :
 let callers (engine : t) (node : Node.t) : Node.Set.t =
   Callers.find engine.callers node
 
-let reaching (engine : t) (node : Node.t) : Reachability.Set.t =
+let interaction (engine : t) (node : Node.t) : Interactability.Interaction.t =
+  Interactability.find engine.interactability node
+
+let sources (engine : t) (node : Node.t) : Reachability.Sources.t =
   Reachability.compute engine.reachability engine.mdg node

src/analyzer/analyzer.ml

@@ -1,43 +1,59 @@
 open Graphjs_base
 open Graphjs_mdg
+module Worklist = Analysis_engine.Worklist
 
-let run_injection_returners (_engine : Analysis_engine.t) (_l_return : Node.t) :
-    Node.Set.t =
-  Node.Set.empty
-(* 
-  let return_reachability = Reachability.compute l_return
-  forall reachable in return_reachability:
-    if is_param reachable then return reachable
-    if is_return reachable then run_injection_returners reachable
-*)
-
-let run_injection_sink (_engine : Analysis_engine.t) (_l_sink : Node.t) :
-    Vulnerability.t option =
-  None
-(* 
-  let sink_reachability = Reachability.compute l_sink
-  if List.mem TaintSource sink_reachability then Some vulnerability
-  else
-    foreach reachable in sink_reachability:
-      if is_call reachable then
-        let callers = Callers.compute reachable in
-        forall callers: run_injection_sink caller
-      if is_return reachable then
-        let returns_reachability = run_injection_returners reachable in
-        forall returns_reachability = run_injection_sink returns_reachability    
-*)
-
-let run_injection (_engine : Analysis_engine.t) : Vulnerability.t list = []
-(* 
-  foreach sink in mdg:
-    run_injection_sink
-*)
+let run_injection_param (engine : Analysis_engine.t) (l_param : Node.t)
+    (_props : string option list) : Analysis_engine.t =
+  let callers = Analysis_engine.callers engine l_param in
+  Log.debug "%a" Node.Set.pp callers;
+  engine
+
+let run_injection_return (engine : Analysis_engine.t) (_l_retn : Node.t) :
+    Analysis_engine.t =
+  engine
+
+let run_injection_sink (engine : Analysis_engine.t) (l_sink : Node.t) :
+    Analysis_engine.t =
+  match l_sink.kind with
+  | TaintSink sink ->
+    let args = Tainted.args sink in
+    let callers = Analysis_engine.callers engine l_sink in
+    Fun.flip2 Node.Set.fold callers engine (fun l_call acc ->
+        Fun.flip2 List.fold_left acc args (fun acc idx ->
+            let ls_arg = Mdg.get_argument engine.mdg l_call idx in
+            Fun.flip2 List.fold_left acc ls_arg (fun acc l_arg ->
+                Analysis_engine.enqueue acc l_arg ) ) )
+  | _ -> Log.fail "unexpected node kind in injection sink"
+
+let run_injection_source (engine : Analysis_engine.t) :
+    Reachability.Source.t -> Analysis_engine.t = function
+  | Param (l_param, props) -> run_injection_param engine l_param props
+  | Ret l_retn -> run_injection_return engine l_retn
+  | TaintSink l_sink -> run_injection_sink engine l_sink
+  | TaintSource -> Log.fail "unexpected taint_source information source"
+
+let run_injection_node (engine : Analysis_engine.t) : Node.t option =
+  Fun.flip Analysis_engine.run engine (fun node ->
+      let sources = Analysis_engine.sources engine node in
+      if Analysis_engine.is_attacker_controlled sources then
+        Analysis_engine.result engine node
+      else
+        Reachability.Sources.fold (Fun.flip run_injection_source) sources engine )
+
+let run_injection (engine : Analysis_engine.t) : Vulnerability.t list =
+  let l_sinks = Analysis_engine.get_sinks engine in
+  Fun.flip2 Node.Set.fold l_sinks [] (fun l_sink vulns ->
+      let engine' = Analysis_engine.enqueue engine l_sink in
+      let sink = Node.sink l_sink in
+      match run_injection_node engine' with
+      | None -> vulns
+      | Some node -> Analysis_engine.vulnerability engine' sink node :: vulns )
 
 let run_prototype (_engine : Analysis_engine.t) : Vulnerability.t list = []
 
 let run (engine : Analysis_engine.t) : Vulnerability.t list =
-  Log.debug "Interactability:@\n%a@." Interactability.pp engine.interactability;
-  Log.debug "Tainted:@\n%a" Mdg.pp engine.mdg;
+  Log.debug "Graph:@\n%a@\n" Mdg.pp engine.mdg;
+  Log.debug "Interactability:@\n%a@\n" Interactability.pp engine.interactability;
   let injection_vulns = run_injection engine in
-  let prototype_vulns = run_injection engine in
+  let prototype_vulns = run_prototype engine in
   injection_vulns @ prototype_vulns