capabilities: forbid Unix.alarm and Unix.setitimer (semgrep/semgrep-p…

…roprietary#2131)

test plan:
make
make test

synced from Pro 2f638ddf285fbd7d03f0217d68a602bf2c8b0247

TCB/Cap.mli

@@ -120,7 +120,7 @@ type console = < stdin ; stdout ; stderr >
 type argv = < argv : Process.argv >
 type env = < env : Process.env >
 type signal = < signal : Process.signal >
-type alarm = < alarm : Process.signal >
+type alarm = < alarm : Process.alarm >
 type exit = < exit : Process.exit >
 type pid = < pid : Process.pid >
 type kill = < kill : Process.kill >

TCB/CapUnix.ml

@@ -1,3 +1,5 @@
 let execvp _caps = Unix.execvp
 let system _caps = Unix.system
 let fork _caps = Unix.fork
+let alarm _caps = Unix.alarm
+let setitimer _caps = Unix.setitimer

TCB/CapUnix.mli

@@ -6,3 +6,10 @@ val execvp : Cap.Exec.t -> string -> string array -> 'a
 (* You should use CapExec.ml instead *)
 val system : Cap.Exec.t -> string -> Unix.process_status
 val fork : Cap.Process.fork -> unit -> int
+val alarm : Cap.Process.alarm -> int -> int
+
+val setitimer :
+  Cap.Process.alarm ->
+  Unix.interval_timer ->
+  Unix.interval_timer_status ->
+  Unix.interval_timer_status

TCB/forbid_process.jsonnet

@@ -3,13 +3,14 @@ local common = import 'common.libsonnet';
 
 local unix_funcs = [
   'fork',
+  'alarm',
   'setitimer',
   //TODO: alarm, signal, kill, waitpid
 ];
 
 local sys_funcs = [
-  'sigalrm',
-  //TODO: set_signal
+  //TODO: set_signal? but then need different capability depending
+  // on the int argument of set_signal
 ];
 
 {
@@ -31,12 +32,12 @@ local sys_funcs = [
       languages: ['ocaml'],
       paths: {
         exclude: common.exclude_paths +
-	['Parmap_.ml', 'Time_limit.ml']
+	['Parmap_.ml']
       },
       severity: 'ERROR',
       message: |||
         Do not use directly process functions. Use the
-        safer CapProcess module.
+        safer CapProcess or CapSys or CapUnix modules.
       |||,
     },
   ],

languages/javascript/menhir/parse_js.mli

@@ -3,7 +3,7 @@
  *  - Parse_info.Lexical_error if Flag_parsing.exn_when_lexical_error is true.
  *)
 val parse :
-  ?timeout:float ->
+  ?timeout:float * < Cap.alarm > ->
   Fpath.t ->
   (Ast_js.a_program, Parser_js.token) Parsing_result.t
 

libs/ojsonnet/Unit_jsonnet.ml

@@ -34,8 +34,8 @@ let test_maker_err dir : Testo.t list =
              | Eval_jsonnet_common.Error _ ->
                  Alcotest.(check bool) "this raised an error" true true))
 
-let mk_tests (subdir : string) (strategys : Conf.eval_strategy list) :
-    Testo.t list =
+let mk_tests (caps : < Cap.alarm >) (subdir : string)
+    (strategys : Conf.eval_strategy list) : Testo.t list =
   Common2.glob (spf "tests/jsonnet/%s/*.jsonnet" subdir)
   |> Fpath_.of_strings
   |> List_.map (fun file ->
@@ -67,7 +67,7 @@ let mk_tests (subdir : string) (strategys : Conf.eval_strategy list) :
                       let json_opt =
                         Common.save_excursion Conf.eval_strategy strategy
                           (fun () ->
-                            Time_limit.set_timeout
+                            Time_limit.set_timeout caps
                               ~name:("ojsonnet-" ^ str_strategy) timeout
                               (fun () ->
                                 let value_ = Eval_jsonnet.eval_program core in
@@ -91,15 +91,15 @@ let mk_tests (subdir : string) (strategys : Conf.eval_strategy list) :
                         failwith
                           (spf "this threw an error with %s" str_strategy))))
 
