[traces] adding Source.Make functor for easier source creation

Summary:
There's a lot of boilerplate work to be done when adding a new kind of source.
This diff tries to reduce the boilerplate by making a functor do all the work.
The functor:
(1) adds a notion of "footprint kind" to the source
(2) packages the source with a call site

Reviewed By: jvillard

Differential Revision: D4349224

fbshipit-source-id: 5e1701a

infer/src/checkers/Source.ml

@@ -9,6 +9,25 @@
 
 open! IStd
 
+module F = Format
+
+let all_formals_untainted pdesc =
+  let make_untainted (name, typ) =
+    name, typ, None in
+  IList.map make_untainted (Procdesc.get_formals pdesc)
+
+module type Kind = sig
+  include TraceElem.Kind
+
+  val unknown : t
+
+  val get : Procname.t -> t option
+
+  (** return each formal of the function paired with either Some(kind) if the formal is a taint
+      source, or None if the formal is not a taint source *)
+  val get_tainted_formals : Procdesc.t -> (Mangled.t * Typ.t * t option) list
+end
+
 module type S = sig
   include TraceElem.S
 
@@ -23,6 +42,69 @@ module type S = sig
   val get_tainted_formals : Procdesc.t -> (Mangled.t * Typ.t * t option) list
 end
 
+module Make (Kind : Kind) = struct
+  module Kind = Kind
+
+  type kind =
+    | Normal of Kind.t (** known source returned directly or transitively from a callee *)
+    | Footprint of AccessPath.t (** unknown source read from the environment *)
+  [@@ deriving compare]
+
+  let pp_kind fmt = function
+    | Normal kind -> Kind.pp fmt kind
+    | Footprint ap -> F.fprintf fmt "Footprint(%a)" AccessPath.pp ap
+
+  type t =
+    {
+      kind : kind;
+      site : CallSite.t;
+    } [@@deriving compare]
+
+  let is_footprint t = match t.kind with
+    | Footprint _ -> true
+    | _ -> false
+
+  let get_footprint_access_path t = match t.kind with
+    | Footprint ap -> Some ap
+    | _ -> None
+
+  let call_site t =
+    t.site
+
+  let kind t = match t.kind with
+    | Normal kind -> kind
+    | Footprint _ -> Kind.unknown
+
+  let make kind site =
+    { site; kind = Normal kind; }
+
+  let make_footprint ap site =
+    let kind = Footprint ap in
+    { site; kind; }
+
+  let get site = match Kind.get (CallSite.pname site) with
+    | Some kind -> Some (make kind site)
+    | None -> None
+
+  let get_tainted_formals pdesc =
+    let site = CallSite.make (Procdesc.get_proc_name pdesc) (Procdesc.get_loc pdesc) in
+    IList.map
+      (fun (name, typ, kind_opt) -> name, typ, Option.map kind_opt ~f:(fun kind -> make kind site))
+      (Kind.get_tainted_formals pdesc)
+
+  let with_callsite t callee_site =
+    { t with site = callee_site; }
+
+  let pp fmt s =
+    F.fprintf fmt "%a(%a)" pp_kind s.kind CallSite.pp s.site
+
+  module Set = PrettyPrintable.MakePPSet(struct
+      type nonrec t = t
+      let compare = compare
+      let pp_element = pp
+    end)
+end
+
 module Dummy = struct
   type t = unit [@@deriving compare]
 

infer/src/checkers/Source.mli

@@ -9,13 +9,33 @@
 
 open! IStd
 
