Source file ThunkIoDisk.ml

let alwaystrace = false

let logtrace =
  let ppf x = Format.eprintf ("[MlFront_Thunk.ThunkIoDisk] " ^^ x ^^ "@.") in
  fun ?trace f -> if alwaystrace || trace = Some true then f ppf

let io_rng = ref None
let io_rng_warned = ref false

let random_int64 () =
  match !io_rng with
  | Some rng -> rng ()
  | None ->
      if not !io_rng_warned then begin
        io_rng_warned := true;
        prerr_endline
          "[warning]: using insecure random generator for I/O operations";
        flush stderr
      end;
      Random.bits64 ()

let default_read_bufsize =
  match Sys.backend_type with
  | Sys.Other "js_of_ocaml" | Sys.Bytecode -> 16_384
  | Sys.Native | Sys.Other _ -> 1_048_576

let set_io_rng rng = io_rng := Some rng

(** [longpath_capable_filepath ~absbasepath fp] converts [fp] into a file path
    on Windows that can exceed [MAX_PATH] 260 characters if the file path is
    given to MlFront_ZipFile functions. On Unix [fp] is kept as-is. *)
let longpath_capable_filepath ~absbasepath ~functions fp =
  if Sys.win32 then
    (* MlFront_ZipFile uses miniz.h which uses [_wfopen] and [_wfopen_s]
       to open files. *)
    match
      ( functions,
        MlFront_Core.FilePath.absolute ~style:`WindowsDeviceNamespace
          ~base:absbasepath fp )
    with
    | `MlFront_ZipFile, Some win_fp -> MlFront_Core.FilePath.to_string win_fp
    | `MlFront_ZipFile, None -> MlFront_Core.FilePath.to_string fp
  else MlFront_Core.FilePath.to_string fp

(** Remove directory recursively *)
let remove_file_or_directory_recursively ~return (dir : MlFront_Core.FilePath.t)
    =
  (* WARNING: Cloned in MetaDb.ml *)
  let clear_windows_readonly ~mode path =
    if Sys.win32 then
      try Unix.chmod path mode
      with Sys_error _ | Unix.Unix_error (Unix.ENOENT, _, _) -> ()
  in
  (* TODO: Retry when there are inevitable race conditions. *)
  logtrace (fun l ->
      l "@[<v 2>Removing directory `%s` recursively:@;%a@]"
        (MlFront_Core.FilePath.to_string dir)
        (fun ppf s ->
          let lines = String.split_on_char '\n' s in
          List.iteri
            (fun idx line ->
              if idx > 0 then Format.fprintf ppf "@;";
              Format.fprintf ppf "%s" line)
            lines)
        (Printexc.raw_backtrace_to_string (Printexc.get_callstack 10)));
  let exception Stop of string in
  try
    let rec aux readonly_status path =
      match Unix.lstat path with
      | { st_kind = S_LNK; _ } ->
          (* symlinks are deleted, not traversed (even if they are
              symlinked directories) *)
          Unix.unlink path
      | { st_kind = S_DIR; _ } ->
          (* directories are traversed *)
          Array.iter (aux `ReadOnlyUnknown)
            (Sys.readdir path |> Array.map (Filename.concat path));
          Unix.rmdir path
      | _ ->
          (* anything else is deleted *)
          Unix.unlink path
      | exception Unix.Unix_error (Unix.EACCES, _fname, _arg)
        when Sys.win32 && readonly_status = `ReadOnlyUnknown ->
          (* On Windows, we may get EACCES when trying to delete a read-only file.
             We try to clear the read-only flag and delete again. *)
          clear_windows_readonly ~mode:0o644 path;
          aux `ReadOnlySet path
      | exception Unix.Unix_error (Unix.ENOENT, _fname, _arg) ->
          (* it is ok if the file is not there:
             1. may be a race condition (external process is deleting the file)
             2. the function may have been called on an already removed directory *)
          ()
      | exception Unix.Unix_error (e, fname, arg) ->
          raise
            (Stop
               (Printf.sprintf
                  "deleting directory `%s` had the error `%s` for %s"
                  (MlFront_Core.FilePath.to_string dir)
                  (Unix.error_message e)
                  (if String.equal arg "" then fname else fname ^ " " ^ arg)))
      | exception Sys_error e ->
          raise
            (Stop
               (Printf.sprintf "deleting directory `%s` had the error `%s`"
                  (MlFront_Core.FilePath.to_string dir)
                  e))
    in
    aux `ReadOnlyUnknown (MlFront_Core.FilePath.to_string dir);
    return `Deleted
  with Stop msg -> return (`Error msg)

let graceful_mkdir dir_s mode =
  (* WARNING: Cloned in MetaDb.ml *)
  try Unix.mkdir dir_s mode
  with Unix.Unix_error (Unix.EEXIST, _, _) ->
    (* it is ok if the directory already exists *)
    ()

(** Make a directory recursively *)
let make_directory_recursively ~return (dir : MlFront_Core.FilePath.t) =
  (* WARNING: Cloned in MetaDb.ml *)
  let dir_s = MlFront_Core.FilePath.to_string dir in
  try
    if Sys.file_exists dir_s then
      (* optimization 1: short-circuit if the directory exists *)
      return `Created
    else
      let parent_dir_s = MlFront_Core.FilePath.(parent dir |> to_string) in
      if Sys.file_exists parent_dir_s then (
        (* optimization 2: parent directory exists *)
        graceful_mkdir dir_s 0o755;
        return `Created)
      else
        (* possibly expensive fallback: recreate from root *)
        let root_result =
          MlFront_Core.FilePath.(
            of_string
              (if is_absolute dir then root_noslash dir ^ slash dir else ""))
        in
        match root_result with
        | Error msg ->
            return
              (`Error (Printf.sprintf "invalid file path `%s`: %s" dir_s msg))
        | Ok root ->
            let rec aux fp = function
              | [] -> `Created
              | segment :: rest -> begin
                  match MlFront_Core.FilePath.append fp segment with
                  | Error msg ->
                      `Error
                        (Printf.sprintf
                           "`%s` can't be added to file path `%s`: %s" segment
                           (MlFront_Core.FilePath.to_string fp)
                           msg)
                  | Ok fp ->
                      let path_s = MlFront_Core.FilePath.to_string fp in
                      if not (Sys.file_exists path_s) then begin
                        graceful_mkdir path_s 0o755
                      end;
                      aux fp rest
                end
            in
            return (aux root (MlFront_Core.FilePath.rootless_segments dir))
  with
  | Unix.Unix_error (e, fname, arg) ->
      return
        (`Error
           (Printf.sprintf "creating directory `%s` had the error `%s` for %s"
              dir_s (Unix.error_message e)
              (if String.equal arg "" then fname else fname ^ " " ^ arg)))
  | Sys_error e ->
      return
        (`Error
           (Printf.sprintf "creating directory `%s` had the error `%s`" dir_s e))

let delete_local_file ~return local_file =
  try
    (* For Windows, can't write (or delete) without turning off
           read-only flag. *)
    (if Sys.win32 then try Unix.chmod local_file 0o644 with Sys_error _ -> ());
    Unix.unlink local_file;
    return `Deleted
  with
  | Unix.Unix_error (Unix.ENOENT, _, _) ->
      (* If the file does not exist, we do not raise an error. *)
      return `Deleted
  | Unix.Unix_error (e, fname, arg) ->
      return
        (`Error
           (Printf.sprintf "deleting file `%s` had the error `%s` in `%s`"
              local_file (Unix.error_message e)
              (if String.equal arg "" then fname else fname ^ " " ^ arg)))
  | Sys_error e ->
      if Sys.file_exists local_file then
        return
          (`Error
             (Printf.sprintf "deleting file `%s` had the error `%s`" local_file
                e))
      else return `Deleted

let move_local_file ~return ~src_local_file ~dst_local_file =
  let exception Stop of string in
  let max_windows_retries = 10 in
  let base_windows_retry_delay_sec = 0.01 in
  let max_windows_retry_delay_sec = 0.5 in
  let sleep ~attempt =
    let delay =
      min max_windows_retry_delay_sec
        (base_windows_retry_delay_sec *. (2. ** float_of_int attempt))
    in
    (* wait up to [delay] seconds for I/O to be possible *)
    let (_ : Unix.file_descr list * Unix.file_descr list * Unix.file_descr list)
        =
      Unix.select [] [] [] delay
    in
    ()
  in
  let rec aux retries_left =
    (* For Windows, can't write (or delete) without turning off
     read-only flag. *)
    (if Sys.win32 then
       try
         (* it is fine if the file does not exist (ENOENT) *)
         Unix.chmod dst_local_file 0o644
       with Sys_error _ | Unix.Unix_error (Unix.ENOENT, _, _) -> ());
    (* Now rename. *)
    try Unix.rename src_local_file dst_local_file with
    | Unix.Unix_error ((Unix.EACCES | Unix.EPERM), _, _)
      when Sys.win32 && retries_left > 0 ->
        let attempt = max_windows_retries - retries_left in
        sleep ~attempt;
        aux (retries_left - 1)
    | Sys_error e
      when Sys.win32
           && String.ends_with ~suffix:"Permission denied" e
           && retries_left > 0 ->
        let attempt = max_windows_retries - retries_left in
        sleep ~attempt;
        aux (retries_left - 1)
    | Unix.Unix_error (e, fname, arg) ->
        let msg =
          Printf.sprintf "moving file `%s` to `%s` had error `%s` for %s"
            src_local_file dst_local_file (Unix.error_message e)
            (if String.equal arg "" then fname else fname ^ " " ^ arg)
        in
        raise (Stop msg)
    | Sys_error e ->
        let msg =
          Printf.sprintf "moving file `%s` to `%s` had error `%s`"
            src_local_file dst_local_file e
        in
        raise (Stop msg)
  in
  (* We retry because intermittely get "Permission denied" on Windows,
     perhaps due to async Windows Defender. *)
  try
    aux max_windows_retries;
    return `Moved
  with Stop msg -> return (`Error msg)

(** The trivial passthrough monad. *)
module Pass : MlFront_Thunk.BuildConstraints.MONAD with type 'a t = 'a = struct
  type 'a t = 'a

  let bind x f = f x
  let return x = x
  let pure x = x
  let map : ('a -> 'b) -> 'a -> 'b = fun f x -> f x
  let apply : ('a -> 'b) -> 'a -> 'b = fun f x -> f x
end

let checksum_local_file ?dos2unix ?(start_at = 0L) ?len ~algo ~return local_file
    =
  let module MBytes = MlFront_Thunk.ThunkBytes.Make (Pass) in
  try
    In_channel.with_open_bin local_file (fun ic ->
        let transferresult =
          MBytes.transfer ?dos2unix ~start_at ?len ~algo
            ~bufsize:default_read_bufsize
            ~read_some:(fun bs off blen ->
              let n = In_channel.input ic bs off blen in
              if n = 0 then Pass.return `Eof else Pass.return (`ReadBytes n))
            ~write_all:(fun _bs _off _blen -> Pass.return `WroteBytes)
            ()
        in
        match transferresult with
        | Error e -> return (`Error e)
        | Ok { write_checksum; write_total } ->
            return (`Checksum (write_checksum, write_total)))
  with Sys_error e -> return (`Error e)

type index_value = {
  indexvalue_local_offset : int64;
  indexvalue_central_offset : int64;
  indexvalue_central_size : int64;
  indexvalue_checksum_blake2b256 : string;
}

open struct
  (* Duplicate of ThunkChecksum *)
  module BLAKE2B_256 = Digestif.Make_BLAKE2B (struct
    let digest_size = 32
  end)
end

let index_local_zipfile ~return ~srczip ~indexzip () =
  try
    let index_value =
      MlFront_ZipFile.ZipFile.zip_add_index_exn ~deterministic:() ~srczip
        ~destzip:indexzip ()
    in
    (* Get BLAKE2B-256 checksum for central directory of [srczip]. *)
    let cksum =
      In_channel.with_open_bin srczip (fun ic ->
          In_channel.seek ic index_value.source_central_directory_offset;
          let bufsize = default_read_bufsize in
          let buf = Bytes.create bufsize in
          let ctx = BLAKE2B_256.init () in
          let rec aux ctx remaining_size =
            if remaining_size <= 0L then ctx
            else
              let to_read =
                Int64.to_int (Int64.min (Int64.of_int bufsize) remaining_size)
              in
              let n = In_channel.input ic buf 0 to_read in
              if n = 0 then ctx
              else
                let ctx = BLAKE2B_256.feed_bytes ctx buf ~off:0 ~len:n in
                aux ctx (Int64.sub remaining_size (Int64.of_int n))
          in
          let ctx' = aux ctx index_value.source_central_directory_eocd_size in
          BLAKE2B_256.get ctx')
    in
    return
      (Ok
         {
           indexvalue_local_offset = index_value.source_local_header_offset;
           indexvalue_central_offset =
             index_value.source_central_directory_offset;
           indexvalue_central_size =
             index_value.source_central_directory_eocd_size;
           indexvalue_checksum_blake2b256 = BLAKE2B_256.to_hex cksum;
         })
  with
  | MlFront_ZipFile.ZipFile.ZipError (_zipfile, msg) -> return (Error msg)
  | Sys_error msg -> return (Error msg)

module Support (M : MlFront_Thunk.BuildConstraints.MONAD_PROMISE) = struct
  let mk_env_arr envmods =
    let envpairs =
      Unix.environment () |> Array.to_list
      |> List.map (Stringext.cut ~on:"=")
      |> List.filter_map Fun.id
    in
    Array.of_list
      (List.map
         (fun (k, v) -> k ^ "=" ^ v)
         (MlFront_Core.EnvMods.apply ~win32:Sys.win32 envmods envpairs))
end

module MakeRacyTestSpawner (M : MlFront_Thunk.BuildConstraints.MONAD_PROMISE) =
struct
  type 'a t = 'a M.t

  open Support (M)

  let spawn ?stdout ?stderr ?progress:_ ~unix_cmdline:(command, args)
      ~windows_appname:_ ~windows_cmdline:_ ~envmods ~dir () =
    let dir_s = MlFront_Core.FilePath.to_string dir in
    let env = mk_env_arr envmods in
    let command_s = MlFront_Core.FilePath.to_string command in
    let args = Array.of_list (command_s :: args) in
    let in_channel, out_channel, err_channel = (ref None, ref None, ref None) in
    Fun.protect
      ~finally:(fun () ->
        (match !in_channel with Some ic -> Unix.close ic | None -> ());
        (match !out_channel with Some oc -> Unix.close oc | None -> ());
        match !err_channel with Some ec -> Unix.close ec | None -> ())
      (fun () ->
        (* /dev/null or NUL for stdin *)
        let in_fd =
          Unix.openfile
            (if Sys.win32 then "NUL" else "/dev/null")
            [ Unix.O_RDONLY ] 0o644
        in
        in_channel := Some in_fd;
        (* files for stdout and stderr *)
        let out_fd =
          Option.map
            (fun stdout ->
              let stdout_s = MlFront_Core.FilePath.to_string stdout in
              let out_fd =
                Unix.openfile stdout_s
                  [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_CLOEXEC ]
                  0o644
              in
              out_channel := Some out_fd;
              out_fd)
            stdout
        in
        let err_fd =
          Option.map
            (fun stderr ->
              let stderr_s = MlFront_Core.FilePath.to_string stderr in
              let err_fd =
                Unix.openfile stderr_s
                  [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; Unix.O_CLOEXEC ]
                  0o644
              in
              err_channel := Some err_fd;
              err_fd)
            stderr
        in
        (* create the process *)
        try
          (* for an instant before we create the process asynchronously,
               we have to change the directory. *)
          let pwd = Sys.getcwd () in
          Unix.chdir dir_s;
          let pid =
            Fun.protect
              ~finally:(fun () -> Unix.chdir pwd)
              (fun () ->
                Unix.create_process_env command_s args env in_fd
                  (Option.value ~default:Unix.stdout out_fd)
                  (Option.value ~default:Unix.stderr err_fd))
          in
          (* wait for process to finish *)
          let ret =
            match Unix.waitpid [] pid with
            | _childpid, Unix.WEXITED ec -> `Exited ec
            | _childpid, Unix.WSIGNALED s -> `Signaled s
            | _childpid, Unix.WSTOPPED s -> `Stopped s
          in
          M.pure ret
        with Unix.Unix_error (Unix.ENOENT, _, _) ->
          M.pure (`Error (Printf.sprintf "command not found: `%s`" command_s)))
end

module Make
    (M : MlFront_Thunk.BuildConstraints.MONAD_PROMISE)
    (S : MlFront_Thunk.ThunkSpawner.S with type 'a t = 'a M.t) =
struct
  open Support (M)
  include MlFront_Thunk.ThunkIo.Make (M)

  (** [memory_limit].

      16 MiB is the maximum on 32-bit OCaml platforms for a single string.
      However, js_of_ocaml uses maximum JavaScript string size which is
      undocumented but at least 2^51.

      We'll use [2^31 - 1] as limit for now as that is the memory bound for
      32-bit signed C integers. *)
  let memory_limit = 2147483647L

  open struct
    let safe_is_directory s = try Sys.is_directory s with Sys_error _ -> false

    let sys_error_is_a_directory ~path s =
      if String.equal s "Is a directory" then
        (* macOS *)
        true
      else if
        String.ends_with ~suffix:"Permission denied" s
        && Sys.win32 && safe_is_directory path
      then
        (* Windows has errors like: "./src: Permission denied".
       We double-check with a racy check. *)
        true
      else false

    let disk_node_id = ref 0L
  end

  let rec disk_dir origin =
    let origin_fp = MlFront_Core.FilePath.to_string origin in
    let dir_path = origin in
    let directory_object_of_local_path path = M.return (Ok (disk_dir path)) in
    let create_directory () =
      make_directory_recursively ~return:M.return origin
    in
    let create_directory_async () =
      match make_directory_recursively ~return:Fun.id origin with
      | `Created -> ()
      | `Error msg ->
          Printf.eprintf "[warning]: error creating directory `%s`: %s\n"
            origin_fp msg
    in
    let anonymous_directory prefix suffix =
      let basename_ =
        Printf.sprintf "%s%Ld%s" prefix (random_int64 ()) suffix
      in
      MlFront_Thunk.Assumptions
      .anonymous_directory_is_subdirectory_of_destination_directory ();
      let anon_origin = MlFront_Core.FilePath.(append_exn origin basename_) in
      M.return (`Anonymous (disk_dir anon_origin))
    in
    let child_if_exists name =
      match MlFront_Core.FilePath.append origin name with
      | Error _msg -> M.return None
      | Ok child_path ->
          let child_path_s = MlFront_Core.FilePath.to_string child_path in
          if Sys.file_exists child_path_s then
            if Sys.is_directory child_path_s then
              M.return (Some (Either.right (disk_dir child_path)))
            else M.return (Some (Either.left (disk_file child_path)))
          else M.return None
    in
    let visit_directory =
      let ( let* ) = M.bind in
      fun (Visitor { init; file; directory; finished }) ->
        let rec aux ~parentdir acc =
          let parentdir_s = MlFront_Core.FilePath.to_string parentdir in
          let entries =
            Sys.readdir parentdir_s |> Array.to_list |> List.sort String.compare
            |> List.filter_map (fun s ->
                   MlFront_Core.FilePath.append parentdir s |> Result.to_option)
            |> List.map (fun entry_fp ->
                   if
                     Sys.is_directory (MlFront_Core.FilePath.to_string entry_fp)
                   then `Directory entry_fp
                   else `File entry_fp)
          in
          let rec loop acc =
           (function
           | [] -> M.return acc
           | `File entry_path :: rest -> (
               let file_obj = disk_file entry_path in
               let* acc, action = file acc file_obj in
               match action with
               | `Stop -> M.return acc
               | `Next -> loop acc rest)
           | `Directory entry_path :: rest -> (
               let dir_obj = disk_dir entry_path in
               let* acc, action = directory acc dir_obj in
               match action with
               | `Stop -> M.return acc
               | `SkipDir -> loop acc rest
               | `Descend ->
                   let* acc = aux ~parentdir:entry_path acc in
                   loop acc rest))
          in
          loop acc entries
        in
        let* acc = aux ~parentdir:origin init in
        finished acc
    in

    let delete_directory () =
      remove_file_or_directory_recursively ~return:M.return origin
    in
    let delete_directory_async () =
      let task ~warn_on_error () =
        match remove_file_or_directory_recursively ~return:Fun.id origin with
        | `Deleted -> `Deleted
        | `Error msg ->
            if warn_on_error then
              Printf.eprintf "[warning]: error deleting directory `%s`: %s\n"
                origin_fp msg;
            `NotDeleted
      in
      (* In our simple implementation, we delete immediately
         and then try again at process exit if needed. *)
      match task ~warn_on_error:true () with
      | `Deleted -> ()
      | `NotDeleted ->
          at_exit (fun () ->
              let _ : [ `Deleted | `NotDeleted ] =
                task ~warn_on_error:false ()
              in
              ())
    in
    let zip_directory_nonatomic ?intermediate ~dest_file () =
      let pending_deletion_file = ref None in
      Fun.protect
        ~finally:(fun () ->
          if intermediate = None then
            try
              Option.iter
                (fun f -> f.delete_file_async ())
                !pending_deletion_file
            with Sys_error _ -> ())
        (fun () ->
          (* make a zip file *)
          pending_deletion_file := Some dest_file;
          (* if the source or destination is an absolute path,
             we can use [longpath_capable_filepath] *)
          MlFront_Thunk.Assumptions
          .mlfront_zipfile_accepts_long_paths_on_windows ();
          let dest_fp = file_path dest_file in
          let destzip =
            if MlFront_Core.FilePath.is_absolute dest_fp then
              longpath_capable_filepath ~absbasepath:dest_fp
                ~functions:`MlFront_ZipFile dest_fp
            else MlFront_Core.FilePath.to_string dest_fp
          in
          let srcdir =
            if MlFront_Core.FilePath.is_absolute origin then
              longpath_capable_filepath ~absbasepath:origin
                ~functions:`MlFront_ZipFile origin
            else MlFront_Core.FilePath.to_string origin
          in
          match
            MlFront_ZipFile.ZipFile.zip_exn ~deterministic:() ~srcdir ~destzip
              ()
          with
          | () ->
              pending_deletion_file := None;
              M.pure `Zipped
          | exception MlFront_ZipFile.ZipFile.ZipError (_zipfile, message) ->
              M.pure (`Error (Printf.sprintf "zipping had error '%s'" message)))
    in
    let interactive_shell_in_directory ?promptname ~envmods () =
      let ( let* ) = M.bind in
      (* Common functions for using the optional prompt *)
      let template name =
        (* Avoid escaping of % in Printf. Instead use literal search/replace *)
        Stringext.replace_all ~pattern:"<PROMPTNAME>" ~with_:name
      in
      let add_if_prompt opts l =
        match promptname with
        | None -> l
        | Some pname -> l @ List.map (template pname) opts
      in
      (* Different logic based on Windows or Unix *)
      if Sys.win32 then
        let original_pwd = Sys.getcwd () in
        match MlFront_Core.FilePath.of_string original_pwd with
        | Error msg ->
            M.pure
              (`Error
                 (Printf.sprintf "invalid current working directory `%s`: %s"
                    original_pwd msg))
        | Ok original_pwd_fp -> (
            let absolute_origin =
              MlFront_Core.FilePath.to_string
                (MlFront_Core.FilePath.concat original_pwd_fp origin)
            in
            let env = mk_env_arr envmods in
            (* NOTE: We can use [Sys.command], [Unix.create_process*] and [Unix.open_process*]
           but not [Unix.exec*] because the latter cooks the Windows Terminal.
           Confer https://github.com/ocaml/ocaml/pull/13879 *)
            let run_get_trimmed_stdout cmd =
              let stdout, stdin, stderr = Unix.open_process_full cmd env in
              Out_channel.close stdin;
              In_channel.close stderr;
              let output = In_channel.input_all stdout in
              In_channel.close stdout;
              String.trim output
            in
            let attempt :
                [ `Error of string
                | `Exited of int
                | `Signaled of int
                | `Stopped of int
                | `TryNext ] =
              `TryNext
            in
            let attempt_chdir_and_run_if_needed attempt command args =
              match attempt with
              | `Error e -> M.pure (`Error e)
              | `Exited ec -> M.pure (`Exited ec)
              | `Signaled ec -> M.pure (`Signaled ec)
              | `Stopped ec -> M.pure (`Stopped ec)
              | `TryNext ->
                  let full_command =
                    run_get_trimmed_stdout
                      (Printf.sprintf "where.exe %s" command)
                  in
                  if String.equal full_command "" then M.pure `TryNext
                  else begin
                    Unix.chdir origin_fp;
                    let pid =
                      Fun.protect
                        ~finally:(fun () -> Unix.chdir original_pwd)
                        (fun () ->
                          Unix.create_process_env full_command
                            (Array.of_list (full_command :: args))
                            env Unix.stdin Unix.stdout Unix.stderr)
                    in
                    (* wait for process to finish *)
                    let ret =
                      match Unix.waitpid [] pid with
                      | _childpid, Unix.WEXITED ec -> `Exited ec
                      | _childpid, Unix.WSIGNALED s -> `Signaled s
                      | _childpid, Unix.WSTOPPED s -> `Stopped s
                    in
                    M.pure ret
                  end
            in

            (* PowerShell prompt ...
           https://learn.microsoft.com/en-us/powershell/module/microsoft.powershell.core/about/about_prompts?view=powershell-7.5#how-to-customize-the-prompt *)
            let powershell_prompt () =
              [
                Printf.sprintf
                  {|function prompt {
    $currentLocation = Get-Location
    $BaseDirectory = "%s"
    $PromptName = "<PROMPTNAME>"

    if ($currentLocation.Path.StartsWith($BaseDirectory)) {
        $relativePath = $currentLocation.Path.Substring($BaseDirectory.Length)
        if ($relativePath -eq "") {
            $PromptValue = "$PromptName"
        } else {
            $PromptValue = "$PromptName$relativePath"
        }
    } else {
        $PromptValue = $currentLocation.Path
    }

    Write-Host "PS $PromptValue>" -NoNewline -ForegroundColor 3
    return " "
} |}
                  absolute_origin;
              ]
              (* [@@warning "-unused-var"] *)
            in

            (* Powershell 7+. https://learn.microsoft.com/en-us/powershell/module/microsoft.powershell.core/about/about_pwsh?view=powershell-7.5 *)
            let* attempt =
              attempt_chdir_and_run_if_needed attempt "pwsh"
                ([ "-Interactive"; "-NoProfile"; "-NoExit"; "-Command" ]
                |> add_if_prompt (powershell_prompt ()))
            in
            (* Powershell 3+. https://learn.microsoft.com/en-us/powershell/module/microsoft.powershell.core/about/about_powershell_exe?view=powershell-5.1 *)
            let* attempt =
              attempt_chdir_and_run_if_needed attempt "powershell"
                ([ "-NoProfile"; "-NoExit"; "-Command" ]
                |> add_if_prompt (powershell_prompt ()))
            in
            (* Command Prompt. https://learn.microsoft.com/en-us/windows-server/administration/windows-commands/cmd *)
            let* attempt =
              attempt_chdir_and_run_if_needed attempt "cmd"
                [ "/d"; "/u"; "/e:on"; "/f:on" ]
            in
            (* Gather errors *)
            match attempt with
            | `Signaled ec -> M.pure (`Signaled ec)
            | `Stopped ec -> M.pure (`Stopped ec)
            | `Exited 0 -> M.pure (`Exited 0)
            | `Exited ec ->
                M.pure (`Error (Printf.sprintf "failed with exit code %d" ec))
            | `TryNext ->
                M.pure
                  (`Error
                     (Printf.sprintf
                        "Command Prompt `cmd.exe` interpreter was not found"))
            | `Error e -> M.pure (`Error e))
      else begin
        (* Unix shells do not have something like -WorkingDirectory. *)
        Unix.chdir origin_fp;
        (* *)
        let shell, opts, envmods =
          let ew suffix = String.ends_with ~suffix in
          let set_if_prompt name value envmods =
            match promptname with
            | None -> envmods
            | Some pname ->
                (* Use [union] to not override the thunk envmods! *)
                MlFront_Core.EnvMods.(
                  union (add name (template pname value) empty) envmods)
          in
          match Sys.getenv_opt "SHELL" with
          | None | Some "" -> ("/bin/sh", [ "-i" ], envmods)
          | Some s when ew "bash" s ->
              (* GNU bash, version 5.2.37(1)-release (aarch64-apple-darwin23.4.0)
               requires [-i] after long options. *)
              ( s,
                [ "--norc"; "--noprofile"; "-i" ],
                set_if_prompt "PS1"
                  {|\[\033[32m\]<PROMPTNAME> \[\033[34m\]\W\[\033[0m\]\$ |}
                  envmods
                |> set_if_prompt "PROMPT_DIRTRIM" "2" )
          | Some s when ew "zsh" s ->
              ( s,
                [ "-i"; "--no-rcs"; "--no-globalrcs" ],
                set_if_prompt "PROMPT"
                  {|%F{green}<PROMPTNAME>%f %F{blue}%2~%f %# |} envmods )
          | Some s when ew "fish" s ->
              ( s,
                [ "-i"; "--no-config" ]
                |> add_if_prompt
                     [
                       "-C";
                       {|function fish_prompt; set_color green; echo -n '<PROMPTNAME> '; set_color blue; echo -n (prompt_pwd); set_color normal; echo -n '> '; end|};
                     ],
                envmods )
          | Some s when ew "tcsh" s ->
              ( s,
                [ "-i"; "-f" ]
                (* sigh ... no way in tcsh to set this without adding files ...
                
                   |> add_if_prompt
                     [
                       "-c";
                       {|set prompt = "<PROMPTNAME>:%c3/> "; exec tcsh -i -f|};
                     ] *),
                envmods )
          | Some s when ew "csh" s -> (s, [ "-i"; "-f" ], envmods)
          | Some s -> (s, [ "-i" ], envmods)
        in
        let env = mk_env_arr envmods in
        Unix.execvpe shell (Array.of_list (shell :: opts)) env
      end
    in
    let spawn_in_directory ?stdout ?stderr ?progress ~unix_cmdline
        ~windows_appname ~windows_cmdline ~envmods () =
      match (stdout, stderr) with
      | Some o, _ when not (is_local_file o) ->
          M.return
            (`Error
               (Printf.sprintf "stdout `%s` is not a local file" (file_origin o)))
      | _, Some e when not (is_local_file e) ->
          M.return
            (`Error
               (Printf.sprintf "stderr `%s` is not a local file" (file_origin e)))
      | _ ->
          S.spawn
            ?stdout:(Option.map file_path stdout)
            ?stderr:(Option.map file_path stderr)
            ?progress ~unix_cmdline ~windows_appname ~windows_cmdline
            ~envmods ~dir:origin ()
    in
    generic_dir ~dir_path ~origin:origin_fp ~directory_object_of_local_path
      ~child_if_exists ~create_directory ~create_directory_async
      ~anonymous_directory ~visit_directory ~delete_directory
      ~delete_directory_async ~zip_directory_nonatomic ~spawn_in_directory
      ~interactive_shell_in_directory ()

  (** [disk_file origin] creates a new file object that reads from the disk from
      the file [origin]. The file is {b read synchronously}, so use a different
      file object implementation for asynchronous reads. *)
  and disk_file origin : file_object =
    let origin_s = MlFront_Core.FilePath.to_string origin in
    let parent_dir = MlFront_Core.FilePath.parent origin in
    let out_channels = Hashtbl.create 1 in
    let in_channels = Hashtbl.create 1 in
    let file_path = origin in
    let parent_directory = disk_dir parent_dir in
    let file_object_of_local_path local_path =
      let df = disk_file local_path in
      M.return (Ok df)
    in
    let open_for_writing () =
      (* We flush _before_ the file is opened to ensure that
         the output is writable (it is not a directory, etc.).
         If the file is lazily opened, we can't distinguish
         input exceptions from output exceptions. *)
      let success = ref false in
      try
        let oc = Out_channel.open_bin origin_s in
        Fun.protect
          ~finally:(fun () -> if not !success then Out_channel.close oc)
          (fun () ->
            match Out_channel.flush oc with
            | () ->
                let idx = !disk_node_id in
                disk_node_id := Int64.succ !disk_node_id;
                Hashtbl.add out_channels idx oc;
                success := true;
                M.return (`Handle idx)
            | exception Sys_error s
              when sys_error_is_a_directory ~path:origin_s s ->
                M.return (`IsDirectory (disk_dir origin)))
      with Sys_error s ->
        M.return
        @@ `Error
             (Format.asprintf "`%s` while opening `%s` for writing" s origin_s)
    in
    let open_for_reading () =
      (* We have to read at least one byte to make sure the file is not
         readable rather than lazily opened. Similar to flushing in
         open_for_writing to raise exceptions early. *)
      let success = ref false in
      try
        let ic = In_channel.open_bin origin_s in
        Fun.protect
          ~finally:(fun () -> if not !success then In_channel.close ic)
          (fun () ->
            let next_bytes_queue = Queue.create () in
            (match In_channel.input_byte ic with
            | None -> ()
            | Some first_byte -> Queue.add first_byte next_bytes_queue);
            let idx = !disk_node_id in
            disk_node_id := Int64.succ !disk_node_id;
            Hashtbl.add in_channels idx (ic, next_bytes_queue);
            success := true;
            M.return (`Handle idx))
      with
      | Sys_error s when sys_error_is_a_directory ~path:origin_s s ->
          M.return (`IsDirectory (disk_dir origin))
      | Sys_error s ->
          M.return
          @@ `Error
               (Format.asprintf "`%s` while opening `%s` for reading" s origin_s)
    in
    let probe_eof idx =
      match Hashtbl.find_opt in_channels idx with
      | None ->
          M.return (Error (Printf.sprintf "file `%s` is not open" origin_s))
      | Some (channel, next_bytes_queue) -> begin
          match Queue.take_opt next_bytes_queue with
          | Some bs1 ->
              (* we have a byte buffered, so not EOF *)
              Queue.add bs1 next_bytes_queue;
              M.return (Ok false)
          | None -> (
              let byte_read = In_channel.input_byte channel in
              match byte_read with
              | None -> M.return (Ok true)
              | Some b ->
                  Queue.add b next_bytes_queue;
                  M.return (Ok false))
        end
    in
    let read_some idx b pos len =
      match Hashtbl.find_opt in_channels idx with
      | None ->
          M.return (`Error (Printf.sprintf "file `%s` is not open" origin_s))
      | Some (channel, next_bytes_queue) -> begin
          match Queue.take_opt next_bytes_queue with
          | Some first_byte ->
              Bytes.set_int8 b pos first_byte;
              M.return (`ReadBytes 1)
          | None ->
              let bytes_read = In_channel.input channel b pos len in
              if bytes_read = 0 then M.return `Eof
              else M.return (`ReadBytes bytes_read)
        end
    in
    let read_all () =
      let bytes_sz = default_read_bufsize in
      let buf = Buffer.create bytes_sz in
      let bytes = Bytes.create bytes_sz in
      M.pure
      @@
      try
        In_channel.with_open_bin origin_s (fun ic ->
            (* Loop and read up to 1 MB of data *)
            let rec read_loop total_read =
              if Int64.compare total_read memory_limit < 0 then
                let bytes_read = In_channel.input ic bytes 0 bytes_sz in
                if bytes_read = 0 then `Content (Buffer.contents buf)
                else (
                  Buffer.add_subbytes buf bytes 0 bytes_read;
                  read_loop (Int64.add total_read (Int64.of_int bytes_read)))
              else
                (* Exceeded memory. Too big! *)
                `ExceededSizeLimit memory_limit
            in
            read_loop 0L)
      with Sys_error s ->
        `Error
          (Printf.sprintf "`%s` while reading file `%s`" s
             (MlFront_Core.FilePath.show origin))
    in
    let write_all idx str pos len =
      match Hashtbl.find_opt out_channels idx with
      | Some channel ->
          if pos = 0 && len = String.length str then
            Out_channel.output_string channel str
          else Out_channel.output channel (Bytes.unsafe_of_string str) pos len;
          M.return `WroteBytes
      | None ->
          M.return (`Error (Printf.sprintf "file `%s` is not open" origin_s))
    in
    let close idx =
      (match Hashtbl.find_opt out_channels idx with
      | Some channel ->
          Out_channel.close channel;
          (* All generated files on Unix should be executable per the file_object docs. *)
          if not Sys.win32 then Unix.chmod origin_s 0o755
      | None -> ());
      (match Hashtbl.find_opt in_channels idx with
      | Some (channel, _next_bytes_queue) -> In_channel.close channel
      | None -> ());
      Hashtbl.remove out_channels idx;
      Hashtbl.remove in_channels idx;
      M.return ()
    in
    let delete_file () = delete_local_file ~return:M.return origin_s in
    let delete_file_async () =
      (* In our simple implementation, we delete immediately
         and then try again at process exit if needed. *)
      let task ~warn_on_error () =
        match delete_local_file ~return:Fun.id origin_s with
        | `Deleted -> `Deleted
        | `Error msg ->
            if warn_on_error then
              Printf.eprintf "[warning]: error deleting file `%s`: %s\n"
                origin_s msg;
            `NotDeleted
      in
      match task ~warn_on_error:true () with
      | `Deleted -> ()
      | `NotDeleted ->
          at_exit (fun () ->
              let _ : [ `Deleted | `NotDeleted ] =
                task ~warn_on_error:false ()
              in
              ())
    in
    let move_and_own_file (src_file : file_object) =
      let src_s = src_file.file_origin in
      if not src_file.is_local_file then
        M.return
          (`Error
             (Printf.sprintf
                "cannot move non-local file `%s` to local file `%s`" src_s
                (MlFront_Core.FilePath.show origin)))
      else
        move_local_file ~return:M.return ~src_local_file:src_s
          ~dst_local_file:origin_s
    in
    let prepare_as_copy_destination () =
      (* For Windows, can't write without turning off read-only flag.
         In fact, you can still get Permission Denied even after turning
         off read-only flag, perhaps because Windows has a richer
         permissions model than POSIX. So we remove the file
         after turning off read-only *)
      let ( let* ) = M.bind in
      let* predelete_result =
        if Sys.win32 then begin
          delete_file ()
        end
        else M.return `Deleted
      in
      match predelete_result with
      | `Error e -> M.return (`Error e)
      | `Deleted -> M.return `Ready
    in
    let checksum_file ~dos2unix ~start_at ?len ~algo () =
      let dos2unix = if dos2unix then Some () else None in
      checksum_local_file ?dos2unix ~start_at ?len ~algo ~return:M.return
        origin_s
    in
    let anonymous_file prefix suffix =
      let temp_dir = MlFront_Core.FilePath.to_string parent_dir in
      let temp_file_s = Filename.temp_file ~temp_dir prefix suffix in
      match MlFront_Core.FilePath.of_string temp_file_s with
      | Error msg ->
          M.return
            (`Error (Printf.sprintf "invalid temporary file path: %s" msg))
      | Ok temp_file_fp -> M.return (`Anonymous (disk_file temp_file_fp))
    in
    generic_file ~file_path ~origin:origin_s ~parent_directory
      ~is_local_file:true ~file_object_of_local_path ~open_for_writing
      ~open_for_reading ~probe_eof ~read_some ~read_all ~write_all ~close
      ~prepare_as_copy_destination ~anonymous_file ~delete_file
      ~delete_file_async ~move_and_own_file ~checksum_file ()
end