-let tests () : Testo.t list =
+let tests (caps : < Cap.alarm >) : Testo.t list =
   Testo.categorize_suites "ojsonnet"
     [
-      mk_tests "pass/" [ Conf.EvalSubst; Conf.EvalEnvir ];
-      mk_tests "only_subst/" [ Conf.EvalSubst ];
-      mk_tests "only_envir/" [ Conf.EvalEnvir ];
-      mk_tests "tutorial/pass/" [ Conf.EvalSubst; Conf.EvalEnvir ];
-      mk_tests "tutorial/only_subst/" [ Conf.EvalSubst ];
-      mk_tests "tutorial/only_envir/" [ Conf.EvalEnvir ];
+      mk_tests caps "pass/" [ Conf.EvalSubst; Conf.EvalEnvir ];
+      mk_tests caps "only_subst/" [ Conf.EvalSubst ];
+      mk_tests caps "only_envir/" [ Conf.EvalEnvir ];
+      mk_tests caps "tutorial/pass/" [ Conf.EvalSubst; Conf.EvalEnvir ];
+      mk_tests caps "tutorial/only_subst/" [ Conf.EvalSubst ];
+      mk_tests caps "tutorial/only_envir/" [ Conf.EvalEnvir ];
       (* TODO
            test_maker_pass_fail dir_fail false;
            test_maker_pass_fail dir_fail_tutorial false;

libs/ojsonnet/Unit_jsonnet.mli

@@ -1 +1 @@
-val tests : unit -> Testo.t list
+val tests : < Cap.alarm > -> Testo.t list

libs/process_limits/Time_limit.ml

@@ -62,7 +62,7 @@ let current_timer = ref None
 
   question: can we have a signal and so exn when in a exn handler ?
 *)
-let set_timeout ~name max_duration f =
+let set_timeout (caps : < Cap.alarm >) ~name max_duration f =
   (match !current_timer with
   | None -> ()
   | Some { name = running_name; max_duration = running_val } ->
@@ -75,12 +75,13 @@ let set_timeout ~name max_duration f =
   let raise_timeout () = raise (Timeout info) in
   let clear_timer () =
     current_timer := None;
-    Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.; it_interval = 0. }
+    CapUnix.setitimer caps#alarm Unix.ITIMER_REAL
+      { Unix.it_value = 0.; it_interval = 0. }
     |> ignore
   in
   let set_timer () =
     current_timer := Some info;
-    Unix.setitimer Unix.ITIMER_REAL
+    CapUnix.setitimer caps#alarm Unix.ITIMER_REAL
       { Unix.it_value = max_duration; it_interval = 0. }
     |> ignore
   in
@@ -110,4 +111,4 @@ let set_timeout ~name max_duration f =
 let set_timeout_opt ~name time_limit f =
   match time_limit with
   | None -> Some (f ())
-  | Some x -> set_timeout ~name x f
+  | Some (x, caps) -> set_timeout caps ~name x f

libs/process_limits/Time_limit.mli

@@ -19,9 +19,11 @@ val string_of_timeout_info : timeout_info -> string
 
    tl;dr nesting will fail
 *)
