From f604bc6d9e9c8ad9c474779c1fa5b9b61ce2f9b5 Mon Sep 17 00:00:00 2001 From: Jonah Beckford <71855677+jonahbeckford@users.noreply.github.com> Date: Thu, 30 Nov 2023 08:58:51 -0800 Subject: [PATCH] Add uninstall_file_onerror_exit Part of https://github.com/diskuv/dkml-installer-ocaml/issues/67 --- CHANGES.md | 4 + api/dkml_install_api.ml | 300 +++++++++++++++++++++-------------- api/dkml_install_api_intf.ml | 14 +- 3 files changed, 202 insertions(+), 116 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index ec4bb88..572643e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,9 @@ # Changes +## Pending + +* Add `uninstall_file_onerror_exit` to API + ## 0.5.2 * Attach `(package)` to auto-generated test so other packages in diff --git a/api/dkml_install_api.ml b/api/dkml_install_api.ml index f01c7d7..ba4e6cc 100644 --- a/api/dkml_install_api.ml +++ b/api/dkml_install_api.ml @@ -153,6 +153,16 @@ struct let ( let+ ) f x = Rresult.R.map x f end +let chmod_plus_readwrite_path ~id path = + let open Immediate_fail (struct + let id = id + end) in + let* mode = Bos.OS.Path.Mode.get path in + if mode land 0o600 <> 0o600 then + let+ () = Bos.OS.Path.Mode.set path (mode lor 0o600) in + () + else Ok () + let chmod_plus_readwrite_dir ~id dir = let open Immediate_fail (struct let id = id @@ -166,21 +176,13 @@ let chmod_plus_readwrite_dir ~id dir = ~error:Rresult.R.pp_msg) result in - let chmod_u_rw rel = function + let f rel = function | Error _ as e -> (* no more chmod if we had an error *) e - | Ok () -> - let path = Fpath.(dir // rel) in - let* mode = Bos.OS.Path.Mode.get path in - if mode land 0o600 <> 0o600 then - let+ () = Bos.OS.Path.Mode.set path (mode lor 0o600) in - () - else Ok () - in - let* res = - Bos.OS.Path.fold ~err:raise_fold_error chmod_u_rw (Ok ()) [ dir ] + | Ok () -> chmod_plus_readwrite_path ~id Fpath.(dir // rel) in + let* res = Bos.OS.Path.fold ~err:raise_fold_error f (Ok ()) [ dir ] in match res with | Ok () -> Ok () | Error s -> @@ -209,29 +211,12 @@ let styled_stuck_detail fmt = let pp3 = Fmt.styled `Bold pp2 in Fmt.styled `Underline pp3 -let uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck = +let delete_path_on_windows ~id ~path ~wait_seconds_if_stuck ~comspec ~cmd + ~options = let open Immediate_fail (struct let id = id end) in - (* On Windows we need to get write access before you can delete the - file. *) - let fl = Forward_progress.stderr_fatallog in - let sequence = - let* exists = Bos.OS.Path.exists dir in - if exists then ( - Logs.info (fun m -> m "Uninstalling directory: %a" Fpath.pp dir); - let* () = chmod_plus_readwrite_dir ~id dir in - (* - OS.Dir.delete has bizarre error messages, like: - - C:\Users\beckf\AppData\Local\Temp\build999583.dune\test_uninstall_7b4501\cmd.exe: The directory name is invalid. - - when the above cmd.exe is being used. So we use cmd.exe on Windows instead which - has user-friendly DOS error messages. - *) - match (Sys.win32, Bos.OS.Env.var "COMSPEC") with - | true, Some comspec when comspec != "" -> - (* + (* https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/rd Example: @@ -245,62 +230,59 @@ let uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck = C:\Users\beckf\AppData\Local\Temp\f46f0508-df03-40e8-8661-728f1be41647\UninstallBlueGreenDeploy2\0\cmd.exe - Access is denied. So any output on the error console indicates a problem. *) - let cmd = - Printf.sprintf "@rd /s /q %s" (Filename.quote (Fpath.to_string dir)) - in - let* batchfile = Bos.OS.File.tmp "rd_%s.bat" in - let* () = Bos.OS.File.write batchfile cmd in - let start_secs = Unix.time () in - let rec helper () = - match - Bos.OS.Cmd.run_out ~err:Bos.OS.Cmd.err_run_out - Bos.Cmd.(v comspec % "/c" % Fpath.to_string batchfile) - |> Bos.OS.Cmd.out_string - with - | Ok ("", (_, `Exited 0)) -> Ok () - | Ok (text, (_, `Exited 0)) -> - (* Exit 0 with any stdout/stderr is a problem. We used 'rd /q' - to suppress output, so any output is an error. *) - let now_secs = Unix.time () in - let elapsed_secs = now_secs -. start_secs in - if elapsed_secs > wait_seconds_if_stuck then - Error - (Rresult.R.msgf - "The DOS command 'rd' did not succeed.@,@[%a@]" - Fmt.lines (dos2unix text)) - else ( - (* Retry until time complete *) - Fmt.epr - "@[@,\ - Stuck during uninstallation of %a@,\ - Waited already %5.1f seconds; will wait at most %5.1f \ - seconds.@,\ - %a@,\ - @[ %a@]@]@,\ - @." - Fpath.pp dir elapsed_secs wait_seconds_if_stuck - (styled_stuck_info Fmt.string) - "Please stop and exit the program:" - (styled_stuck_detail Fmt.lines) - (dos2unix text); - Unix.sleep 5; - helper ()) - | Ok (text, (_, `Exited v)) -> - Error - (Rresult.R.msgf - "The DOS command DOS 'rd' exited with exit code %d.@,\ - @[%a@]" - v Fmt.lines (dos2unix text)) - | Ok (text, (_, `Signaled v)) -> - Error - (Rresult.R.msgf - "The DOS command DOS 'rd' was killed by signal %d.@,\ - @[%a@]" - v Fmt.lines (dos2unix text)) - | Error msg -> Error msg - in - helper () - (* + let cmd = + Printf.sprintf "@%s %s %s" cmd options + (Filename.quote (Fpath.to_string path)) + in + let* batchfile = Bos.OS.File.tmp "delpath_%s.bat" in + let* () = Bos.OS.File.write batchfile cmd in + let start_secs = Unix.time () in + let rec helper () = + match + Bos.OS.Cmd.run_out ~err:Bos.OS.Cmd.err_run_out + Bos.Cmd.(v comspec % "/c" % Fpath.to_string batchfile) + |> Bos.OS.Cmd.out_string + with + | Ok ("", (_, `Exited 0)) -> Ok () + | Ok (text, (_, `Exited 0)) -> + (* Exit 0 with any stdout/stderr is a problem. We used 'rd /q' or 'del /q' + to suppress output, so any output is an error. *) + let now_secs = Unix.time () in + let elapsed_secs = now_secs -. start_secs in + if elapsed_secs > wait_seconds_if_stuck then + Error + (Rresult.R.msgf "The DOS command '%s' did not succeed.@,@[%a@]" + cmd Fmt.lines (dos2unix text)) + else ( + (* Retry until time complete *) + Fmt.epr + "@[@,\ + Stuck during uninstallation of %a@,\ + Waited already %5.1f seconds; will wait at most %5.1f seconds.@,\ + %a@,\ + @[ %a@]@]@,\ + @." + Fpath.pp path elapsed_secs wait_seconds_if_stuck + (styled_stuck_info Fmt.string) + "Please stop and exit the program:" + (styled_stuck_detail Fmt.lines) + (dos2unix text); + Unix.sleep 5; + helper ()) + | Ok (text, (_, `Exited v)) -> + Error + (Rresult.R.msgf + "The DOS command DOS '%s' exited with exit code %d.@,@[%a@]" cmd + v Fmt.lines (dos2unix text)) + | Ok (text, (_, `Signaled v)) -> + Error + (Rresult.R.msgf + "The DOS command DOS '%s' was killed by signal %d.@,@[%a@]" cmd + v Fmt.lines (dos2unix text)) + | Error msg -> Error msg + in + helper () +(* let helper () = match Bos.OS.Cmd.run_out Bos.Cmd.(v comspec % "/c" % cmd) @@ -328,35 +310,35 @@ let uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck = helper () *) - (* let ic = - Unix.open_process_args_in comspec - [| "/s"; "/c"; cmd |] - in - let rd_output = really_input_string ic 0 |> dos2unix in - match Unix.close_process_in ic with - | WEXITED 0 when rd_output = "" -> Ok () - | WEXITED 0 -> - Error - (Rresult.R.msgf - "DOS 'rd' exited with exit code 0, but should not have \ - produced output.@,\ - @[%a@]" - Fmt.lines rd_output) - | WEXITED v -> - Error - (Rresult.R.msgf "DOS 'rd' exited with exit code %d.@,@[%a@]" - v Fmt.lines rd_output) - | WSIGNALED v -> - Error - (Rresult.R.msgf "DOS 'rd' killed by signal %d.@,@[%a@]" v - Fmt.lines rd_output) - | WSTOPPED v -> - Error - (Rresult.R.msgf "DOS 'rd' stopped by signal %d.@,@[%a@]" v - Fmt.lines rd_output)) - *) +(* let ic = + Unix.open_process_args_in comspec + [| "/s"; "/c"; cmd |] + in + let rd_output = really_input_string ic 0 |> dos2unix in + match Unix.close_process_in ic with + | WEXITED 0 when rd_output = "" -> Ok () + | WEXITED 0 -> + Error + (Rresult.R.msgf + "DOS 'rd' exited with exit code 0, but should not have \ + produced output.@,\ + @[%a@]" + Fmt.lines rd_output) + | WEXITED v -> + Error + (Rresult.R.msgf "DOS 'rd' exited with exit code %d.@,@[%a@]" + v Fmt.lines rd_output) + | WSIGNALED v -> + Error + (Rresult.R.msgf "DOS 'rd' killed by signal %d.@,@[%a@]" v + Fmt.lines rd_output) + | WSTOPPED v -> + Error + (Rresult.R.msgf "DOS 'rd' stopped by signal %d.@,@[%a@]" v + Fmt.lines rd_output)) +*) - (* +(* (match Unix.system cmd with | WEXITED 0 -> Ok () | WEXITED v -> @@ -366,6 +348,45 @@ let uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck = | WSTOPPED v -> Error (Rresult.R.msgf "DOS 'rd' stopped by signal %d" v)) *) + +let uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck = + let open Immediate_fail (struct + let id = id + end) in + (* On Windows we need to get write access before you can delete the + file. *) + let fl = Forward_progress.stderr_fatallog in + let sequence = + let* exists = Bos.OS.Path.exists dir in + if exists then ( + Logs.info (fun m -> m "Uninstalling directory: %a" Fpath.pp dir); + let* () = chmod_plus_readwrite_dir ~id dir in + (* + OS.Dir.delete has bizarre error messages, like: + + C:\Users\beckf\AppData\Local\Temp\build999583.dune\test_uninstall_7b4501\cmd.exe: The directory name is invalid. + + when the above cmd.exe is being used. So we use cmd.exe on Windows instead which + has user-friendly DOS error messages. + *) + match (Sys.win32, Bos.OS.Env.var "COMSPEC") with + | true, Some comspec when comspec != "" -> + (* + https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/rd + + Example: + + rd "C:\Temp\abc" /s /q + + And instead of dealing with insane OCaml + DOS quoting issues, will + create a temporary batch file and execute that. + + Other complexity is we won't get any error codes from `rd`. But we will get: + C:\Users\beckf\AppData\Local\Temp\f46f0508-df03-40e8-8661-728f1be41647\UninstallBlueGreenDeploy2\0\cmd.exe - Access is denied. + So any output on the error console indicates a problem. + *) + delete_path_on_windows ~id ~path:dir ~wait_seconds_if_stuck ~comspec + ~cmd:"rd" ~options:"/s /q" | _ -> Bos.OS.Dir.delete ~recurse:true dir) else Ok () in @@ -376,3 +397,52 @@ let uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck = (Fmt.str "The directory@ %a@ could not be uninstalled due to: %a" Fpath.pp dir Rresult.R.pp_msg rmsg); exit (Forward_progress.Exit_code.to_int_exitcode Exit_transient_failure) + +let uninstall_file_onerror_exit ~id ~file ~wait_seconds_if_stuck = + let open Immediate_fail (struct + let id = id + end) in + (* On Windows we need to get write access before you can delete the file. *) + let fl = Forward_progress.stderr_fatallog in + let sequence = + let* exists = Bos.OS.Path.exists file in + if exists then ( + Logs.info (fun m -> m "Uninstalling file: %a" Fpath.pp file); + let* () = chmod_plus_readwrite_path ~id file in + (* + OS.Dir.delete has bizarre error messages, like: + + C:\Users\beckf\AppData\Local\Temp\build999583.dune\test_uninstall_7b4501\cmd.exe: The directory name is invalid. + + when the above cmd.exe is being used. So we use cmd.exe on Windows instead which + has user-friendly DOS error messages. + *) + match (Sys.win32, Bos.OS.Env.var "COMSPEC") with + | true, Some comspec when comspec != "" -> + (* + https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/del + + Example: + + del "C:\Temp\abc" /f /q + + And instead of dealing with insane OCaml + DOS quoting issues, will + create a temporary batch file and execute that. + + Other complexity is we won't get any error codes from `del`. But we will get: + Y:\temp\ocamllsp.exe + Access is denied. + So any output on the error console indicates a problem. + *) + delete_path_on_windows ~id ~path:file ~wait_seconds_if_stuck ~comspec + ~cmd:"del" ~options:"/f /q" + | _ -> Bos.OS.File.delete file) + else Ok () + in + match sequence with + | Ok () -> () + | Error rmsg -> + fl ~id + (Fmt.str "The file@ %a@ could not be uninstalled due to: %a" Fpath.pp + file Rresult.R.pp_msg rmsg); + exit (Forward_progress.Exit_code.to_int_exitcode Exit_transient_failure) diff --git a/api/dkml_install_api_intf.ml b/api/dkml_install_api_intf.ml index ed138c8..834a46d 100644 --- a/api/dkml_install_api_intf.ml +++ b/api/dkml_install_api_intf.ml @@ -271,7 +271,7 @@ module type Intf = sig val uninstall_directory_onerror_exit : id:string -> dir:Fpath.t -> wait_seconds_if_stuck:float -> unit - (** [uninstall_directory ~id ~dir ~wait_seconds_if_stuck] removes the directory [dir] and, if any process + (** [uninstall_directory_onerror_exit ~id ~dir ~wait_seconds_if_stuck] removes the directory [dir] and, if any process is using the files in [dir], will give the [wait_seconds_if_stuck] seconds to stop using the program. If the directory cannot be removed then prints an error on the fatal logger [fl ~id] and exists with a transient error code. @@ -281,6 +281,18 @@ module type Intf = sig only on Windows machines will trigger the logic to check if a process is using a file or directory. This behavior may change in the future. *) + val uninstall_file_onerror_exit : + id:string -> file:Fpath.t -> wait_seconds_if_stuck:float -> unit + (** [uninstall_file_onerror_exit ~id ~dir ~wait_seconds_if_stuck] removes the file [file] and, if the file + is currently in use, will give the [wait_seconds_if_stuck] seconds to stop using the + file. If the file cannot be removed then prints an error on the + fatal logger [fl ~id] and exists with a transient error code. + + For Windows machines a file cannot be removed if it is in use. For most *nix + machines the file can be removed since the inode lives on. Consequently + only on Windows machines will trigger the logic to check if a process + is using the file. This behavior may change in the future. *) + (** {2 Logging}