package dkml-package-console

  1. Overview
  2. Docs

Source file dkml_package_console_common.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
open Bos
open Astring
open Dkml_install_api
open Dkml_install_runner.Error_handling.Monad_syntax
include Error_utils

(* Pull in other modules and functions to fill out .mli *)
(* BEGIN *)
module Author_types = Author_types
module Windows_registry = Windows_registry

let spawn = Spawn.spawn
(* END *)

open Author_types

(** [parse_version] parses ["[v|V]major.minor[.patch][(+|-)info]"].
    Verbatim from https://erratique.ch/software/astring/doc/Astring/index.html

    We are not using semver2 Opam package because it has bigstringaf DLL stublibs. *)
let parse_version : string -> (int * int * int * string option) option =
 fun s ->
  try
    let parse_opt_v s =
      match String.Sub.head s with
      | Some ('v' | 'V') -> String.Sub.tail s
      | Some _ -> s
      | None -> raise Exit
    in
    let parse_dot s =
      match String.Sub.head s with
      | Some '.' -> String.Sub.tail s
      | Some _ | None -> raise Exit
    in
    let parse_int s =
      match String.Sub.span ~min:1 ~sat:Char.Ascii.is_digit s with
      | i, _ when String.Sub.is_empty i -> raise Exit
      | i, s -> (
          match String.Sub.to_int i with None -> raise Exit | Some i -> (i, s))
    in
    let maj, s = parse_int (parse_opt_v (String.sub s)) in
    let min, s = parse_int (parse_dot s) in
    let patch, s =
      match String.Sub.head s with
      | Some '.' -> parse_int (parse_dot s)
      | _ -> (0, s)
    in
    let info =
      match String.Sub.head s with
      | Some ('+' | '-') -> Some String.Sub.(to_string (tail s))
      | Some _ -> raise Exit
      | None -> None
    in
    Some (maj, min, patch, info)
  with Exit -> None