+(** specify that all the formals of the procdesc are not tainted *)
+val all_formals_untainted : Procdesc.t -> (Mangled.t * Typ.t * 'a option) list
+
+module type Kind = sig
+  include TraceElem.Kind
+
+  (** kind of an unknown source *)
+  val unknown : t
+
+  (** return Some (kind) if the procedure is a taint source, None otherwise *)
+  val get : Procname.t -> t option
+
+  (** return each formal of the function paired with either Some(kind) if the formal is a taint
+      source, or None if the formal is not a taint source *)
+  val get_tainted_formals : Procdesc.t -> (Mangled.t * Typ.t * t option) list
+end
+
 module type S = sig
   include TraceElem.S
 
+  (** return true if the current source is a footprint source *)
   val is_footprint : t -> bool
 
+  (** create a footprint source for the value read from the given access path. *)
   val make_footprint : AccessPath.t -> CallSite.t -> t
 
+  (** return Some(access path) if the current source is a footprint source, None otherwise *)
   val get_footprint_access_path: t -> AccessPath.t option
 
   (** return Some (source) if the call site is a taint source, None otherwise *)
@@ -26,4 +46,6 @@ module type S = sig
   val get_tainted_formals : Procdesc.t -> (Mangled.t * Typ.t * t option) list
 end
 
+module Make (Kind : Kind) : S with module Kind = Kind
+
 module Dummy : S with type t = unit

infer/src/checkers/TraceElem.ml

@@ -18,7 +18,7 @@ module type Kind = sig
 end
 
 module type S = sig
-  type t
+  type t [@@deriving compare]
 
   module Kind : Kind
 

infer/src/quandary/CppTrace.ml

@@ -12,54 +12,17 @@ open! IStd
 module F = Format
 module L = Logging
 
-module CppSource = struct
-
-  module Kind = struct
-    type t =
-      | Footprint of AccessPath.t (** source that was read from the environment. *)
-      | EnvironmentVariable (** source that was read from an environment variable *)
-      | Other (** for testing or uncategorized sources *)
-    [@@deriving compare]
-
-    let equal sk1 sk2 =
-      compare sk1 sk2 = 0
-
-    let pp fmt = function
-      | Footprint ap -> F.fprintf fmt "Footprint[%a]" AccessPath.pp ap
-      | EnvironmentVariable -> F.fprintf fmt "EnvironmentVariable"
-      | Other -> F.fprintf fmt "Other"
-  end
 
+module Kind = struct
   type t =
-    {
+    | EnvironmentVariable (** source that was read from an environment variable *)
-      kind : Kind.t;
+    | Other (** for testing or uncategorized sources *)
-      site : CallSite.t;
+    | Unknown
-    } [@@deriving compare]
+  [@@deriving compare]
-
-  let equal t1 t2 =
-    compare t1 t2 = 0
-
-  let is_footprint t = match t.kind with
-    | Kind.Footprint _ -> true
-    | _ -> false
-
-  let get_footprint_access_path t = match t.kind with
-    | Kind.Footprint access_path -> Some access_path
-    | _ -> None
-
-  let call_site t =
-    t.site
-
-  let kind t =
-    t.kind
 
-  let make kind site =
+  let unknown = Unknown
-    { site; kind; }
-
-  let make_footprint ap site =
-    { kind = Kind.Footprint ap; site; }
 
-  let get site = match CallSite.pname site with
+  let get = function
     | (Procname.ObjC_Cpp cpp_pname) as pname ->
         begin
           match Procname.objc_cpp_get_class_name cpp_pname, Procname.get_method pname with
@@ -67,11 +30,11 @@ module CppSource = struct
           | "Namespace here", "method name here" -> None
           | _ -> None
         end
-    | (C _) as pname ->
+    | (Procname.C _) as pname ->
         begin
           match Procname.to_string pname with
-          | "getenv" -> Some (make EnvironmentVariable site)
+          | "getenv" -> Some EnvironmentVariable
-          | "__infer_taint_source" -> Some (make Other site)
+          | "__infer_taint_source" -> Some Other
           | _ -> None
         end
     | pname when BuiltinDecl.is_declared pname ->
@@ -80,21 +43,16 @@ module CppSource = struct
         failwithf "Non-C++ procname %a in C++ analysis@." Procname.pp pname
 
   let get_tainted_formals pdesc =
-    IList.map (fun (name, typ) -> name, typ, None) (Procdesc.get_formals pdesc)
+    Source.all_formals_untainted pdesc
-
-  let with_callsite t callee_site =
-    { t with site = callee_site; }
 
-  let pp fmt s =
+  let pp fmt = function
-    F.fprintf fmt "%a(%a)" Kind.pp s.kind CallSite.pp s.site
+    | EnvironmentVariable -> F.fprintf fmt "EnvironmentVariable"
-
+    | Other -> F.fprintf fmt "Other"
-  module Set = PrettyPrintable.MakePPSet(struct
+    | Unknown -> F.fprintf fmt "Unknown"
-      type nonrec t = t
-      let compare = compare
-      let pp_element = pp
-    end)
 end
 
+module CppSource = Source.Make(Kind)
+
 module CppSink = struct
 
   module Kind = struct
@@ -177,9 +135,9 @@ include
 
     let should_report source sink =
       match Source.kind source, Sink.kind sink with
-      | Source.Kind.EnvironmentVariable, Sink.Kind.ShellExec ->
+      | Kind.EnvironmentVariable, Sink.Kind.ShellExec ->
           true
-      | Source.Kind.Other, Sink.Kind.Other ->
+      | Kind.Other, Sink.Kind.Other ->
           true
       | _ ->
           false

infer/src/quandary/JavaTrace.ml

@@ -12,69 +12,38 @@ open! IStd
 module F = Format
 module L = Logging
 
-module JavaSource = struct
 
-  module Kind = struct
-    type t =
-      | PrivateData (** private user or device-specific data *)
-      | Footprint of AccessPath.t (** source that was read from the environment. *)
-      | Intent
-      | Other (** for testing or uncategorized sources *)
-    [@@deriving compare]
-
-    let pp fmt = function
-      | Intent -> F.fprintf fmt "Intent"
-      | PrivateData -> F.fprintf fmt "PrivateData"
-      | Footprint ap -> F.fprintf fmt "Footprint[%a]" AccessPath.pp ap
-      | Other -> F.fprintf fmt "Other"
-  end
 
+module Kind = struct
   type t =
-    {
+    | PrivateData (** private user or device-specific data *)
-      kind : Kind.t;
+    | Intent
-      site : CallSite.t;
+    | Other (** for testing or uncategorized sources *)
-    } [@@deriving compare]
+    | Unknown
-
+  [@@deriving compare]
-  let is_footprint t = match t.kind with
-    | Kind.Footprint _ -> true
-    | _ -> false
-
-  let get_footprint_access_path t = match t.kind with
-    | Kind.Footprint access_path -> Some access_path
-    | _ -> None
-
-  let call_site t =
-    t.site
 
-  let kind t =
+  let unknown = Unknown
-    t.kind
-
-  let make kind site =
-    { site; kind; }
-
-  let make_footprint ap site =
-    { kind = Kind.Footprint ap; site; }
 
-  let get site = match CallSite.pname site with
+  let get = function
     | Procname.Java pname ->
         begin
           match Procname.java_get_class_name pname, Procname.java_get_method pname with
           | "android.content.Intent", ("getStringExtra" | "parseUri" | "parseIntent") ->
-              Some (make Intent site)
+              Some Intent
           | "android.content.SharedPreferences", "getString" ->
-              Some (make PrivateData site)
+              Some PrivateData
           | "android.location.Location",
             ("getAltitude" | "getBearing" | "getLatitude" | "getLongitude" | "getSpeed") ->
-              Some (make PrivateData site)
+              Some PrivateData
           | "android.telephony.TelephonyManager",
             ("getDeviceId" |
              "getLine1Number" |
              "getSimSerialNumber" |
              "getSubscriberId" |
              "getVoiceMailNumber") ->
-              Some (make PrivateData site)
+              Some PrivateData
           | "com.facebook.infer.builtins.InferTaint", "inferSecretSource" ->
-              Some (make Other site)
+              Some Other
           | _ ->
               None
         end
@@ -84,15 +53,14 @@ module JavaSource = struct
   let get_tainted_formals pdesc =
     let make_untainted (name, typ) =
       name, typ, None in
-    let taint_formals_with_types type_strs kind pdesc formals =
+    let taint_formals_with_types type_strs kind formals =
       let taint_formal_with_types ((formal_name, formal_typ) as formal) =
         let matches_classname typ typ_str = match typ with
           | Typ.Tptr (Tstruct typename, _) -> Typename.name typename = typ_str
           | _ -> false in
         if IList.mem matches_classname formal_typ type_strs
         then
-          let site = CallSite.make (Procdesc.get_proc_name pdesc) (Procdesc.get_loc pdesc) in
+          formal_name, formal_typ, Some kind
-          formal_name, formal_typ, Some (make kind site)
         else
           make_untainted formal in
       IList.map taint_formal_with_types formals in
@@ -106,29 +74,24 @@ module JavaSource = struct
               taint_formals_with_types
                 ["java.lang.Integer"; "java.lang.String"]
                 Other
-                pdesc
                 formals
           | _ ->
-              IList.map make_untainted formals
+              Source.all_formals_untainted pdesc
         end
     | procname ->
         failwithf
           "Non-Java procedure %a where only Java procedures are expected"
           Procname.pp procname
 
-  let with_callsite t callee_site =
+  let pp fmt = function
-    { t with site = callee_site; }
+    | Intent -> F.fprintf fmt "Intent"
-
+    | PrivateData -> F.fprintf fmt "PrivateData"
-  let pp fmt s =
+    | Other -> F.fprintf fmt "Other"
-    F.fprintf fmt "%a(%a)" Kind.pp s.kind CallSite.pp s.site
+    | Unknown -> F.fprintf fmt "Unknown"
-
-  module Set = PrettyPrintable.MakePPSet(struct
-      type nonrec t = t
-      let compare = compare
-      let pp_element = pp
-    end)
 end
 
+module JavaSource = Source.Make(Kind)
+
 module JavaSink = struct
 
   module Kind = struct
@@ -244,10 +207,10 @@ include
 
     let should_report source sink =
       match Source.kind source, Sink.kind sink with
-      | Source.Kind.Other, Sink.Kind.Other
+      | Kind.Other, Sink.Kind.Other
-      | Source.Kind.PrivateData, Sink.Kind.Logging ->
+      | Kind.PrivateData, Sink.Kind.Logging ->
           true
-      | Source.Kind.Intent, Sink.Kind.Intent ->
+      | Kind.Intent, Sink.Kind.Intent ->
           true
       | _ ->
           false

infer/src/unit/TaintTests.ml

@@ -34,22 +34,21 @@ module MockTrace = Trace.Make(struct
           let compare = compare
           let pp_element = pp
         end)
-
     end
 
-    module Source = struct
+    module Source = Source.Make(struct
-      include MockTraceElem
+        include MockTraceElem
 
-      let get site =
+        let unknown = CallSite.dummy
-        if String.is_prefix ~prefix:"SOURCE" (Procname.to_string (CallSite.pname site))
-        then Some site
-        else None
 
-      let get_tainted_formals _ = assert false
+        let get pname =
-      let is_footprint _ = false
+          if String.is_prefix ~prefix:"SOURCE" (Procname.to_string pname)
-      let make_footprint _ = assert false
+          then Some (CallSite.make pname Location.dummy)
-      let get_footprint_access_path _ = assert false
+          else None
-    end
+
+        let get_tainted_formals _ =
+          []
+      end)
 
     module Sink = struct
       include MockTraceElem

infer/src/unit/TraceTests.ml

@@ -17,6 +17,10 @@ module MockTraceElem = struct
     | Kind1
     | Kind2
     | Footprint
+    | Unknown
+  [@@deriving compare]
+
+  let unknown = Unknown
 
   let call_site _ = CallSite.dummy
 
@@ -24,23 +28,11 @@ module MockTraceElem = struct
 
   let make kind _ = kind
 
-  let compare t1 t2 =
-    match t1, t2 with
-    | Kind1, Kind1 -> 0
-    | Kind1, _ -> (-1)
-    | _, Kind1 -> 1
-    | Kind2, Kind2 -> 0
-    | Kind2, _ -> (-1)
-    | _, Kind2 -> 1
-    | Footprint, Footprint -> 0
-
-  let equal t1 t2 =
-    compare t1 t2 = 0
-
   let pp fmt = function
     | Kind1 -> F.fprintf fmt "Kind1"
     | Kind2 -> F.fprintf fmt "Kind2"
     | Footprint -> F.fprintf fmt "Footprint"
+    | Unknown -> F.fprintf fmt "Unknown"
 
   module Kind = struct
     type nonrec t = t
@@ -58,25 +50,23 @@ module MockTraceElem = struct
 end
 
 module MockSource = struct
-  include MockTraceElem
+  include
-
+    (Source.Make(struct
-  let make = MockTraceElem.make
+       include MockTraceElem
 
-  let is_footprint kind =
+       let get _ = assert false
-    kind = Footprint
+       let get_tainted_formals _ = assert false
+     end))
 
-  let make_footprint _ _ = Footprint
+  let equal source1 source2 = compare source1 source2 = 0
-
-  let get _ = assert false
-  let get_tainted_formals _ = []
-  let get_footprint_access_path _ = assert false
 end
 
 module MockSink = struct
   include MockTraceElem
 
-
   let get _ = assert false
+
+  let equal sink1 sink2 = compare sink1 sink2 = 0
 end
 
 
@@ -120,7 +110,8 @@ let tests =
   let append =
     let append_ _ =
       let call_site = CallSite.dummy in
-      let footprint_source = MockSource.make_footprint MockTraceElem.Kind1 call_site in
+      let footprint_ap = AccessPath.Exact (AccessPath.of_id (Ident.create_none ()) Typ.Tvoid) in
+      let footprint_source = MockSource.make_footprint footprint_ap call_site in
       let source_trace =
         MockTrace.of_source source1 in
       let footprint_trace =