Extend OpamProcess to run scripts and Cygwin bins

Invoking processes on Windows is fundamentally different from Unix since
Windows processes receive a single-string command line, rather than an
argv array.

Windows has a set of conventions for quoting these (totally independent
of the Command Processor cmd.exe and unambiguously allowing any argv
array to be encoded) which OCaml already follows in the Unix module.

Cygwin, for various reasons, does not follow these conventions and
various different shims are required, particularly to avoid Cygwin's
globbing operations.

Armed with the ability to call Cygwin executables, OpamProcess is also
to locate a script processor, meaning it can handle #! scripts directly.
This is less error prone than trying to run them using sh -c which on
Cygwin has even more complex escaping rules which have to be navigated.

Signed-off-by: David Allsopp <david.allsopp@metastack.com>

src/core/opamProcess.ml

@@ -9,9 +9,188 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open OpamCompat
+
 let log ?level fmt =
   OpamConsole.log "PROC" ?level fmt
 
+let cygwin_create_process_env prog args env fd1 fd2 fd3 =
+  (*
+   * Unix.create_process_env correctly converts arguments to a command line for
+   * native Windows execution, but it does not correctly handle Cygwin's quoting
+   * requirements.
+   *
+   * The process followed here is based on an analysis of the sources for the
+   * Cygwin DLL (git://sourceware.org/git/newlib-cygwin.git,
+   * winsup/cygwin/dcrt0.cc) and a lack of refutation on the Cygwin mailing list
+   * in May 2016!
+   *
+   * In case this seems terminally stupid, it's worth noting that Cygwin's
+   * implementation of the exec system calls do not pass argv using the Windows
+   * command line, these weird and wonderful rules exist for corner cases and,
+   * as here, for invocations from native Windows processes.
+   *
+   * There are two forms of escaping which can apply, controlled by the CYGWIN
+   * environment variable option noglob.
+   *
+   * If none of the strings in argv contains the double-quote character, then
+   * the process should be invoked with the noglob option (to ensure that no
+   * characters are unexpectedly expanded). In this mode of escaping, it is
+   * necessary to protect any whitespace characters (\r, \n, \t, and space
+   * itself) by surrounding sequences of them with double-quotes). Additionally,
+   * if any string in argv begins with the @ sign, this should be double-quoted.
+   *
+   * If any one of the strings in argv does contain a double-quote character,
+   * then the process should be invoked with the glob option (this is the
+   * default). Every string in argv should have double-quotes put around it. Any
+   * double-quote characters within the string should be translated to "'"'".
+   *
+   * The reason for supporting both mechanisms is that the noglob method has
+   * shorter command lines and Windows has an upper limit of 32767 characters
+   * for the command line.
+   *
+   * COMBAK If the command line does exceed 32767 characters, then Cygwin allows
+   *        a parameter beginning @ to refer to a file from which to read the
+   *        rest of the command line. This support is not implemented at this
+   *        time in OPAM.
+   *
+   * [This stray " is here to terminate a previous part of the comment!]
+   *)
+  let make_args argv =
+    let b = Buffer.create 128 in
+    let gen_quote ~quote ~pre ?(post = pre) s =
+      log ~level:3 "gen_quote: %S" s;
+      Buffer.clear b;
+      let l = String.length s in
+      let rec f i =
+        let j =
+          try
+            OpamStd.String.find_from (fun c -> try String.index quote c >= 0 with Not_found -> false) s (succ i)
+          with Not_found ->
+            l in
+        Buffer.add_string b (String.sub s i (j - i));
+        if j < l then begin
+          Buffer.add_string b pre;
+          let i = j in
+          let j =
+            try
+              OpamStd.String.find_from (fun c -> try String.index quote c < 0 with Not_found -> true) s (succ i)
+            with Not_found ->
+              l in
+          Buffer.add_string b (String.sub s i (j - i));
+          Buffer.add_string b post;
+          if j < l then
+            f j
+          else
+            Buffer.contents b
+        end else
+          Buffer.contents b in
+      let r =
+        if s = "" then
+          "\"\""
+        else
+          f 0
+      in
+      log ~level:3 "result: %S" r; r in
+    if List.exists (fun s -> try String.index s '"' >= 0 with Not_found -> false) argv then
+      ("\"" ^ String.concat "\" \"" (List.map (gen_quote ~quote:"\"" ~pre:"\"'" ~post:"'\"") argv) ^ "\"", false)
+    else
+      (String.concat " " (List.map (gen_quote ~quote:"\b\r\n " ~pre:"\"") argv), true) in
+  let (command_line, no_glob) = make_args (Array.to_list args) in
+  log "cygvoke(%sglob): %s" (if no_glob then "no" else "") command_line;
+  let env = Array.to_list env in
+  let set = ref false in
+  let f item =
+    let (key, value) =
+      match OpamStd.String.cut_at item '=' with
+        Some pair -> pair
+      | None -> (item, "") in
+    match String.lowercase_ascii key with
+    | "cygwin" ->
+        let () =
+          if key = "CYGWIN" then
+            set := true in
+        let settings = OpamStd.String.split value ' ' in
+        let set = ref false in
+        let f setting =
+          let setting = String.trim setting in
+          let setting =
+            match OpamStd.String.cut_at setting ':' with
+              Some (setting, _) -> setting
+            | None -> setting in
+          match setting with
+            "glob" ->
+              if no_glob then begin
+                log ~level:2 "Removing glob from %s" key;
+                false
+              end else begin
+                log ~level:2 "Leaving glob in %s" key;
+                set := true;
+                true
+              end
+          | "noglob" ->
+              if no_glob then begin
+                log ~level:2 "Leaving noglob in %s" key;
+                set := true;
+                true
+              end else begin
+                log ~level:2 "Removing noglob from %s" key;
+                false
+              end
+          | _ ->
+              true in
+        let settings = List.filter f settings in
+        let settings =
+          if not !set && no_glob then begin
+            log ~level:2 "Setting noglob in %s" key;
+            "noglob"::settings
+          end else
+            settings in
+        if settings = [] then begin
+          log ~level:2 "Removing %s completely" key;
+          None
+        end else
+          Some (key ^ "=" ^ String.concat " " settings)
+    | "path" ->
+        let path_dirs = OpamStd.Sys.split_path_variable item in
+        let winsys = Filename.concat (OpamStd.Sys.system ()) "." |> String.lowercase_ascii in
+        let rec f prefix suffix = function
+        | dir::dirs ->
+            let contains_cygpath = Sys.file_exists (Filename.concat dir "cygpath.exe") in
+            if suffix = [] then
+              if String.lowercase_ascii (Filename.concat dir ".") = winsys then
+                f prefix [dir] dirs
+              else
+                if contains_cygpath then
+                  path_dirs
+                else
+                  f (dir::prefix) [] dirs
+            else
+              if contains_cygpath then begin
+                log ~level:2 "Moving %s to after %s in PATH" dir (List.hd prefix);
+                List.rev_append prefix (dir::(List.rev_append suffix dirs))
+              end else
+                f prefix (dir::suffix) dirs
+        | [] ->
+            assert false
+        in
+        Some (String.concat ";" (f [] [] path_dirs))
+    | _ ->
+        Some item in
+  let env = OpamStd.List.filter_map f env in
+  let env =
+    if !set then
+      env
+    else
+      if no_glob then begin
+        log ~level:2 "Adding CYGWIN=noglob";
+        "CYGWIN=noglob"::env
+      end else
+        env in
+  OpamStubs.win_create_process prog command_line
+                               (Some(String.concat "\000" env ^ "\000"))
+                               fd1 fd2 fd3
+
 (** Shell commands *)
 type command = {
   cmd: string;
@@ -127,6 +306,15 @@ let string_of_info ?(color=`yellow) info =
         (OpamConsole.colorise color k) v) info;
   Buffer.contents b
 
+let resolve_command_fn = ref (fun ?env:_ ?dir:_ _ -> None)
+let set_resolve_command =
+  let called = ref false in
+  fun resolve_command ->
+    if !called then invalid_arg "Just what do you think you're doing, Dave?";
+    called := true;
+    resolve_command_fn := resolve_command
+let resolve_command cmd = !resolve_command_fn cmd
+
 (** [create cmd args] create a new process to execute the command
     [cmd] with arguments [args]. If [stdout_file] or [stderr_file] are
     set, the channels are redirected to the corresponding files.  The
@@ -191,8 +379,68 @@ let create ?info_file ?env_file ?(allow_stdin=true) ?stdout_file ?stderr_file ?e
       close_out chan in
 
   let pid =
+    let cmd, args =
+      if Sys.win32 then
+        try
+          let actual_command =
+            if Sys.file_exists cmd then
+              cmd
+            else if Sys.file_exists (cmd ^ ".exe") then
+              cmd ^ ".exe"
+            else
+              raise Exit in
+          let actual_image, args =
+            let c = open_in actual_command in
+            set_binary_mode_in c true;
+            try
+              if really_input_string c 2 = "#!" then begin
+                (* The input_line will only fail for a 2-byte file consisting of exactly #! (with no \n), which is acceptable! *)
+                let l = String.trim (input_line c) in
+                let cmd, arg =
+                  try
+                    let i = String.index l ' ' in
+                    let cmd = Filename.basename (String.trim (String.sub l 0 i)) in
+                    let arg = String.trim (String.sub l i (String.length l - i)) in
+                    if cmd = "env" then
+                      arg, None
+                    else
+                      cmd, Some arg
+                  with Not_found ->
+                    Filename.basename l, None in
+                close_in c;
+                try
+                  let cmd = OpamStd.Option.default cmd (resolve_command cmd) in
+                  (*Printf.eprintf "Deduced %s => %s to be executed via %s\n%!" cmd actual_command cmd;*)
+                  let args = actual_command::args in
+                  cmd, OpamStd.Option.map_default (fun arg -> arg::args) args arg
+                with Not_found ->
+                  (* Script interpreter isn't available - fall back *)
+                  raise Exit
+              end else begin
+                close_in c;
+                actual_command, args
+              end
+            with End_of_file ->
+              close_in c;
+              (* A two-byte image can't be executable! *)
+              raise Exit in
+          (*Printf.eprintf "Final deduction: %s -> %s\n%!" cmd actual_image;*)
+          actual_image, args
+        with Exit ->
+          (* Fall back to default behaviour if anything went wrong - almost certainly means a broken package *)
+          cmd, args
+      else
+        cmd, args in
+    let create_process, cmd, args =
+      if Sys.win32 then
+        if OpamStd.Sys.is_cygwin_variant cmd = `Cygwin then
+          cygwin_create_process_env, cmd, args
+        else
+          Unix.create_process_env, cmd, args
+      else
+        Unix.create_process_env, cmd, args in
     try
-      Unix.create_process_env
+      create_process
         cmd
         (Array.of_list (cmd :: args))
         env

src/core/opamProcess.mli

@@ -210,3 +210,7 @@ module Job: sig
 end
 
 type 'a job = 'a Job.Op.job
+
+(**/**)
+val set_resolve_command :
+  (?env:string array -> ?dir:string -> string -> string option) -> unit

src/core/opamStd.ml

@@ -435,6 +435,21 @@ module OpamString = struct
     with Not_found ->
       false
 
+  let find_from f s i =
+    let l = String.length s in
+    if i < 0 || i > l then
+      invalid_arg "find_from"
+    else
+      let rec g i =
+        if i < l then
+          if f s.[i] then
+            i
+          else
+            g (succ i)
+        else
+          raise Not_found in
+      g i
+
   let map f s =
     let len = String.length s in
     let b = Bytes.create len in
@@ -591,9 +606,9 @@ module OpamSys = struct
     if Sys.win32 then fun path ->
       let length = String.length path in
       let rec f acc index current last normal =
-        if index = length
-        then let current = current ^ String.sub path last (index - last) in
-          if current <> "" then current::acc else acc
+        if index = length then
+          let current = current ^ String.sub path last (index - last) in
+          List.rev (if current <> "" then current::acc else acc)
         else let c = path.[index]
           and next = succ index in
           if c = ';' && normal || c = '"' then
@@ -701,6 +716,10 @@ module OpamSys = struct
         Hashtbl.add memo arg r;
         r
 
+  let system () =
+    (* CSIDL_SYSTEM = 0x25 *)
+    OpamStubs.(shGetFolderPath 0x25 SHGFP_TYPE_CURRENT)
+
   type os =
     | Darwin
     | Linux

src/core/opamStd.mli

@@ -224,6 +224,7 @@ module String : sig
   val contains_char: string -> char -> bool
   val contains: sub:string -> string -> bool
   val exact_match: Re.re -> string -> bool
+  val find_from: (char -> bool) -> string -> int -> int
 
   (** {3 Manipulation} *)
 
@@ -368,6 +369,9 @@ module Sys : sig
   (** The /etc directory *)
   val etc: unit -> string
 
+  (** The system directory (Windows only) *)
+  val system: unit -> string
+
   type os = Darwin
           | Linux
           | FreeBSD

src/core/opamStubs.ml.dummy

@@ -35,3 +35,4 @@ let shGetFolderPath _ = that's_a_no_no
 let sendMessageTimeout _ _ _ _ _ = that's_a_no_no
 let getParentProcessID = that's_a_no_no
 let getConsoleAlias _ = that's_a_no_no
+let win_create_process _ _ _ _ _ = that's_a_no_no

src/core/opamStubs.ml.win32

@@ -11,3 +11,7 @@
 include OpamStubsTypes
 include OpamWin32Stubs
 let getpid () = Int32.to_int (getCurrentProcessID ())
+
+external win_create_process : string -> string -> string option ->
+                              Unix.file_descr -> Unix.file_descr -> Unix.file_descr -> int
+                            = "win_create_process" "win_create_process_native"

src/core/opamStubs.mli

@@ -128,3 +128,7 @@ val getConsoleAlias : string -> string -> string
 (** Windows only. [getConsoleAlias alias exeName] retrieves the value for a
     given executable or [""] if the alias is not defined. See
     https://docs.microsoft.com/en-us/windows/console/getconsolealias *)
+
+val win_create_process : string -> string -> string option -> Unix.file_descr ->
+                         Unix.file_descr -> Unix.file_descr -> int
+(** Windows only. Provided by OCaml's win32unix library. *)

src/core/opamSystem.ml

@@ -841,3 +841,6 @@ let init () =
   Sys.catch_break true;
   try Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> ()))
   with Invalid_argument _ -> ()
+
+let () =
+  OpamProcess.set_resolve_command resolve_command