Source file windows_registry.ml

(*
     * https://nsis.sourceforge.io/Add_uninstall_information_to_Add/Remove_Programs
     * https://docs.microsoft.com/en-us/windows/win32/msi/uninstall-registry-key
*)

open Dkml_install_runner.Error_handling.Monad_syntax
open Author_types

(** Find reg.exe. For safety we'll look in the same directory as cmd.exe
    first. *)
let find_reg_exe () =
  let* std_search_path, _fl =
    Dkml_install_runner.Error_handling.map_msg_error_to_progress
      (Bos.OS.Cmd.search_path_dirs (Bos.OS.Env.opt_var ~absent:"" "PATH"))
  in
  let* search, _fl =
    (* Ex. C:\WINDOWS\system32\reg.exe *)
    match Bos.OS.Env.var "COMSPEC" with
    | None -> return std_search_path
    | Some comspec ->
        (* Ex. C:\WINDOWS\system32 *)
        let comspec_dir = Fpath.(v comspec |> parent) in
        let* exists, _fl =
          Dkml_install_runner.Error_handling.map_msg_error_to_progress
            (Bos.OS.Dir.exists comspec_dir)
        in
        if exists then return (comspec_dir :: std_search_path)
        else return std_search_path
  in
  Dkml_install_runner.Error_handling.map_msg_error_to_progress
    (Bos.OS.Cmd.get_tool ~search Bos.Cmd.(v "reg"))

let registry_template_pf =
  Printf.sprintf
    {|

Windows Registry Editor Version 5.00

[%s]
"DisplayName"="%s"
"DisplayVersion"="%s"
%s
"Publisher"="%s"
"InstallDate"="%s"
"InstallLocation"="%s"
"QuietUninstallString"="\"%s\\uninstall.exe\" --ci --prefix \"%s\" --quiet --color=never"
"UninstallString"="\"%s\\uninstall.exe\" --prefix \"%s\""
"URLInfoAbout"="%s"
"URLUpdateInfo"="%s"
"HelpLink"="%s"
%s
"NoModify"=dword:00000001
"NoRepair"=dword:00000001
"Language"=%s
|}

(** [registry_key ~program_name] is
    ["HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\<program_name.name_camel_case_nospaces>"] *)
let registry_key ~(program_name : program_name) =
  "HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\"
  ^ program_name.name_camel_case_nospaces

let registry_template ~installation_prefix ~(organization : organization)
    ~(program_name : program_name) ~(program_info : program_info)
    ~program_version ~app_ico_path_opt =
  let escaped_installation_prefix =
    String.escaped (Fpath.to_string installation_prefix)
  in
  let localnow = Unix.localtime (Unix.time ()) in
  let localyyyymmdd =
    Printf.sprintf "%04d%02d%02d" (1900 + localnow.tm_year)
      (localnow.tm_mon + 1) localnow.tm_mday
  in

  registry_template_pf
    (* [HKEY\...\_] *) (registry_key ~program_name)
    (* DisplayName=%s *)
    program_name.name_full (* DisplayVersion=%s *) program_version
    (* "DisplayIcon"="C:\\Users\\beckf\\AppData\\Local\\Programs\\DiskuvOCaml\\32x32.ico" *)
    (Option.fold ~none:""
       ~some:(fun app_ico_path ->
         let escaped_app_ico_path =
           String.escaped (Fpath.to_string app_ico_path)
         in
         Printf.sprintf {|"DisplayIcon"="%s"|} escaped_app_ico_path)
       app_ico_path_opt)
    (* Publisher=%s *)
    organization.legal_name (* InstallDate=%s *) localyyyymmdd
    (* InstallLocation=%s *)
    escaped_installation_prefix
    (* QuietUninstallString=%s --prefix %s *)
    escaped_installation_prefix escaped_installation_prefix
    (* UninstallString=%s --prefix %s *)
    escaped_installation_prefix escaped_installation_prefix
    (* URLInfoAbout=%s *)
    (Option.fold ~none:""
       ~some:(Printf.sprintf {|"URLInfoAbout"="%s"|})
       program_info.url_info_about_opt)
    (* URLUpdateInfo=%s *)
    (Option.fold ~none:""
       ~some:(Printf.sprintf {|"URLUpdateInfo"="%s"|})
       program_info.url_update_info_opt)
    (* HelpLink=%s *)
    (Option.fold ~none:""
       ~some:(Printf.sprintf {|"HelpLink"="%s"|})
       program_info.help_link_opt)
    (* "EstimatedSize"=dword:0015cff7 | units in KB *)
    (Option.fold ~none:""
       ~some:(fun estimated_byte_size ->
         Printf.sprintf {|"EstimatedSize"=dword:%08Lx|}
           (Int64.div estimated_byte_size 1024L))
       program_info.estimated_byte_size_opt)
    (* "Language"=%s | default is en-US (0x409) *)
    (Printf.sprintf "dword:%08x"
       (Option.value ~default:0x409 program_info.windows_language_code_id_opt))

let delete_program_entry ~program_name =
  (* Delete from registry.

     https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/reg-delete *)
  let* reg_exe, _fl = find_reg_exe () in
  let cmd =
    Bos.Cmd.(
      v (Fpath.to_string reg_exe) % "delete" % registry_key ~program_name % "/f")
  in
  Logs.debug (fun l -> l "Running:@ %a" Bos.Cmd.pp cmd);
  Spawn.spawn ~err_ok:true cmd

let write_program_entry ~installation_prefix ~organization ~program_name
    ~program_assets ~program_version ~program_info =
  (* Make absolute path for installation prefix.

     No guarantee that prefix is not relative like in --prefix=_build/p.
     Since goes into Registry, it needs to be an absolute path. *)
  let* pwd, _fl =
    Dkml_install_runner.Error_handling.map_msg_error_to_progress
      (Bos.OS.Dir.current ())
  in
  let installation_prefix =
    match Fpath.is_rel installation_prefix with
    | true -> Fpath.(pwd // installation_prefix)
    | false -> installation_prefix
  in

  (* Make PREFIX/app.ico if available *)
  let* app_ico_path_opt, _fl =
    match program_assets.logo_icon_32x32_opt with
    | None -> return None
    | Some logo_icon_32x32 ->
        let app_ico_path = Fpath.(installation_prefix / "app.ico") in
        let* (), _fl =
          Dkml_install_runner.Error_handling.map_msg_error_to_progress
            (Bos.OS.File.write app_ico_path logo_icon_32x32)
        in
        return (Some app_ico_path)
  in

  (* Make a TMP/uninstall.reg file *)
  let registry_contents =
    String.trim
      (registry_template ~installation_prefix ~organization ~program_name
         ~program_version ~program_info ~app_ico_path_opt)
  in
  let* registry_file, _fl =
    Dkml_install_runner.Error_handling.map_msg_error_to_progress
      (Bos.OS.File.tmp "uninstall%s.reg")
  in
  let* (), _fl =
    Dkml_install_runner.Error_handling.map_msg_error_to_progress
      (Bos.OS.File.write registry_file registry_contents)
  in

  (* Write into registry.

     https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/reg-import *)
  let* reg_exe, _fl = find_reg_exe () in
  Logs.info (fun l -> l "Writing to registry for Add/Remove Programs");
  let cmd =
    Bos.Cmd.(
      v (Fpath.to_string reg_exe) % "import" % Fpath.to_string registry_file)
  in
  Logs.debug (fun l ->
      l "Running:@ %a@ with the contents:@ @[<v>  %a@]" Bos.Cmd.pp cmd Fmt.lines
        registry_contents);
  Spawn.spawn cmd