(** [ver_m_n_o_p ver] converts the version [ver] into the
    ["mmmmm.nnnnn.ooooo.ppppp"] format required by an Application Manifest.

    Confer https://docs.microsoft.com/en-us/windows/win32/sbscs/application-manifests#assemblyidentity *)
let version_m_n_o_p version =
  match parse_version version with
  | Some (major, minor, patch, _info) -> Fmt.str "%d.%d.%d.0" major minor patch
  | None -> "0.0.0.0"

let create_minimal_context ~self_component_name ~log_config ~target_abi ~prefix
    ~staging_files_source =
  let open Dkml_install_runner.Path_eval in
  let* interpreter, _fl =
    Interpreter.create_minimal ~self_component_name ~abi:target_abi
      ~staging_files_source ~prefix
  in
  return
    {
      Context.eval = Interpreter.eval interpreter;
      path_eval = Interpreter.path_eval interpreter;
      target_abi_v2 = target_abi;
      log_config;
    }

let needs_install_admin ~reg ~selector ~log_config ~target_abi ~prefix
    ~staging_files_source =
  let+ bools =
    Dkml_install_register.Component_registry.install_eval reg ~selector
      ~fl:Dkml_install_runner.Error_handling.runner_fatal_log ~f:(fun cfg ->
        let module Cfg = (val cfg : Component_config) in
        let* ctx, _fl =
          create_minimal_context ~self_component_name:Cfg.component_name
            ~log_config ~target_abi ~prefix ~staging_files_source
        in
        Logs.debug (fun l ->
            l
              "Checking if we need to request administrator privileges for %s \
               ..."
              Cfg.component_name);
        let ret = Cfg.needs_install_admin ~ctx in
        Logs.debug (fun l ->
            l "Administrator required to install %s? %b" Cfg.component_name ret);
        return ret)
  in
  List.exists Fun.id bools

let needs_uninstall_admin ~reg ~selector ~log_config ~target_abi ~prefix
    ~staging_files_source =
  let+ bools =
    Dkml_install_register.Component_registry.uninstall_eval reg ~selector
      ~fl:Dkml_install_runner.Error_handling.runner_fatal_log ~f:(fun cfg ->
        let module Cfg = (val cfg : Component_config) in
        let* ctx, _fl =
          create_minimal_context ~self_component_name:Cfg.component_name
            ~log_config ~target_abi ~prefix ~staging_files_source
        in
        Logs.debug (fun l ->
            l
              "Checking if we need to request administrator privileges for %s \
               ..."
              Cfg.component_name);
        let ret = Cfg.needs_uninstall_admin ~ctx in
        Logs.debug (fun l ->
            l "Administrator required to uninstall %s? %b" Cfg.component_name
              ret);
        return ret)
  in
  List.exists Fun.id bools

let console_component_name = "xx-console"

let console_required_components = [ console_component_name; "staging-ocamlrun" ]

let elevated_cmd ~target_abi ~staging_files_source cmd =
  if Context.Abi_v2.is_windows target_abi then
    (* dkml-install-admin.exe on Win32 has a UAC manifest injected
       by link.exe in dune. But still will get
       "The requested operation requires elevation" if dkml-install-admin.exe
       is spawned from another process rather than directly from
       Command Prompt or PowerShell.
       So use `gsudo` from dkml-package-console. *)
    let component_dir =
      Dkml_install_runner.Path_location.absdir_staging_files
        ~package_selector:Package ~component_name:console_component_name
        ~abi_selector:(Abi target_abi) staging_files_source
    in
    let gsudo = Fpath.(component_dir / "bin" / "gsudo.exe") in
    match Logs.level () with
    | Some Debug ->
        return
          Cmd.(
            v (Fpath.to_string gsudo) % "--wait" % "--direct" % "--debug" %% cmd)
    | Some _ | None ->
        return Cmd.(v (Fpath.to_string gsudo) % "--wait" % "--direct" %% cmd)
  else
    match OS.Cmd.find_tool (Cmd.v "doas") with
    | Ok (Some fpath) -> return Cmd.(v (Fpath.to_string fpath) %% cmd)
    | Ok None | Error _ -> (
        match OS.Cmd.find_tool (Cmd.v "sudo") with
        | Ok (Some fpath) -> return Cmd.(v (Fpath.to_string fpath) %% cmd)
        | Ok None | Error _ -> (
            match OS.Cmd.resolve (Cmd.v "su") with
            | Ok su ->
                (* su -c "dkml-install-admin-runner ..." *)
                return Cmd.(su % "-c" % to_string cmd)
            | Error e ->
                Dkml_install_runner.Error_handling.runner_fatal_log
                  ~id:"6320d6e4"
                  (Fmt.str "@[Could not escalate to a superuser:@]@ @[%a@]"
                     Rresult.R.pp_msg e);
                Forward_progress.(Halted_progress Exit_transient_failure)))

let home_dir_fp () =
  let open Dkml_install_runner.Error_handling in
  let* home_str, _fl = map_rresult_error_to_progress @@ OS.Env.req_var "HOME" in
  let* home_fp, _fl =
    map_rresult_error_to_progress @@ Fpath.of_string home_str
  in
  (* ensure HOME is a pre-existing directory *)
  map_rresult_error_to_progress @@ OS.Dir.must_exist home_fp

let get_default_user_installation_prefix_windows
    ~installation_prefix_camel_case_nospaces =
  let open Dkml_install_runner.Error_handling in
  let* local_app_data_str, _fl =
    map_rresult_error_to_progress @@ OS.Env.req_var "LOCALAPPDATA"
  in
  let* local_app_data_fp, _fl =
    map_rresult_error_to_progress @@ Fpath.of_string local_app_data_str
  in
  (* ensure LOCALAPPDATA is a pre-existing directory *)
  let* local_app_data_fp, _fl =
    map_rresult_error_to_progress @@ OS.Dir.must_exist local_app_data_fp
  in
  return
    Fpath.(
      local_app_data_fp / "Programs" / installation_prefix_camel_case_nospaces)

let get_default_user_installation_prefix_darwin
    ~installation_prefix_camel_case_nospaces =
  let* home_dir_fp, _fl = home_dir_fp () in
  return
    Fpath.(
      home_dir_fp / "Applications" / installation_prefix_camel_case_nospaces)

let get_default_user_installation_prefix_linux
    ~installation_prefix_kebab_lower_case =
  let open Dkml_install_runner.Error_handling in
  match OS.Env.var "XDG_DATA_HOME" with
  | Some xdg_data_home ->
      let* fp, _fl =
        map_rresult_error_to_progress @@ Fpath.of_string xdg_data_home
      in
      return Fpath.(fp / installation_prefix_kebab_lower_case)
  | None ->
      let* home_dir_fp, _fl = home_dir_fp () in
      return
        Fpath.(
          home_dir_fp / ".local" / "share"
          / installation_prefix_kebab_lower_case)

let get_user_installation_prefix ~program_name ~target_abi ~prefix_opt =
  let installation_prefix_camel_case_nospaces =
    match program_name.installation_prefix_camel_case_nospaces_opt with
    | Some v -> v
    | None -> program_name.name_camel_case_nospaces
  in
  let installation_prefix_kebab_lower_case =
    match program_name.installation_prefix_kebab_lower_case_opt with
    | Some v -> v
    | None -> program_name.name_kebab_lower_case
  in
  match prefix_opt with
  | Some prefix -> return (Fpath.v prefix)
  | None ->
      if Context.Abi_v2.is_windows target_abi then
        get_default_user_installation_prefix_windows
          ~installation_prefix_camel_case_nospaces
      else if Context.Abi_v2.is_darwin target_abi then
        get_default_user_installation_prefix_darwin
          ~installation_prefix_camel_case_nospaces
      else if Context.Abi_v2.is_linux target_abi then
        get_default_user_installation_prefix_linux
          ~installation_prefix_kebab_lower_case
      else (
        Dkml_install_runner.Error_handling.runner_fatal_log ~id:"14420023"
          (Fmt.str
             "No rules defined for the default user installation prefix of the \
              ABI %a"
             Context.Abi_v2.pp target_abi);
        Forward_progress.(Halted_progress Exit_unrecoverable_failure))

(* Command Line Processing *)

type package_args = {
  log_config : Log_config.t;
  prefix_opt : string option;
  component_selector : string list;
  static_files_source : Dkml_install_runner.Path_location.static_files_source;
  staging_files_source : Dkml_install_runner.Path_location.staging_files_source;
}

let prefix_opt_t ~program_name ~target_abi =
  let doc =
    Fmt.str
      "$(docv) is the installation directory. If not set and $(b,--%s) is also \
       not set, then $(i,%s) will be used as the installation directory"
      Dkml_install_runner.Cmdliner_common.opam_context_args
      (Cmdliner.Manpage.escape
         (Fpath.to_string
            (Dkml_install_runner.Error_handling.continue_or_exit
            @@ get_user_installation_prefix ~program_name ~target_abi
                 ~prefix_opt:None)))
  in
  Cmdliner.Arg.(
    value
    & opt (some string) None
    & info
        [ Dkml_install_runner.Cmdliner_common.prefix_arg ]
        ~docv:"PREFIX" ~doc)

let package_args_t ~program_name ~target_abi ~install_direction =
  let package_args log_config prefix_opt component_selector static_files_source
      staging_files_source =
    {
      log_config;
      prefix_opt;
      component_selector;
      static_files_source =
        Dkml_install_runner.Error_handling.continue_or_exit static_files_source;
      staging_files_source =
        Dkml_install_runner.Error_handling.continue_or_exit staging_files_source;
    }
  in
  Cmdliner.Term.(
    const package_args $ Dkml_install_runner.Cmdliner_runner.setup_log_t
    $ prefix_opt_t ~program_name ~target_abi
    $ Dkml_install_runner.Cmdliner_runner.component_selector_t
        ~install_direction
    $ Dkml_install_runner.Cmdliner_runner.static_files_source_for_package_t
    $ Dkml_install_runner.Cmdliner_runner.staging_files_source_for_package_t)
OCaml

Innovation. Community. Security.