Merge pull request #5963 from dra27/gwf-menu

Improvements to `opam init` "Git" menu on Windows

Author: rjbou

configure

@@ -342,21 +342,22 @@ default_static=no
 AS_CASE([$TARGET],
   [*-linux-musl*],[
     support_static=yes
-    platform_dependant_stuff="-cclib -lstdc++ -cclib -static-libgcc -cclib -static"
+    platform_dependent_stuff="-cclib -lstdc++ -cclib -static-libgcc -cclib -static"
   ],
   [*-*-mingw32*],[
     support_static=yes
-    default_static=yes
+    AS_IF([test "x${with_private_runtime}" = "xno"],[default_static=yes])
     # NOTE: On Windows, the Windows specific dlls should stay dynamic for security reasons
     # NOTE: -l:libstdc++.a is necessary (vs. -lstdc++) as flexlink will use libstdc++.dll.a
     # which still depends on the DLL at runtime instead of libstdc++.a (that looks like a bug in flexlink)
-    platform_dependant_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32 -cclib -lole32 -cclib -luuid"
+    platform_dependent_stuff="-cclib -lopam_stubs_win32_stubs -cclib -l:libstdc++.a -cclib -l:libpthread.a -cclib -Wl,-static -cclib -ladvapi32 -cclib -lgdi32 -cclib -luser32 -cclib -lshell32 -cclib -lole32 -cclib -luuid -cclib -luserenv"
+    AS_IF([test "x${SYSTEM}" = "xmingw"], [platform_dependent_stuff="${platform_dependent_stuff} -cclib -lwindowsapp"])
   ])
 AS_CASE([${support_static},${enable_static}],
   [no,yes],[AC_MSG_ERROR([--enable-static is not available on this platform (${TARGET}).])],
   [*,auto],[enable_static=${default_static}])
 AS_IF([test "${enable_static}" = yes],[
-  echo "(-noautolink -cclib -lunix -cclib -lmccs_stubs -cclib -lmccs_glpk_stubs -cclib -lsha_stubs ${platform_dependant_stuff})" > src/client/linking.sexp
+  echo "(-noautolink -cclib -lunix -cclib -lmccs_stubs -cclib -lmccs_glpk_stubs -cclib -lsha_stubs ${platform_dependent_stuff})" > src/client/linking.sexp
   AC_MSG_RESULT([static])
 ],[
   AC_MSG_RESULT([shared])

configure.ac

@@ -23,6 +23,9 @@ users)
 
 ## Init
   * ◈ New option `opam init --cygwin-extra-packages=CYGWIN_PKGS --cygwin-internal-install`, to specify additional packages for internal Cygwin [#5930, #5964 @moyodiallo - fix #5834]
+  * Skip Git-for-Windows menu if the Git binary resolved in PATH is Git-for-Windows [#5963 @dra27 - fix #5835]
+  * Enhance the Git menu by warning if the user appears to need to restart the shell to pick up PATH changes [#5963 @dra27]
+  * Include Git for Windows installations in the list of possibilities where the user instructed Git-for-Windows setup not to update PATH [#5963 @dra27]
 
 ## Config report
 
@@ -164,3 +167,6 @@ users)
 ## opam-core
   * `OpamStd.String`: add `split_quoted` that preserves quoted separator [#5935 @dra27]
   * `OpamSystem.copy_dir` and `OpamSystem.mv` may display a warning on Windows if an invalid symlink (e.g. an LXSS Junction) is found [#5953 @dra27]
+  * `OpamStubs.getVersionInfo`: on Windows, retrives the version information block of an executable/library [#5963 @dra27]
+  * `OpamStubs.readRegistry`: on Windows, complements `OpamStubs.writeRegistry` [#5963 @dra27]
+  * `OpamStubs.get_initial_environment`: on Windows, returns the pristine environment for new shells [#5963 @dra27]

master_changes.md

@@ -15,7 +15,16 @@ match Sys.argv.(1) with
       print_string "i686"
 | "clibs" ->
     if Sys.win32 then
-      print_string "(-ladvapi32 -lgdi32 -luser32 -lshell32 -lole32 -luuid)"
+      let common =
+        "-ladvapi32 -lgdi32 -luser32 -lshell32 -lole32 -luuid -luserenv"
+      in
+      if Config.system = "mingw" then
+        (* This appears to be a packaging bug in i686-w64-mingw32, as
+           GetFileVersionInfoEx and friends are include in the x86_64 copy of
+           libversion.a *)
+        Printf.printf "(%s -lwindowsapp)" common
+      else
+        Printf.printf "(%s)" common
     else
       print_string "()"
 | _ ->

shell/context_flags.ml

@@ -635,8 +635,27 @@ let init_checks ?(hard_fail_exn=true) init_config =
   if hard_fail && hard_fail_exn then OpamStd.Sys.exit_because `Configuration_error
   else not (soft_fail || hard_fail)
 
+let is_git_for_windows git =
+  (* The resource file compiled for Git for Windows sets the ProductVersion
+     string to M.m.r.windows.b where M.m.r is the git version and b is the
+     revision number of Git for Windows. This differentiates it from very old
+     pre-GfW builds and also from Cygwin/MSYS2 builds of Git (which don't have
+     version blocks at all). The resource file is not localised cf.:
+     - https://github.com/git/git/blob/master/git.rc#L7
+     - https://github.com/git-for-windows/git/blob/main/SECURITY.md#L45
+     - https://github.com/git/git/blob/master/GIT-VERSION-GEN#L15
+  *)
+  match OpamStubs.getVersionInfo git with
+  | Some {OpamStubsTypes.strings =
+            [(_, {productVersionString = Some version; _})]; _} ->
+    begin
+      try Scanf.sscanf version "%u.%u.%u.windows.%u%!" (fun _ _ _ _ -> true)
+      with Scanf.Scan_failure _ | Failure _ | End_of_file ->  false
+    end
+  | _ -> false
+
 let git_for_windows_check =
-  if not Sys.win32 && not Sys.cygwin then fun ?git_location:_ () -> None else
+  if not Sys.win32 then fun ?git_location:_ () -> None else
   fun ?git_location () ->
     let header () = OpamConsole.header_msg "Git" in
     let contains_git p =
@@ -651,6 +670,67 @@ let git_for_windows_check =
             Some (git, OpamSystem.bin_contains_bash p)
           | None -> None)
     in
+    let abort_action = "install Git for Windows." in
+    let gits, gfw_message, abort_action =
+      if gits = [] then
+        (* Git has not been found in PATH. See if it instead can be found in the
+           initial environment. This deals with the possibility that the user
+           has installed Git for Windows, but not restarted the terminal (so
+           PATH has not been updated) *)
+        let env = OpamStubs.get_initial_environment () in
+        match OpamSystem.resolve_command ~env:(Array.of_list env) "git" with
+        | Some git when is_git_for_windows git ->
+          [], Some "It looks as though Git for Windows has been installed but \
+                    the shell needs to be restarted. You may wish to abort and \
+                    re-run opam init from a fresh session.",
+              "restart your shell."
+        | _ ->
+          (* Git is neither in the current nor the initial PATH. There is one
+             further possibility: the user may have installed Git for Windows
+             but selected the option not to update the environment. The final
+             hint given searches the Windows Registry for both a system-wide
+             and user-specific installation and, if found, both displays a
+             warning suggesting that the machine be reconfigured to enable them
+             in PATH, but also gives the opportunity to use the git-location
+             mechanism to select it for opam's internal use. *)
+          let test_for_installation ((gits, gfw_message, abort_action) as acc) (hive, key) =
+            let process root =
+              let git_location = Filename.concat root "cmd" in
+              let git = Filename.concat git_location "git.exe" in
+              if OpamSystem.resolve_command ~env:[||] git <> None
+              && is_git_for_windows git then
+                let gits =
+                  (git, OpamSystem.bin_contains_bash git_location)::gits
+                and message, action =
+                  Some "It looks as though Git for Windows has been installed, \
+                        but configured not to put the git binary in your PATH. \
+                        You can either abort and reconfigure your environment \
+                        (or re-run the Git for Windows installer) to enable \
+                        this, or you can use the menu below to have opam use \
+                        this Git installation internally.",
+                  "reconfigure Git for Windows."
+                in
+                if message = None then
+                  gits, gfw_message, action
+                else
+                  gits, message, abort_action
+              else
+                acc
+            in
+            let key = Filename.concat key "GitForWindows" in
+            OpamStubs.readRegistry hive key "InstallPath" OpamStubsTypes.REG_SZ
+            |> OpamStd.Option.map_default process acc
+          in
+          let installations = [
+            (* Machine-wide installation *)
+            (OpamStubsTypes.HKEY_LOCAL_MACHINE, "SOFTWARE");
+            (* User-specific installation *)
+            (OpamStubsTypes.HKEY_CURRENT_USER, "Software");
+          ] in
+          List.fold_left test_for_installation (gits, None, abort_action) installations
+      else
+        gits, None, abort_action
+    in
     let get_git_location ?git_location () =
       let bin =
         match git_location with
@@ -690,9 +770,10 @@ let git_for_windows_check =
               gits)
           @ [
             `Specify, "Enter the location of installed Git";
-            `Abort, "Abort initialisation to install recommended Git.";
+            `Abort, ("Abort initialisation to " ^ abort_action);
           ]
         in
+        OpamStd.Option.iter (OpamConsole.warning "%s\n") gfw_message;
         OpamConsole.menu "Which Git should opam use?"
           ~default:`Default ~no:`Default ~options
       in
@@ -711,7 +792,12 @@ let git_for_windows_check =
         header ();
         get_git_location ~git_location:(OpamFilename.Dir.to_string git_location) ()
       | None ->
-        if OpamStd.Sys.tty_out then
+        let git_found =
+          match OpamSystem.resolve_command "git" with
+          | None -> false
+          | Some git -> is_git_for_windows git
+        in
+        if not git_found && OpamStd.Sys.tty_out then
           (header ();
            OpamConsole.msg
              "Cygwin Git is functional but can have credentials issues for private repositories, \

src/client/opamClient.ml

@@ -23,6 +23,7 @@ let setConsoleMode _ = that's_a_no_no
 let getWindowsVersion = that's_a_no_no
 let getArchitecture = that's_a_no_no
 let waitpids _ = that's_a_no_no
+let readRegistry _ _ _ = that's_a_no_no
 let writeRegistry _ _ _ = that's_a_no_no
 let getConsoleOutputCP = that's_a_no_no
 let getCurrentConsoleFontEx _ = that's_a_no_no
@@ -42,3 +43,5 @@ let getConsoleWindowClass = that's_a_no_no
 let setErrorMode = that's_a_no_no
 let getErrorMode = that's_a_no_no
 let setConsoleToUTF8 = that's_a_no_no
+let getVersionInfo = that's_a_no_no
+let get_initial_environment = that's_a_no_no

src/core/opamStubs.dummy.ml

@@ -63,6 +63,13 @@ val waitpids : int list -> int -> int * Unix.process_status
       [waitpids pids length] behaves like [Unix.wait], returning the pid and
       exit status of the first process to terminate. *)
 
+val readRegistry : registry_root -> string -> string -> 'a registry_value -> 'a option
+  (** Windows only. [readRegistry root key name value_type] reads the value
+      [name] from registry key [key] of [root]. As per Windows Registry
+      convention, the default value can be read by passing [""] for [name].
+
+      @raise Failure If the value in the registry does not have [value_type] *)
+
 val writeRegistry :
   registry_root -> string -> string -> 'a registry_value -> 'a -> unit
   (** Windows only. [writeRegistry root key name value_type value] sets the
@@ -145,3 +152,10 @@ val getErrorMode : unit -> int
 
 val setConsoleToUTF8 : unit -> unit
 (** Windows only. Directly wraps SetConsoleOutputCP(CP_UTF8). *)
+
+val getVersionInfo : string -> win32_version_info option
+(** Windows only. Returns the version info block for a file or [None] if the
+    file either doesn't exist or doesn't have one. *)
+
+val get_initial_environment : unit -> string list
+(** Windows only. Returns the environment which new processes would receive. *)

src/core/opamStubs.mli

@@ -80,3 +80,36 @@ type windows_cpu_architecture =
 | IA64    (* 0x6 *)
 | Intel   (* 0x0 *)
 | Unknown (* 0xffff *)
+
+
+(** Predefined version information strings (see VerQueryValueW) *)
+type win32_non_fixed_version_info = {
+  comments: string option;
+  companyName: string option;
+  fileDescription: string option;
+  fileVersionString: string option;
+  internalName: string option;
+  legalCopyright: string option;
+  legalTrademarks: string option;
+  originalFilename: string option;
+  productName: string option;
+  productVersionString: string option;
+  privateBuild: string option;
+  specialBuild: string option;
+}
+
+(** VS_FIXEDFILEINFO *)
+type win32_version_info = {
+  signature: int; (** [0xFEEF04BD] *)
+  version: int * int; (** Structure version number *)
+  fileVersion: int * int * int * int; (** File version *)
+  productVersion: int * int * int * int; (** Product version *)
+  fileFlagsMask: int; (** Valid bits in {!fileFlags} *)
+  fileFlags: int; (** File attributes (see VS_FIXEDFILEINFO) *)
+  fileOS: int; (** File OS (see VS_FIXEDFILEINFO) *)
+  fileType: int; (** File Type (see VS_FIXEDFILEINFO) *)
+  fileSubtype: int; (** File Sub-type (see VS_FIXEDFILEINFO) *)
+  fileDate: int64; (** File creation time stamp *)
+  strings: ((int * int) * win32_non_fixed_version_info) list;
+    (** Non-fixed string table. First field is a pair of Language and Codepage ID. *)
+}

src/core/opamStubsTypes.ml

@@ -22,6 +22,7 @@ external setConsoleMode : 'a -> int -> bool = "OPAMW_SetConsoleMode"
 external getWindowsVersion : unit -> int * int * int * int = "OPAMW_GetWindowsVersion"
 external getArchitecture : unit -> 'a = "OPAMW_GetArchitecture"
 external waitpids : int list -> int -> int * Unix.process_status = "OPAMW_waitpids"
+external readRegistry : 'a -> string -> string -> 'b -> 'c option = "OPAMW_ReadRegistry"
 external writeRegistry : 'a -> string -> string -> 'b -> 'c -> unit = "OPAMW_WriteRegistry"
 external getConsoleOutputCP : unit -> int = "OPAMW_GetConsoleOutputCP"
 external getCurrentConsoleFontEx : 'a -> bool -> 'b = "OPAMW_GetCurrentConsoleFontEx"
@@ -40,3 +41,5 @@ external getConsoleWindowClass : unit -> string option = "OPAMW_GetConsoleWindow
 external setErrorMode : int -> int = "OPAMW_SetErrorMode"
 external getErrorMode : unit -> int = "OPAMW_GetErrorMode"
 external setConsoleToUTF8 : unit -> unit = "OPAMW_SetConsoleToUTF8"
+external getVersionInfo : string -> 'a option = "OPAMW_GetVersionInfo"
+external get_initial_environment : unit -> string list = "OPAMW_CreateEnvironmentBlock"