Source file BuildTaskBundle.ml

open BuildCore

type almost_object = AlmostObject | Other_Failure_is_pending

let make_userbundlekind_task_of_bundle ~config ~k_user_bundle
    ~values_file_sha256 ~values_file_local ~initiator :
    (Alacarte_3_2_apparatus.O.t ->
    Alacarte_3_2_apparatus.K.t ->
    Alacarte_3_2_apparatus.V.t Alacarte_6_4_test.CSuspending.t) ->
    Alacarte_3_2_apparatus.V.t Alacarte_6_4_test.CSuspending.t =
  let open Alacarte_3_2_apparatus in
  let open BuildInstance.Syntax in
  let bundle_id = K.module_version_exn k_user_bundle in
  let build = MlFront_Thunk.ThunkSemver64.build bundle_id.version in

  (* Provide the task definition *)
  let task
      (fetch :
        Alacarte_3_2_apparatus.O.t ->
        Alacarte_3_2_apparatus.K.t ->
        Alacarte_3_2_apparatus.V.t Alacarte_6_4_test.CSuspending.t) =
    (* Add dependency to distribution *)
    let* dist_result =
      BuildTask.depend_on_distribution ~config ~fetch ~error_locations:[]
        ~module_version:bundle_id
    in
    match dist_result with
    | `Failure_is_pending -> return V.Failure_is_pending
    | `Ok -> (
        (* Add dependency to parsed values, and extract the bundle from its index *)
        let* asset_result =
          BuildTask.depend_on_values_ast ~fetch ~error_locations:[]
            ~values_file_sha256 (fun ast ->
              match MlFront_Thunk.ThunkAst.find_bundle ast bundle_id with
              | None ->
                  Error
                    (Printf.sprintf "AST did not contain the bundle `%s`"
                       (MlFront_Thunk.ThunkCommand.show_module_version bundle_id))
              | Some bundle -> Ok bundle)
        in
        match asset_result with
        | `Failure_is_pending -> return V.Failure_is_pending
        | `FoundInValues
            {
              answer =
                ( ({
                     bundle_canonical_id = _;
                     listing_unencrypted = _;
                     listing = { origins };
                     asset_files = _;
                   } as bundle),
                  bundle_range );
              answer_values_file;
              answer_values_file_sha256 = bundle_values_file_sha256;
              answer_values_canonical_id = bundle_values_canonical_id;
            } -> (
            let values_file =
              match values_file_local with
              | Some (`Validated vf) -> vf
              | None -> answer_values_file
            in
            (* Extract from [asset_result] *)
            let cid_bundle =
              MlFront_Thunk.ThunkAst.canonical_id_bundle bundle
            in
            let value_id =
              BuildTask.value_id_bundle ~cid:cid_bundle ~build ()
            in

            let* error_locations =
              BuildTaskForm.range_into_problem_location ~source:values_file
                bundle_range
            in

            (* Each bundle will be staged in a cleaned output directory *)
            let output_path =
              BuildTask.resolve_bundle_output_path ~config ~cid:cid_bundle
            in
            let* () =
              BuildTaskForm.rmdir ~values_file ~what:"bundle output directory"
                bundle_range output_path
            in
            let* () =
              BuildTaskForm.mkdir ~values_file ~what:"bundle output directory"
                bundle_range output_path
            in
            (* Recursion case: Download and keep the Object if successful,
       or stop with failure. *)
            let* v =
              MlFront_Thunk.ThunkAst.fold_assets_wth_ranges
                ~f:(fun asset asset_range acc_vc ->
                  let {
                    file_canonical_id = _;
                    file_origin;
                    file_path;
                    file_checksum;
                    file_sz;
                  } : MlFront_Thunk.ThunkAst.asset_file2 =
                    asset
                  in
                  let* v = acc_vc in
                  match v with
                  | AlmostObject -> (
                      let cant_do =
                        Format.asprintf "get bundle `%s` of %a" file_path K.pp
                          k_user_bundle
                      in
                      (* Create or clean location to download the asset *)
                      let output_path_for_file =
                        MlFront_Core.FilePath.append_exn file_path output_path
                      in
                      (* Find matching origin *)
                      let origin_mirrors_opt =
                        List.find_map
                          (fun ({ origin_name; origin_mirrors } :
                                 MlFront_Thunk.ThunkAst.asset_origin2) ->
                            if String.equal origin_name file_origin then
                              Some origin_mirrors
                            else None)
                          origins
                      in
                      match origin_mirrors_opt with
                      | None ->
                          let* () =
                            fail ~error_code:"ff45ece5" ~cant_do
                              ~because:
                                (Printf.sprintf
                                   "the asset `%s`'s origin `%s` is not in the \
                                    bundle's listing"
                                   file_path file_origin)
                              ~error_locations ()
                          in
                          return Other_Failure_is_pending
                      | Some origin_mirrors -> (
                          (* Download *)
                          let on_fail ~location_if_checksum_error ~error_code
                              ~because ~recommendations () =
                            let* error_locations =
                              let range =
                                match location_if_checksum_error with
                                | Some range -> range
                                | None -> asset_range
                              in
                              BuildTaskForm.range_into_problem_location
                                ~source:values_file range
                            in
                            fail ~error_code ~cant_do ~because ~recommendations
                              ~error_locations ~exitcode_posix:2
                              ~exitcode_windows:2 ()
                          in
                          let* (status :
                                 [ `Downloaded of [ `Sha256 of string * int64 ]
                                 | `Failed ]) =
                            (BuildConfig.download config)
                              ~on_fail ~file_path ~file_checksum
                              ~file_sz:(Some file_sz) ~origin_mirrors
                              output_path_for_file
                          in
                          (* Keep Object if download successful *)
                          match status with
                          | `Failed -> return Other_Failure_is_pending
                          | `Downloaded _ -> return v))
                  | Other_Failure_is_pending ->
                      (* Continue propagating the failure *)
                      return Other_Failure_is_pending)
                ~init:(return AlmostObject) bundle
            in
            match v with
            | AlmostObject ->
                (* Successful staging. So zip it up to the value store. *)
                if BuildConfig.verbose config then
                  Printf.eprintf "[zipping] %s to bundle %s\n%!"
                    (K.show k_user_bundle) value_id;
                let staging_dir =
                  BuildTask.resolve_staging_path ~config ~initiator
                    ~cid:cid_bundle
                in
                BuildInstance.ValueStore.add_bundle
                  ~valuestore:(BuildConfig.valuestore config)
                  ~src_file_or_dir:(BuildCore.Io.disk_file output_path)
                  ~value_id ~staging_dir ~bundle_id ~bundle_range
                  ~bundle_values_canonical_id ~bundle_values_file_sha256
                  ~bundle_values_file_local:values_file_local
                  ~on_error:(fun because ->
                    let* error_locations =
                      BuildTaskForm.range_into_problem_location
                        ~source:values_file bundle_range
                    in
                    let* () =
                      fail ~error_code:"766a323d"
                        ~cant_do:
                          (Format.asprintf "zip bundle %a" K.pp k_user_bundle)
                        ~because ~error_locations ~recommendations:[]
                        ~exitcode_posix:2 ~exitcode_windows:2 ()
                    in
                    return V.Failure_is_pending)
                  ()
            | Other_Failure_is_pending ->
                (* Continue propagating the failure *)
                return V.Failure_is_pending))
  in
  task