-val set_timeout : name:string -> float -> (unit -> 'a) -> 'a option
+val set_timeout :
+  < Cap.alarm > -> name:string -> float -> (unit -> 'a) -> 'a option
 
 (*
    Only set a timer if a time limit is specified. Uses 'set_timeout'.
 *)
-val set_timeout_opt : name:string -> float option -> (unit -> 'a) -> 'a option
+val set_timeout_opt :
+  name:string -> (float * < Cap.alarm >) option -> (unit -> 'a) -> 'a option

src/analyzing/tests/Unit_dataflow.ml

@@ -12,7 +12,8 @@ let timeout_secs = 1.0
 (* ran from the root of the semgrep repository *)
 let tests_path = "tests"
 
-let tests parse_program =
+let tests (caps : < Cap.alarm >)
+    (parse_program : Fpath.t -> AST_generic.program) : Testo.t list =
   Testo.categorize "dataflow_python"
     [
       (* Just checking that it terminates without crashing. *)
@@ -25,7 +26,7 @@ let tests parse_program =
                  let lang = Lang.lang_of_filename_exn file in
                  Naming_AST.resolve lang ast;
                  match
-                   Time_limit.set_timeout ~name:"cst_prop" timeout_secs
+                   Time_limit.set_timeout caps ~name:"cst_prop" timeout_secs
                      (fun () ->
                        Constant_propagation.propagate_basic lang ast;
                        Constant_propagation.propagate_dataflow lang ast)

src/analyzing/tests/Unit_dataflow.mli

@@ -2,4 +2,4 @@
  * the caller (e.g. in Test.ml ) with other testsuites and
  * run via Alcotest.run.
  *)
-val tests : (Fpath.t -> AST_generic.program) -> Testo.t list
+val tests : < Cap.alarm > -> (Fpath.t -> AST_generic.program) -> Testo.t list

src/core_cli/Core_CLI.ml

@@ -355,6 +355,7 @@ let all_actions (caps : Cap.all_caps) () =
       " <files or dirs> generate parsing statistics (use -json for JSON output)",
       Arg_.mk_action_n_arg (fun xs ->
           Test_parsing.parsing_stats
+            (caps :> < Cap.alarm >)
             (Xlang.lang_of_opt_xlang_exn !lang)
             ~json:
               (match !output_format with
@@ -470,6 +471,7 @@ let all_actions (caps : Cap.all_caps) () =
       " <files or dirs> look for parsing regressions",
       Arg_.mk_action_n_arg (fun xs ->
           Test_parsing.parsing_regressions
+            (caps :> < Cap.alarm >)
             (Xlang.lang_of_opt_xlang_exn !lang)
             (Fpath_.of_strings xs)) );
     ( "-test_parse_tree_sitter",

src/engine/Match_rules.ml

@@ -46,7 +46,8 @@ let timeout_function (rule : Rule.t) (file : string)
   let timeout =
     match timeout with
     | None -> None
-    | Some { timeout; _ } -> if timeout <= 0. then None else Some timeout
+    | Some { timeout; caps; threshold = _ } ->
+        if timeout <= 0. then None else Some (timeout, caps)
   in
   match
     Time_limit.set_timeout_opt ~name:"Match_rules.timeout_function" timeout f

src/osemgrep/cli/CLI.ml

@@ -219,7 +219,7 @@ let dispatch_subcommand (caps : caps) (argv : string array) =
               subcmd_argv
         | "install-semgrep-pro" ->
             Install_semgrep_pro_subcommand.main
-              (caps :> < Cap.network >)
+              (caps :> < Cap.network ; Cap.alarm >)
               subcmd_argv
         (* osemgrep-only: and by default! no need experimental! *)
         | "lsp" ->

src/osemgrep/cli_install_semgrep_pro/Install_semgrep_pro_subcommand.ml

@@ -32,8 +32,11 @@ module Out = Semgrep_output_v1_j
 (* Types and Constants *)
 (*****************************************************************************)
 
-(* TODO: does not even use stdout right now, it abuses Logs.app *)
-type caps = < Cap.network >
+(* We need alarm because we timeout after 10s if the install fails
+ * TODO: add stdout, but does not even use stdout right now, it abuses
+ * Logs.app but we should switch to CapConsole.print
+ *)
+type caps = < Cap.network ; Cap.alarm >
 
 let version_stamp_filename = "pro-installed-by.txt"
 
@@ -217,7 +220,10 @@ let run_conf (caps : caps) (conf : Install_semgrep_pro_CLI.conf) : Exit_code.t =
         let version =
           let cmd = (Cmd.Name !!semgrep_pro_path_tmp, [ "-pro_version" ]) in
           let opt =
-            Time_limit.set_timeout ~name:"check pro version" 10.0 (fun () ->
+            Time_limit.set_timeout
+              (caps :> < Cap.alarm >)
+              ~name:"check pro version" 10.0
+              (fun () ->
                 (* TODO?  Bos.OS.Cmd.run_out ~err:Bos.OS.Cmd.err_run_out *)
                 let result = UCmd.string_of_run ~trim:true cmd in
                 match result with

src/osemgrep/cli_install_semgrep_pro/Install_semgrep_pro_subcommand.mli

@@ -5,7 +5,8 @@
 
    This function returns an exit code to be passed to the 'exit' function.
 *)
-val main : < Cap.network > -> string array -> Exit_code.t
+val main : < Cap.network ; Cap.alarm > -> string array -> Exit_code.t
 
 (* internal *)
-val run_conf : < Cap.network > -> Install_semgrep_pro_CLI.conf -> Exit_code.t
+val run_conf :
+  < Cap.network ; Cap.alarm > -> Install_semgrep_pro_CLI.conf -> Exit_code.t

src/parsing/tests/Test_parsing.ml

@@ -25,6 +25,9 @@ let tags = Logs_.create_tags [ __MODULE__ ]
 (*****************************************************************************)
 (* Prelude *)
 (*****************************************************************************)
+(*
+ * TODO: remove all those ~verbose parameter; just use Logs
+ *)
 
 (*****************************************************************************)
 (* Helpers *)
@@ -307,7 +310,7 @@ let dump_lang_ast (lang : Lang.t) (file : Fpath.t) : unit =
    This is meant to run the same parsers as semgrep-core does for normal
    semgrep scans.
 *)
-let parsing_common ?(verbose = true) lang files_or_dirs =
+let parsing_common (caps : < Cap.alarm >) ?(verbose = true) lang files_or_dirs =
   let timeout_seconds = 10.0 in
   (* Without the use of Memory_limit below, we were getting some
    * 'Fatal error: out of memory' errors in the parsing stat CI job,
@@ -362,9 +365,9 @@ let parsing_common ?(verbose = true) lang files_or_dirs =
              try
                match
                  Memory_limit.run_with_memory_limit ~mem_limit_mb (fun () ->
-                     Time_limit.set_timeout ~name:"Test_parsing.parsing_common"
-                       timeout_seconds (fun () ->
-                         Parse_target.parse_and_resolve_name lang file))
+                     Time_limit.set_timeout caps
+                       ~name:"Test_parsing.parsing_common" timeout_seconds
+                       (fun () -> Parse_target.parse_and_resolve_name lang file))
                with
                | Some res ->
                    let ast_stat = AST_stat.stat res.ast in
@@ -409,8 +412,8 @@ let parsing_common ?(verbose = true) lang files_or_dirs =
    be nice to find out about timeouts. I think the timeout threshold should
    in seconds/MB or equivalent units, not seconds per file."
 *)
-let parse_project ~verbose lang name files_or_dirs =
-  let stat_list, _skipped = parsing_common ~verbose lang files_or_dirs in
+let parse_project (caps : < Cap.alarm >) ~verbose lang name files_or_dirs =
+  let stat_list, _skipped = parsing_common caps ~verbose lang files_or_dirs in
   let stat_list =
     List.filter (fun stat -> not stat.PS.have_timeout) stat_list
   in
@@ -520,22 +523,22 @@ let print_json lang results =
   let s = Parsing_stats_j.string_of_t stats in
   print_endline (Yojson.Safe.prettify s)
 
-let parse_projects ~verbose lang project_dirs =
+let parse_projects caps ~verbose lang project_dirs =
   project_dirs
   |> List_.map (fun dir ->
          let name = dir in
-         parse_project ~verbose lang name [ Fpath.v dir ])
+         parse_project caps ~verbose lang name [ Fpath.v dir ])
 
-let parsing_stats ?(json = false) ?(verbose = false) lang project_dirs =
-  let stat_list = parse_projects ~verbose lang project_dirs in
+let parsing_stats caps ?(json = false) ?(verbose = false) lang project_dirs =
+  let stat_list = parse_projects caps ~verbose lang project_dirs in
   report_counts ();
   if json then print_json lang stat_list
   else
     let flat_stat = List.concat_map snd stat_list in
     UCommon.pr (Parsing_stat.string_of_stats flat_stat)
 
-let parsing_regressions lang files_or_dirs =
-  let _stat_list = parsing_common lang files_or_dirs in
+let parsing_regressions caps lang files_or_dirs =
+  let _stat_list = parsing_common caps lang files_or_dirs in
   raise Todo
 
 let diff_pfff_tree_sitter xs =

src/parsing/tests/Test_parsing.mli

@@ -10,10 +10,15 @@
  *   {"total":111,"bad":0,"percent_correct":100.0}
  *)
 val parsing_stats :
-  ?json:bool -> ?verbose:bool -> Lang.t -> string (* filename *) list -> unit
+  < Cap.alarm > ->
+  ?json:bool ->
+  ?verbose:bool ->
+  Lang.t ->
+  string (* filename *) list ->
+  unit
 
 (* TODO: parsing regressions as in pfff (unfinished) *)
-val parsing_regressions : Lang.t -> Fpath.t list -> unit
+val parsing_regressions : < Cap.alarm > -> Lang.t -> Fpath.t list -> unit
 
 (* Similar to [parsing_stats], but uses only tree-sitter parsers,
  * and stop the parsing at the tree-sitter CST level (it does not

src/tests/Test.ml

@@ -69,7 +69,7 @@ let tests (caps : Cap.all_caps) =
       Unit_autofix_printer.tests;
       Unit_synthesizer.tests;
       Unit_synthesizer_targets.tests;
-      Unit_dataflow.tests Parse_target.parse_program;
+      Unit_dataflow.tests (caps :> < Cap.alarm >) Parse_target.parse_program;
       Unit_typing_generic.tests Parse_target.parse_program (fun lang file ->
           Parse_pattern.parse_pattern lang file);
       Unit_naming_generic.tests Parse_target.parse_program;
@@ -78,7 +78,7 @@ let tests (caps : Cap.all_caps) =
       (* TODO Unit_matcher.spatch_unittest ~xxx *)
       (* TODO Unit_matcher_php.unittest; (* sgrep, spatch, refactoring, unparsing *) *)
       Unit_engine.tests ();
-      Unit_jsonnet.tests ();
+      Unit_jsonnet.tests (caps :> < Cap.alarm >);
       Unit_metachecking.tests (caps :> Core_scan.caps);
       (* OSemgrep tests *)
       Unit_LS.tests