Source file BuildTask.ml

let package_is_local config pkg =
  List.exists
    (fun p -> MlFront_Core.PackageId.compare p pkg = 0)
    (BuildConfig.local_packages config)

let mock_slot =
  let module ResultObserver =
    MlFront_Thunk.ThunkParsers.Results.MakeObserverWithErrorReporter
  in
  MlFront_Thunk.ThunkCommand.InternalUse.parse_object_slot
    (module ResultObserver)
    MlFront_Thunk.ThunkParsers.Results.State.none `DirectDecode None "Mock"
  |> Result.get_ok

type initiator =
  | UserInitiated of {
      agent : string;
      request_slot : MlFront_Thunk.ThunkCommand.object_slot option;
    }
  | CommandInitiated of {
      cid_command : string;
      cid_thunk_for_output : string;
      basedir : MlFront_Core.FilePath.t option;
      request_slot : MlFront_Thunk.ThunkCommand.object_slot option;
    }
  | FunctionInitiated of {
      cid_thunk : string;
      request_slot : MlFront_Thunk.ThunkCommand.object_slot option;
    }

let initiator_slot_request_id = function
  | UserInitiated { request_slot; _ }
  | CommandInitiated { request_slot; _ }
  | FunctionInitiated { request_slot; _ } ->
      request_slot

let initiator_slot_request_id_as_string initiator =
  Option.map MlFront_Thunk.ThunkCommand.object_slot_to_shell
    (initiator_slot_request_id initiator)

let base32_cid ~cid = BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:() cid

let object_slot_as_dirname slot =
  Format.asprintf "%a"
    Format.(
      pp_print_list
        ~pp_sep:(fun ppf () -> pp_print_string ppf ".")
        pp_print_string)
    (MlFront_Thunk.ThunkCommand.object_slot_list slot)

let user_fp s = MlFront_Core.FilePath.(of_string_exn "target" |> append_exn s)

let command_fp ~thread ~cid s =
  MlFront_Core.FilePath.(
    thread
    |> append_exn (Stringext.take (base32_cid ~cid) BuildPaths.path_hash_len)
    |> append_exn s)

(** Reverse path from [resolve_task_function_path] to [command_fp].

    That is, ["<cid>/fn/<slot>"] to ["<cid>"], which is ["../.."] *)
let function_path_to_command_path = MlFront_Core.FilePath.of_string_exn "../.."

let function_fp s =
  let open MlFront_Core.FilePath in
  append_exn s function_path_to_command_path |> normalize

let value_id_form_object ~cid ~build slot =
  let raw =
    Format.asprintf "%s::%s::%s" cid
      (MlFront_Thunk.ThunkCommand.object_slot_to_shell slot)
      (* semver build metadata is separated by dots *)
      (String.concat "." build)
  in
  BuildPaths.prefix_object
  ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:()
      (Digestif.SHA256.to_hex (Digestif.SHA256.digest_string raw))

let value_id_bundle ~cid ~build () =
  let raw =
    Format.asprintf "%s::%s" cid
      (* semver build metadata is separated by dots *)
      (String.concat "." build)
  in
  BuildPaths.prefix_bundle
  ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:()
      (Digestif.SHA256.to_hex (Digestif.SHA256.digest_string raw))

let value_id_asset ~cid ~build () =
  let raw =
    Format.asprintf "%s::%s" cid
      (* semver build metadata is separated by dots *)
      (String.concat "." build)
  in
  BuildPaths.prefix_asset
  ^ BuildPaths.hex_to_base32_exn ~no_pad:() ~lowercase:()
      (Digestif.SHA256.to_hex (Digestif.SHA256.digest_string raw))

let resolve_task_function_path ~config ~cid slot =
  MlFront_Core.FilePath.(
    BuildConfig.threaddir config
    |> append_exn (Stringext.take (base32_cid ~cid) BuildPaths.path_hash_len)
    |> append_exn "fn"
    |> append_exn (object_slot_as_dirname slot))

let resolve_user_output_path ~config:_ slot =
  MlFront_Core.FilePath.(
    user_fp "out" |> append_exn (object_slot_as_dirname slot))

let resolve_bundle_output_path ~config ~cid =
  command_fp ~thread:(BuildConfig.threaddir config) ~cid "bundle"

let resolve_task_output_path ~config ~cid slot =
  command_fp ~thread:(BuildConfig.threaddir config) ~cid "out"
  |> MlFront_Core.FilePath.append_exn (object_slot_as_dirname slot)

let resolve_task_output_path_from_function slot =
  function_fp "out"
  |> MlFront_Core.FilePath.append_exn (object_slot_as_dirname slot)

let resolve_task_log_path ~config ~cid slot =
  command_fp ~thread:(BuildConfig.threaddir config) ~cid "log"
  |> MlFront_Core.FilePath.append_exn (object_slot_as_dirname slot)

let resolve_staging_path ~config ~initiator ~cid =
  match initiator with
  | UserInitiated _ -> user_fp "stage"
  | CommandInitiated _ ->
      command_fp ~thread:(BuildConfig.threaddir config) ~cid "stage"
  | FunctionInitiated _ -> function_fp "stage"

let resolve_labeled_path ~config ~initiator key =
  let thread = BuildConfig.threaddir config in
  match (key, initiator) with
  | `Home, UserInitiated _ -> BuildConfig.install_home config
  | `Cache, UserInitiated _ -> BuildConfig.install_cache config
  | `Data, UserInitiated _ -> BuildConfig.install_data config
  | `Config, UserInitiated _ -> BuildConfig.install_config config
  | `State, UserInitiated _ -> BuildConfig.install_state config
  | `Runtime, UserInitiated _ -> BuildConfig.install_runtime config
  | `MoreIncludes, UserInitiated _ -> user_fp "inc"
  | `MoreCommands, UserInitiated _ -> user_fp "cmd"
  | `PipeAsRegularFile pipe, UserInitiated _ -> user_fp ("pipe/" ^ pipe)
  | `StagedArchiveMember archivemember, UserInitiated _ ->
      user_fp ("sam/" ^ archivemember)
  | `StagedConstant, UserInitiated _ -> user_fp "const"
  | `Home, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "home"
  | `Cache, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "cache"
  | `Data, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "data"
  | `Config, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "config"
  | `State, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "state"
  | `Runtime, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "run"
  | `MoreIncludes, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "inc"
  | `MoreCommands, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "cmd"
  | `PipeAsRegularFile pipe, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command ("pipe/" ^ pipe)
  | `StagedArchiveMember archivemember, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command ("sam/" ^ archivemember)
  | `StagedConstant, CommandInitiated { cid_command; _ } ->
      command_fp ~thread ~cid:cid_command "const"
  | `Home, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "home"
  | `Cache, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "cache"
  | `Data, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "data"
  | `Config, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "config"
  | `State, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "state"
  | `Runtime, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "run"
  | `MoreIncludes, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "inc"
  | `MoreCommands, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "cmd"
  | ( `PipeAsRegularFile pipe,
      FunctionInitiated { cid_thunk = _; request_slot = _ } ) ->
      function_fp ("pipe/" ^ pipe)
  | ( `StagedArchiveMember archivemember,
      FunctionInitiated { cid_thunk = _; request_slot = _ } ) ->
      function_fp ("sam/" ^ archivemember)
  | `StagedConstant, FunctionInitiated { cid_thunk = _; request_slot = _ } ->
      function_fp "const"

(** [trim_leading_slashes s] is the string [s] with all leading forward and
    backslashes removed. *)
let trim_leading_slashes s =
  let rec aux i =
    if i >= String.length s then ""
    else
      match s.[i] with
      | '/' | '\\' -> aux (i + 1)
      | _ -> String.sub s i (String.length s - i)
  in
  aux 0

let reason_no_slot_request_id =
  "${SLOTNAME.request} cannot be used from a `get-bundle` or `get-asset` \
   command."

let eval_term_as_filepath ?platform ~config ~initiator lst =
  let basedir =
    match initiator with
    | CommandInitiated { basedir; _ } -> basedir
    | UserInitiated _ | FunctionInitiated _ -> None
  in
  let some s = Some s in
  let exception Failed of string in
  (* Reduce the expression into (optional BaseDirectory; reversed (Literal|DirectorySeperator).
     Reset the right-hand side when get to a directory variable. *)
  let rec aux (l, r) : MlFront_Thunk.ThunkCommand.evalable_term -> _ =
    let eval_slot slot rest =
      let slotdir =
        match initiator with
        | UserInitiated _ -> resolve_user_output_path ~config slot
        | CommandInitiated
            {
              cid_command = _;
              cid_thunk_for_output;
              basedir = _;
              request_slot = _;
            } ->
            resolve_task_output_path ~config ~cid:cid_thunk_for_output slot
        | FunctionInitiated { cid_thunk = _; request_slot = _ } ->
            resolve_task_output_path_from_function slot
      in
      aux (some slotdir, []) rest
    in
    function
    | [] -> (l, r)
    | DirectorySeperator :: rest -> aux (l, `DirSep :: r) rest
    | Literal s :: rest -> aux (l, `Lit s :: r) rest
    | ExecutableSuffix :: rest -> aux (l, `Lit ".exe" :: r) rest
    | SlotNameRequest _range :: rest -> begin
        match initiator_slot_request_id_as_string initiator with
        | None -> raise (Failed reason_no_slot_request_id)
        | Some slot_request_id -> aux (l, `Lit slot_request_id :: r) rest
      end
    | SlotRequest _range :: rest -> begin
        match initiator_slot_request_id initiator with
        | None -> raise (Failed reason_no_slot_request_id)
        | Some slot -> eval_slot slot rest
      end
    | SlotVariable (slot, _range) :: rest -> eval_slot slot rest
    | PipeVariable (pipe, _range) :: rest ->
        let pipedir =
          resolve_labeled_path ~config ~initiator (`PipeAsRegularFile pipe)
        in
        aux (some pipedir, []) rest
    | MoreIncludesDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `MoreIncludes in
        aux (some dir, []) rest
    | MoreCommandsFile :: rest ->
        let file = resolve_labeled_path ~config ~initiator `MoreCommands in
        aux (some file, []) rest
    | HomeDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Home in
        aux (some dir, []) rest
    | CacheDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Cache in
        aux (some dir, []) rest
    | DataDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Data in
        aux (some dir, []) rest
    | ConfigDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Config in
        aux (some dir, []) rest
    | StateDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `State in
        aux (some dir, []) rest
    | RuntimeDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Runtime in
        aux (some dir, []) rest
  in
  try
    let basedir_opt, reversed_ending = aux (basedir, []) lst in

    (* Deterministically get the directory separator *)
    let dirsep, to_os =
      match platform with
      | Some `Windows -> ("\\", fun p -> MlFront_Core.FilePath.to_windows p)
      | Some `Unix -> ("/", fun p -> MlFront_Core.FilePath.to_unix p)
      | None ->
      match basedir_opt with
      | Some basedir -> (MlFront_Core.FilePath.slash basedir, Fun.id)
      | None -> ("/", Fun.id)
    in

    (* Reduce ending from (reversed (Literal|DirectorySeperator)) to Literal *)
    let b = Buffer.create 100 in
    List.iter
      (function
        | `Lit s -> Buffer.add_string b s
        | `DirSep -> Buffer.add_string b dirsep)
      (List.rev reversed_ending);
    let ending = Buffer.contents b in

    (* Build the filepath *)
    match basedir_opt with
    | None -> begin
        match MlFront_Core.FilePath.of_string ending with
        | Error msg -> Error msg
        | Ok ending_fp -> Ok (ending_fp |> to_os)
      end
    | Some basedir ->
        (* [ending] must be treated as a relative path since we already have a base
           directory *)
        let relative_ending = trim_leading_slashes ending in
        begin
          match MlFront_Core.FilePath.append relative_ending basedir with
          | Error msg -> Error msg
          | Ok relative_fp -> Ok (relative_fp |> to_os)
        end
  with Failed msg -> Error msg

let eval_term_as_string ?platform ~config ~initiator lst =
  let exception Failed of string in
  (* Deterministically get the directory separator. It is the first separator
     of an absolute path. *)
  let dirsep, to_os =
    match platform with
    | Some `Windows -> ("\\", fun p -> MlFront_Core.FilePath.to_windows p)
    | Some `Unix -> ("/", fun p -> MlFront_Core.FilePath.to_unix p)
    | None -> (
        let mock_cid = "00" in
        let candidates =
          [
            resolve_labeled_path ~config ~initiator `Home;
            resolve_labeled_path ~config ~initiator `State;
            resolve_bundle_output_path ~config ~cid:mock_cid;
            resolve_task_output_path ~config ~cid:mock_cid mock_slot;
            resolve_user_output_path ~config mock_slot;
          ]
        in
        let absolute_candidates =
          List.filter MlFront_Core.FilePath.is_absolute candidates
        in
        match absolute_candidates with
        | [] -> ("/", Fun.id)
        | first :: _ -> (MlFront_Core.FilePath.slash first, Fun.id))
  in

  let buf = Buffer.create 100 in
  let add_fp fp =
    Buffer.add_string buf (MlFront_Core.FilePath.to_string (to_os fp))
  in
  let rec aux : MlFront_Thunk.ThunkCommand.evalable_term -> _ =
    let eval_slot slot rest =
      let slotdir =
        match initiator with
        | UserInitiated _ -> resolve_user_output_path ~config slot
        | CommandInitiated
            {
              cid_command = _;
              cid_thunk_for_output;
              basedir = _;
              request_slot = _;
            } ->
            resolve_task_output_path ~config ~cid:cid_thunk_for_output slot
        | FunctionInitiated { cid_thunk = _; request_slot = _ } ->
            resolve_task_output_path_from_function slot
      in
      add_fp slotdir;
      aux rest
    in
    function
    | [] -> ()
    | DirectorySeperator :: rest ->
        Buffer.add_string buf dirsep;
        aux rest
    | Literal s :: rest ->
        Buffer.add_string buf s;
        aux rest
    | ExecutableSuffix :: rest ->
        Buffer.add_string buf ".exe";
        aux rest
    | SlotNameRequest _range :: rest -> begin
        match initiator_slot_request_id_as_string initiator with
        | None -> raise (Failed reason_no_slot_request_id)
        | Some slot_request_id ->
            Buffer.add_string buf slot_request_id;
            aux rest
      end
    | SlotRequest _range :: rest -> begin
        match initiator_slot_request_id initiator with
        | None -> raise (Failed reason_no_slot_request_id)
        | Some slot -> eval_slot slot rest
      end
    | SlotVariable (slot, _range) :: rest -> eval_slot slot rest
    | PipeVariable (pipe, _range) :: rest ->
        let pipedir =
          resolve_labeled_path ~config ~initiator (`PipeAsRegularFile pipe)
        in
        add_fp pipedir;
        aux rest
    | MoreIncludesDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `MoreIncludes in
        add_fp dir;
        aux rest
    | MoreCommandsFile :: rest ->
        let file = resolve_labeled_path ~config ~initiator `MoreCommands in
        add_fp file;
        aux rest
    | HomeDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Home in
        add_fp dir;
        aux rest
    | CacheDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Cache in
        add_fp dir;
        aux rest
    | DataDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Data in
        add_fp dir;
        aux rest
    | ConfigDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Config in
        add_fp dir;
        aux rest
    | StateDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `State in
        add_fp dir;
        aux rest
    | RuntimeDir :: rest ->
        let dir = resolve_labeled_path ~config ~initiator `Runtime in
        add_fp dir;
        aux rest
  in
  try
    aux lst;
    Ok (Buffer.contents buf)
  with Failed msg -> Error msg

type 'a ast_answer = {
  answer : 'a;
  answer_values_file : BuildCore.Io.file_object;
  answer_values_file_sha256 : string;
  answer_values_canonical_id : string;
}

let match_values ~error_locations ~find =
  let open BuildCore.Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  function
  | V.Failure_is_pending -> return `Failure_is_pending
  | V.Values
      {
        value_id = _;
        value_sha256 = _;
        value =
          Some
            {
              values_canonical_id;
              values_file_sha256;
              values_file_local;
              values_origin = _;
              values_transient = Some { values; values_file };
            };
      } -> begin
      match find values with
      | Error msg ->
          let* () =
            fail ~error_code:"1f0e3dad" ~cant_do:"find values" ~because:msg
              ~error_locations ()
          in
          return `Failure_is_pending
      | Ok answer ->
          return
            (`FoundInValues
               {
                 answer;
                 answer_values_file =
                   Option.value ~default:values_file
                     (Option.map (fun (`Validated o) -> o) values_file_local);
                 answer_values_file_sha256 = values_file_sha256;
                 answer_values_canonical_id = values_canonical_id;
               })
    end
  | v ->
      let* () =
        fail ~error_code:"bf3dd922" ~cant_do:"get values"
          ~because:(Printf.sprintf "expected a values AST, not `%s`" (V.show v))
          ~error_locations ()
      in
      return `Failure_is_pending

let depend_on_values_ast ~fetch ~error_locations ~values_file_sha256 find =
  let open BuildCore.Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  match
    K.create_checksum_for_values_file ~debug_reference:None ~values_file_sha256
      ()
  with
  | Error m ->
      let* () =
        fail ~error_code:"82dc185c" ~cant_do:"calculate values file checksum"
          ~because:m ~error_locations ()
      in
      return `Failure_is_pending
  | Ok k_valuesfile -> (
      let* v_expect_values = fetch O.not_relevant k_valuesfile in
      match v_expect_values with
      | V.Failure_is_pending -> return `Failure_is_pending
      | V.Values _ -> match_values ~error_locations ~find v_expect_values
      | v ->
          let* () =
            fail ~error_code:"b8586926" ~cant_do:"get values AST"
              ~because:
                (Printf.sprintf "expected a values value, not `%s`" (V.show v))
              ~error_locations ()
          in
          return `Failure_is_pending)

let depend_on_distribution ~config ~fetch ~error_locations ~module_version =
  let open BuildCore.Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  let k_distribution_opt =
    let { id; version } : MlFront_Thunk.ThunkCommand.module_version =
      module_version
    in
    match SecPackageRegistry.package_id_for_module id with
    | None -> None
    | Some package_id ->
        Some
          ( package_id,
            K.create_for_distribution ~debug_reference:None ~package_id
              ~package_semver:version () )
  in
  (* fetch the distribution unless [vendor = Our] *)
  match k_distribution_opt with
  | None -> return `Ok
  | Some (package_id, k_distribution) -> (
      if package_is_local config package_id then return `Ok
      else
        let* (v_expect_something : V.t) = fetch O.not_relevant k_distribution in
        match v_expect_something with
        | V.Failure_is_pending -> return `Failure_is_pending
        | V.Distribution _ -> return `Ok
        | v ->
            let* () =
              fail ~error_code:"a86bcf37" ~cant_do:"get distribution"
                ~because:
                  (Printf.sprintf
                     "expected a distribution value for `%s`, not `%s`"
                     (MlFront_Thunk.ThunkCommand.show_module_version
                        module_version)
                     (V.show v))
                ~error_locations ()
            in
            return `Failure_is_pending)