Source file ShellCore.ml

type phase1 = { preconfig : BuildConfig.preconfig }

type phase3 = {
  config : BuildConfig.t;
  initiator : BuildTask.initiator;
  state : BuildEngine.state;
  tasks : BuildEngine.tasks;
  system_keys : [ `ValuesFileSHA256 of string ] list;
}

module MakeInitObserver =
  MlFront_Thunk.ThunkParsers.Results.MakeObserverWithDiagnoseErrors
    (MlFront_Thunk.Diagnose.Diagnose.ConsolePlainStyle)

let quick_error msg =
  let lines = String.split_on_char '\n' msg in
  Format.eprintf "@[<v 1>FATAL: The build failed.@;%a@]@."
    Format.(pp_print_list ~pp_sep:pp_print_cut pp_print_string)
    lines;
  exit 1

let save_file ~contents fp =
  let values_file = BuildCore.Io.disk_file fp in
  match
    BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise
    @@ BuildCore.Io.replace_all_string values_file contents 0
         (String.length contents)
  with
  | `Error msg -> quick_error msg
  | `IsDirectory _ ->
      quick_error
        (Printf.sprintf "`%s` is a directory"
           (MlFront_Core.FilePath.to_string fp))
  | `WroteBytes ->
      Printf.eprintf "Saved %s\n%!" (MlFront_Core.FilePath.to_string fp);
      ()

let run_modules ~request_slot ~forms
    ({ config; initiator = _; state; tasks; system_keys = _ } : phase3)
    module_or =
  (* Run state to get [apply_aliases] *)
  let apply_aliases, state =
    let kont1 = BuildTraceStore.get_apply_aliases ~config in
    BuildEngine.run_continuation kont1 state
  in
  (* Create keys *)
  let form_keys =
    Assumptions.forms_are_public_interface_for_distributions ();
    List.map
      (fun ({ id; version } : MlFront_Thunk.ThunkCommand.module_version) ->
        BuildEngine.create_key_for_form ~apply_aliases:(Some apply_aliases)
          ~debug_reference:None ~module_id:id ~module_semver:version
          ~slot:request_slot ())
      forms
  in
  (* Run state in [run_multiple]. Similar to XGetObject.run *)
  let state_after_run =
    let kont2 = BuildEngine.run_multiple ~config ~tasks module_or form_keys in
    BuildEngine.run_unit_continuation kont2 state
  in
  ( List.map BuildEngine.uncloak_key form_keys,
    BuildEngine.uncloak_state state_after_run )

(** [trim_trailing_slashes s] removes all trailing slashes from [s]. *)
let trim_trailing_slashes s =
  let l = String.length s in
  let rec aux_len i =
    if i < 0 then 0 else match s.[i] with '/' -> aux_len (i - 1) | _ -> i + 1
  in
  let new_l = aux_len (l - 1) in
  String.sub s 0 new_l

let signal_name = function
  | n when n = Sys.sigabrt -> "SIGABRT"
  | n when n = Sys.sighup -> "SIGHUP"
  | n when n = Sys.sigint -> "SIGINT"
  | n when n = Sys.sigint -> "SIGINT"
  | n when n = Sys.sigquit -> "SIGQUIT"
  | n when n = Sys.sigterm -> "SIGTERM"
  | n -> Printf.sprintf "signal (%d)" n

type 'a download_status =
  | Downloaded of {
      origin : string;
      downloaded_checksum :
        [ `Unknown
        | `KnownSha256 of string * int64
        | `KnownSha1 of string * int64 ];
    }
  | Failed of 'a
  | FailedRetryableAttempt of {
      error_code : string;
      because : string;
      recommendations : string list;
      location_if_checksum_error : Fmlib_parse.Position.range option;
    }

(** [download_remote] uses curl to download the file. It is available in Windows
    10 and 11 at C:\Windows\System32\curl.exe, and should be available on Unix.

    If it fails, we will try the next mirror. *)
let download_remote ?verbose ?debug_connection ~autofix ~on_fail ~return ~mirror
    ~file_path ~file_sz destination_file =
  (* let open BuildInstance.Syntax in *)
  let url =
    match Stringext.cut mirror ~on:"?" with
    | None -> Printf.sprintf "%s/%s" mirror (trim_trailing_slashes file_path)
    | Some (base, query) ->
        Printf.sprintf "%s/%s?%s" (trim_trailing_slashes base) file_path query
  in
  (* Assemble curl arguments *)
  let curl_args =
    [
      "--retry";
      "5";
      "--retry-max-time";
      "120";
      "--fail";
      "--location";
      "--output";
      MlFront_Core.FilePath.to_string destination_file;
      url;
    ]
  in
  let curl_args =
    match debug_connection with
    | Some () -> "--verbose" :: curl_args
    | None -> "--silent" :: "--show-error" :: curl_args
  in
  let curl_args =
    if String.starts_with ~prefix:"https://" url then
      "--proto" :: "=https" :: "--tlsv1.2" :: curl_args
    else curl_args
  in
  let curl_args =
    match file_sz with
    | Some _ when autofix -> curl_args
    | Some (_range, sz) -> "--max-filesize" :: Int64.to_string sz :: curl_args
    | None -> curl_args
  in
  let cmdline = Filename.quote_command "curl" curl_args in
  (if verbose = Some () then
     (* Do not use [cmdline] since every word is quoted. *)
     let minquote_cmdline =
       String.concat " "
         (List.map MlFront_Thunk.ThunkCommand.InternalUse.posix_quote_word
            ("curl" :: curl_args))
     in
     Printf.eprintf "%s\n%!" minquote_cmdline);
  match Unix.system cmdline with
  | Unix.WEXITED 0 ->
      (* Checksum will be verified by caller. *)
      return (Downloaded { origin = url; downloaded_checksum = `Unknown })
  | Unix.WSIGNALED n ->
      on_fail ~error_code:"124c2cc5"
        ~because:(Printf.sprintf "`curl` was killed by a %s" (signal_name n))
        ~recommendations:[] ()
  | Unix.WSTOPPED n ->
      on_fail ~error_code:"479da8d7"
        ~because:(Printf.sprintf "`curl` was stopped by a %s" (signal_name n))
        ~recommendations:[] ()
  | Unix.WEXITED 127 ->
      (* Unix.system doc: The result WEXITED 127 indicates that the shell couldn't be executed. *)
      on_fail ~error_code:"e87a5870"
        ~because:"`curl` from the shell could not be executed"
        ~recommendations:[] ()
  | Unix.WEXITED 22 ->
      (* https://curl.se/docs/manpage.html:
         --fail
           Fail with error code 22 and with no response body output at all for HTTP transfers returning HTTP response codes at 400 or greater. *)
      return
        (FailedRetryableAttempt
           {
             error_code = "4dc6910e";
             because = "the download had a HTTP response code 400 or greater";
             recommendations = [];
             location_if_checksum_error = None;
           })
  | Unix.WEXITED ec ->
      return
        (FailedRetryableAttempt
           {
             error_code = "8ff6585f";
             because = Printf.sprintf "`curl` exited with code %d" ec;
             recommendations = [];
             location_if_checksum_error = None;
           })

let with_ppf f = function
  | `Stdout ->
      f Format.std_formatter;
      flush stdout
  | `Stderr ->
      f Format.err_formatter;
      flush stderr
  | `File path ->
      let oc = open_out (MlFront_Core.FilePath.to_string path) in
      let ppf = Format.formatter_of_out_channel oc in
      Fun.protect
        ~finally:(fun () ->
          Format.pp_print_flush ppf ();
          close_out oc)
        (fun () -> f ppf)

let dump_graph ~dump_ancestors_graph ~dump_dependency_graph state_after_run
    target_keys =
  (match dump_ancestors_graph with
  | None -> ()
  | Some where ->
      with_ppf
        (fun ppf ->
          BuildCore.Alacarte_6_4_test.StateSuspending.pp_graph_of_keys
            `Ancestors ppf state_after_run target_keys)
        where);
  match dump_dependency_graph with
  | None -> ()
  | Some where ->
      with_ppf
        (fun ppf ->
          BuildCore.Alacarte_6_4_test.StateSuspending.pp_graph_of_keys
            `Dependencies ppf state_after_run target_keys)
        where

module GitHubRepo : sig
  type t

  val to_string : t -> string
  val hostname : t -> string option
  val owner_and_repo : t -> string

  val parse : string -> (t, string) result
  (** [parse s] validates that the string [s] is a GitHub repository of form
      ["[HOST/]OWNER/REPO"]. *)
end = struct
  type t = { host : string; owner : string; repo : string }

  let default_host = "github.com"

  let hostname t =
    if String.equal default_host t.host then None else Some t.host

  let owner_and_repo t = Printf.sprintf "%s/%s" t.owner t.repo
  let to_string t = Printf.sprintf "%s/%s/%s" t.host t.owner t.repo

  (* Super annoying that GitHub does not document the whitelist of characters.
       We'll use https://stackoverflow.com/questions/59081778/rules-for-special-characters-in-github-repository-name instead:
       > [A-Za-z0-9_.-] *)
  let whitelist_repo_char c =
    (c >= 'A' && c <= 'Z')
    || (c >= 'a' && c <= 'z')
    || (c >= '0' && c <= '9')
    || c = '_' || c = '.' || c = '-'

  let whitelist_domain_name_char c =
    (c >= 'A' && c <= 'Z')
    || (c >= 'a' && c <= 'z')
    || (c >= '0' && c <= '9')
    || c = '-'

  let is_term_whitelisted ~w s =
    if String.length s = 0 then false
    else
      let rec loop i =
        if i >= String.length s then true
        else if not (w s.[i]) then false
        else loop (i + 1)
      in
      loop 0

  let validate_dns_name s =
    let parts = String.split_on_char '.' s in
    List.for_all (is_term_whitelisted ~w:whitelist_domain_name_char) parts
    && List.for_all (fun part -> String.length part > 0) parts
    && List.length parts >= 2

  let validate_owner_or_repo s =
    is_term_whitelisted ~w:whitelist_repo_char s && String.length s > 0

  let parse s =
    let parts = String.split_on_char '/' s in
    match parts with
    | [ owner; repo ]
      when validate_owner_or_repo owner && validate_owner_or_repo repo ->
        Ok { host = default_host; owner; repo }
    | [ host; owner; repo ]
      when validate_dns_name host
           && validate_owner_or_repo owner
           && validate_owner_or_repo repo ->
        Ok { host; owner; repo }
    | _ ->
        Error
          (Printf.sprintf
             "Invalid GitHub repository '%s'. Expected format: \
              '[HOST/]OWNER/REPO'"
             s)
end

(** Per
    {:https://docs.github.com/en/get-started/using-git/dealing-with-special-characters-in-branch-and-tag-names}
    Git is very permissive with Git tags. However, we only allow semver tags
    since the Git tag becomes the distribution library's version. *)
module SemVerGitTag : sig
  type t

  val to_string : t -> string

  val parse :
    string -> (t, MlFront_Thunk.ThunkParsers.Results.Semantic.t) result
end = struct
  type t = MlFront_Thunk.ThunkSemver64.t

  let to_string t = MlFront_Thunk.ThunkSemver64.to_string t

  let parse s =
    MlFront_Thunk.ThunkCommand.InternalUse.parse_semver64
      (module MakeInitObserver)
      MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None s
end