Source file BuildConfig.ml

(** {1 Configuration} *)

type install_params = { program : string }

module KMap = Map.Make (BuildCore.Alacarte_3_2_apparatus.K)

type preconfig = {
  preconfig_buildlogtrace : bool;
  preconfig_parsetrace : bool;
  preconfig_debug_task : bool;
  preconfig_tracestore : MlFront_Core.FilePath.t;
  preconfig_tracefile : string;
  preconfig_valuestore : MlFront_Core.FilePath.t;
  preconfig_install_home : MlFront_Core.FilePath.t;
  preconfig_install_cache : MlFront_Core.FilePath.t;
  preconfig_install_data : MlFront_Core.FilePath.t;
  preconfig_install_config : MlFront_Core.FilePath.t;
  preconfig_install_state : MlFront_Core.FilePath.t;
  preconfig_install_runtime : MlFront_Core.FilePath.t;
  preconfig_build_pubkey : [ `PublicKey of string ];
  preconfig_build_seckey : [ `SecretKey of string ];
  preconfig_metadb : MlFront_Cache.MetaDb.t;
  preconfig_rng : Mirage_crypto_rng.g;
  preconfig_integrity : [ `None | `Existence | `Checksum ];
}

type t = {
  mutable does_enter_shell_before_function : unit KMap.t;
  threaddir : MlFront_Core.FilePath.t;
  download :
    on_fail:
      (location_if_checksum_error:Fmlib_parse.Position.range option ->
      error_code:string ->
      because:string ->
      recommendations:string list ->
      unit ->
      unit BuildCore.Alacarte_3_7_test_last.ThunkTrackingInterpreter.C.t) ->
    file_path:string ->
    file_checksum:MlFront_Thunk.ThunkAst.asset_checksum ->
    file_sz:(Fmlib_parse.Position.range * int64) option ->
    origin_mirrors:string * string list ->
    MlFront_Core.FilePath.t ->
    [ `Downloaded of [ `Sha256 of string * int64 ] | `Failed ]
    BuildCore.Alacarte_6_4_test.CSuspending.t;
  verbose : bool;
  explain : bool;
  parsetrace : bool;
  intermediate : bool;
  buildlogtrace : bool;
  debug_task : bool;
  importtrace : bool;
  importtrace2 : bool;
  includedirs : string list;
  sysincludedirs : string list;
  local_packages : MlFront_Core.PackageId.t list;
  build_number : string;
  integrity : [ `None | `Existence | `Checksum ];
  inferred_package_id_or_reason_whynone :
    (MlFront_Core.PackageId.t, string) Either.t;
  valuestore : MlFront_Core.FilePath.t;
  tracestore : MlFront_Core.FilePath.t;
  tracefile : string;
  install_home : MlFront_Core.FilePath.t;
  install_cache : MlFront_Core.FilePath.t;
  install_data : MlFront_Core.FilePath.t;
  install_config : MlFront_Core.FilePath.t;
  install_state : MlFront_Core.FilePath.t;
  install_runtime : MlFront_Core.FilePath.t;
  rng : Mirage_crypto_rng.g;
  build_pubkey : [ `PublicKey of string ];
  build_seckey : [ `SecretKey of string ];
  metadb : MlFront_Cache.MetaDb.t;
  observer_result : (module MlFront_Thunk.ThunkParsers.Results.OBSERVER_RESULT);
  nobuiltininc : bool;
  nosysinc : bool;
  builtin_values : BuildCore.Io.file_object list;
}

let fatal_return ~error_code = function
  | `Created | `Deleted -> ()
  | `Error s ->
      Printf.eprintf "[fatal] [error %s] %s\n%!" error_code s;
      exit 1

let build_key_pipes_to_newlines s =
  Assumptions.build_keys_have_no_pipes_and_store_pipe_separated ();
  let s = String.trim s in
  let s = String.concat "\n" (String.split_on_char '|' s) in
  (* Format is COMMENT NEWLINE KEY NEWLINE *)
  s ^ "\n"

let load_or_generate_keys_dir ~rng ~keys_env ~build_public_keyfile
    ~build_secret_keyfile () =
  (* Check for secret key (not the public key since that is theoretically
     recoverable). If secret key doesn't exist, create a new key pair. *)
  match keys_env with
  | Some prefix -> (
      let pubkey_env = prefix ^ "_PUBKEY" in
      let seckey_env = prefix ^ "_SECKEY" in
      match (Sys.getenv_opt pubkey_env, Sys.getenv_opt seckey_env) with
      | Some pubkey, Some seckey ->
          ( `PublicKey (build_key_pipes_to_newlines pubkey),
            `SecretKey (build_key_pipes_to_newlines seckey) )
      | None, None ->
          Printf.eprintf
            "[signify] FATAL: Environment variables %s and %s not set.\n%!"
            pubkey_env seckey_env;
          exit 1
      | Some _, None ->
          Printf.eprintf
            "[signify] FATAL: Environment variable %s set but %s not set.\n%!"
            pubkey_env seckey_env;
          exit 1
      | None, Some _ ->
          Printf.eprintf
            "[signify] FATAL: Environment variable %s set but %s not set.\n%!"
            seckey_env pubkey_env;
          exit 1)
  | None ->
      if Sys.file_exists (MlFront_Core.FilePath.show build_secret_keyfile) then begin
        let seckey =
          In_channel.with_open_bin
            (MlFront_Core.FilePath.show build_secret_keyfile) (fun ic ->
              In_channel.input_all ic)
        in
        let pubkey =
          In_channel.with_open_bin
            (MlFront_Core.FilePath.show build_public_keyfile) (fun ic ->
              In_channel.input_all ic)
        in
        (`PublicKey pubkey, `SecretKey seckey)
      end
      else begin
        (* Create keys *)
        let ((`PublicKey pubkey, `SecretKey seckey) as keypair) =
          SecCore.generate_build_keypair ~rng ()
        in
        SecCore.save_build_keypair ~build_public_keyfile ~build_secret_keyfile
          ~fatal_return keypair;
        (* Save keys ... secret key last for idempotency with secret key check above. *)
        MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
          ~return:(fatal_return ~error_code:"5696c586")
          (MlFront_Core.FilePath.parent build_public_keyfile);
        MlFront_Thunk_IoDisk.ThunkIoDisk.make_directory_recursively
          ~return:(fatal_return ~error_code:"b1f3c9e2")
          (MlFront_Core.FilePath.parent build_secret_keyfile);
        Out_channel.with_open_bin
          (MlFront_Core.FilePath.show build_public_keyfile) (fun ic ->
            Out_channel.output_string ic pubkey);
        Out_channel.with_open_bin
          (MlFront_Core.FilePath.show build_secret_keyfile) (fun ic ->
            Out_channel.output_string ic seckey);
        (* Log *)
        Printf.eprintf
          "[signify] New build key pair in %s and %s ...\n\
           [signify] Distribute key pair among trusted coworkers only!\n\
           %!"
          (MlFront_Core.FilePath.show build_public_keyfile)
          (MlFront_Core.FilePath.show build_secret_keyfile);
        (`PublicKey pubkey, `SecretKey seckey)
      end

let setup_cachedirs ~rng ~data_dir ~cache_dir () =
  match
    MlFront_Cache.MetaDb.create ~rng ~name:"build"
      ~datadir:Fpath.(data_dir / "build.1")
      ~cachedir:Fpath.(cache_dir / "build.1")
      ()
  with
  | Ok metadb -> metadb
  | Error _ ->
      Fmt.epr "@[<v 2>FATAL: Could not create the metadata database.@ %a@]@."
        MlFront_Errors.Errors.Details.pp ();
      exit 2

let preconfigure ?data_dir ?cache_dir ?valuestore ?tracestore ?buildlogtrace
    ?parsetrace ?debug_task ~install ~keys_env ~keys_dir ~random_seed ~integrity
    () =
  let xdg = Xdg.create ~env:Sys.getenv_opt () in
  let dk_prog = "dk" in
  (* Data and cache directories *)
  let data_dir, data_dir_fp =
    let data_dir_default =
      MlFront_Core.FilePath.(
        of_string_exn (Xdg.data_dir xdg) |> append_exn dk_prog |> to_string)
    in
    let data_dir_opt = Option.map MlFront_Core.FilePath.to_string data_dir in
    let s = Option.value ~default:data_dir_default data_dir_opt in
    match Fpath.of_string s with
    | Error (`Msg msg) ->
        failwith (Printf.sprintf "Failed to understand data dir: %s" msg)
    | Ok dir -> (MlFront_Core.FilePath.of_string_exn s, dir)
  in
  let cache_dir, cache_dir_fp =
    let cache_dir_default =
      MlFront_Core.FilePath.(
        of_string_exn (Xdg.cache_dir xdg) |> append_exn dk_prog |> to_string)
    in
    let cache_dir_opt = Option.map MlFront_Core.FilePath.to_string cache_dir in
    let s = Option.value ~default:cache_dir_default cache_dir_opt in
    match Fpath.of_string s with
    | Error (`Msg msg) ->
        failwith (Printf.sprintf "Failed to understand cache dir: %s" msg)
    | Ok dir -> (MlFront_Core.FilePath.of_string_exn s, dir)
  in

  (* Stores *)
  let valuestore =
    (* default:
         "val.1" = value store. layout version 1 *)
    Option.value
      ~default:(MlFront_Core.FilePath.append_exn "val.1" data_dir)
      valuestore
  in
  let tracestore =
    (* default:
         "cts.1.<tag>" = constructive trace store. layout version 1 *)
    Option.value
      ~default:
        (MlFront_Core.FilePath.append_exn
           ("cts.1." ^ BuildCore.compatibility_tag ())
           data_dir)
      tracestore
  in
  (* Choose location for signify keys *)
  let build_public_keyfile, build_secret_keyfile =
    let open MlFront_Core.FilePath in
    let keys_dir =
      match keys_dir with
      | None -> of_string_exn (Xdg.config_dir xdg) |> append_exn dk_prog
      | Some dir -> of_string_exn dir
    in
    (append_exn "build.pub" keys_dir, append_exn "build.sec" keys_dir)
  in
  (* Choose location for various variables *)
  let ( install_home,
        install_cache,
        install_data,
        install_config,
        install_state,
        install_runtime ) =
    let open MlFront_Core.FilePath in
    let x = of_string_exn in
    match install with
    | Some { program } -> (
        let y f = of_string_exn (f xdg) |> append_exn program in
        let z f = append_exn program f in
        ( x (Xdg.home_dir xdg),
          z cache_dir,
          z data_dir,
          y Xdg.config_dir,
          y Xdg.state_dir,
          match Xdg.runtime_dir xdg with
          | None -> y Xdg.state_dir
          | Some r -> x r ))
    | None ->
        ( x "target/xhome",
          x "target/xcache",
          x "target/xdata",
          x "target/xconfig",
          x "target/xstate",
          x "target/xruntime" )
  in
  (* Create random number generator *)
  let rng = SecCore.get_rng ~random_seed () in
  (* Create signify key if secret key not present *)
  let build_pubkey, build_seckey =
    load_or_generate_keys_dir ~rng ~keys_env ~build_public_keyfile
      ~build_secret_keyfile ()
  in
  (* metadb *)
  let metadb =
    setup_cachedirs ~rng ~data_dir:data_dir_fp ~cache_dir:cache_dir_fp ()
  in
  (* Done preconfigure *)
  {
    preconfig_tracestore = tracestore;
    preconfig_tracefile = "trace";
    preconfig_buildlogtrace = buildlogtrace = Some ();
    preconfig_parsetrace = parsetrace = Some ();
    preconfig_debug_task = debug_task = Some ();
    preconfig_valuestore = valuestore;
    preconfig_install_home = install_home;
    preconfig_install_cache = install_cache;
    preconfig_install_data = install_data;
    preconfig_install_config = install_config;
    preconfig_install_state = install_state;
    preconfig_install_runtime = install_runtime;
    preconfig_build_pubkey = build_pubkey;
    preconfig_build_seckey = build_seckey;
    preconfig_metadb = metadb;
    preconfig_rng = rng;
    preconfig_integrity = integrity;
  }

(** [create ?verbose ~threaddir ~download ()].

    [threaddir] is a directory exclusive to the {b running process and thread}.
    It is used for temporary directories. *)
let create ?verbose ?explain ?intermediate ?importtrace ?importtrace2
    ?nobuiltininc ?nosysinc ~preconfig ~sysincludedirs ~includedirs
    ~local_packages ~build_number ~inferred_package_id_or_reason_whynone
    ~threaddir ~download ~observer_result () =
  let {
    preconfig_buildlogtrace = buildlogtrace;
    preconfig_parsetrace = parsetrace;
    preconfig_debug_task = debug_task;
    preconfig_tracestore = tracestore;
    preconfig_tracefile = tracefile;
    preconfig_valuestore = valuestore;
    preconfig_install_home = install_home;
    preconfig_install_cache = install_cache;
    preconfig_install_data = install_data;
    preconfig_install_config = install_config;
    preconfig_install_state = install_state;
    preconfig_install_runtime = install_runtime;
    preconfig_build_pubkey = build_pubkey;
    preconfig_build_seckey = build_seckey;
    preconfig_metadb = metadb;
    preconfig_rng = rng;
    preconfig_integrity = integrity;
  } =
    preconfig
  in
  (* Return *)
  {
    builtin_values =
      (if nobuiltininc = Some () then [] else BuildBuiltins.builtin_values ());
    rng;
    includedirs;
    sysincludedirs = (if nosysinc = Some () then [] else sysincludedirs);
    local_packages;
    build_number;
    integrity;
    inferred_package_id_or_reason_whynone;
    threaddir;
    tracestore;
    tracefile;
    download;
    nobuiltininc = nobuiltininc = Some ();
    nosysinc = nosysinc = Some ();
    verbose = verbose = Some ();
    explain = explain = Some ();
    intermediate = intermediate = Some ();
    debug_task;
    buildlogtrace;
    importtrace = importtrace = Some ();
    importtrace2 = importtrace2 = Some ();
    parsetrace;
    valuestore;
    install_home;
    install_cache;
    install_data;
    install_config;
    install_state;
    install_runtime;
    build_pubkey;
    build_seckey;
    metadb;
    observer_result;
    does_enter_shell_before_function = KMap.empty;
  }

let builtin_values { builtin_values; _ } = builtin_values
let threaddir { threaddir; _ } = threaddir
let download { download; _ } = download
let verbose { verbose; _ } = verbose
let explain { explain; _ } = explain
let parsetrace { parsetrace; _ } = parsetrace
let intermediate { intermediate; _ } = intermediate
let importtrace { importtrace; _ } = importtrace
let importtrace2 { importtrace2; _ } = importtrace2
let debug_task { debug_task; _ } = debug_task
let buildlogtrace { buildlogtrace; _ } = buildlogtrace
let includedirs { includedirs; _ } = includedirs
let sysincludedirs { sysincludedirs; _ } = sysincludedirs
let local_packages { local_packages; _ } = local_packages
let integrity { integrity; _ } = integrity
let valuestore { valuestore; _ } = valuestore
let tracestore { tracestore; _ } = tracestore
let tracefile { tracefile; _ } = tracefile
let install_home { install_home; _ } = install_home
let install_cache { install_cache; _ } = install_cache
let install_data { install_data; _ } = install_data
let install_config { install_config; _ } = install_config
let install_state { install_state; _ } = install_state
let install_runtime { install_runtime; _ } = install_runtime
let rng { rng; _ } = rng
let build_pubkey { build_pubkey; _ } = build_pubkey
let build_seckey { build_seckey; _ } = build_seckey
let build_number { build_number; _ } = build_number
let metadb { metadb; _ } = metadb
let observer_result { observer_result; _ } = observer_result
let nobuiltininc { nobuiltininc; _ } = nobuiltininc
let nosysinc { nosysinc; _ } = nosysinc

let inferred_package_id_or_reason_whynone
    { inferred_package_id_or_reason_whynone; _ } =
  inferred_package_id_or_reason_whynone

let does_enter_shell_before_function { does_enter_shell_before_function; _ } k =
  KMap.mem k does_enter_shell_before_function

(** [set_enter_shell_breakpoint_before_function config key] will trigger the
    interactive shell to launch before the next function call(s) of the key
    [key], if any. *)
let set_enter_shell_breakpoint_before_function
    ({ does_enter_shell_before_function; _ } as config) k =
  config.does_enter_shell_before_function <-
    KMap.add k () does_enter_shell_before_function

(** {2 Preconfiguration} *)

let preconfig_tracestore { preconfig_tracestore; _ } = preconfig_tracestore
let preconfig_tracefile { preconfig_tracefile; _ } = preconfig_tracefile
let preconfig_valuestore { preconfig_valuestore; _ } = preconfig_valuestore

let preconfig_build_pubkey { preconfig_build_pubkey; _ } =
  preconfig_build_pubkey

let preconfig_build_seckey { preconfig_build_seckey; _ } =
  preconfig_build_seckey

let preconfig_buildlogtrace { preconfig_buildlogtrace; _ } =
  preconfig_buildlogtrace

let preconfig_parsetrace { preconfig_parsetrace; _ } = preconfig_parsetrace
let preconfig_debug_task { preconfig_debug_task; _ } = preconfig_debug_task
let preconfig_integrity { preconfig_integrity; _ } = preconfig_integrity

let print_config config =
  let open Format in
  let p = fprintf in
  let f = std_formatter in
  let pp_opt_bool fmt = function
    | true -> fprintf fmt "Some ()"
    | false -> fprintf fmt "None"
  in
  let pp_list =
    pp_print_list
      ~pp_sep:(fun fmt () -> fprintf fmt "; ")
      Format.pp_print_string
  in
  p f "@[<v>";
  p f "threaddir: %a@;" MlFront_Core.FilePath.pp (threaddir config);
  p f "verbose: %a@;" pp_opt_bool (verbose config);
  p f "explain: %a@;" pp_opt_bool (explain config);
  p f "parsetrace: %a@;" pp_opt_bool (parsetrace config);
  p f "intermediate: %a@;" pp_opt_bool (intermediate config);
  p f "buildlogtrace: %a@;" pp_opt_bool (buildlogtrace config);
  p f "debug_task: %a@;" pp_opt_bool (debug_task config);
  p f "importtrace: %a@;" pp_opt_bool (importtrace config);
  p f "importtrace2: %a@;" pp_opt_bool (importtrace2 config);
  p f "nobuiltininc: %a@;" pp_opt_bool (nobuiltininc config);
  p f "nosysinc: %a@;" pp_opt_bool (nosysinc config);
  p f "sysincludedirs: [%a]@;" pp_list (sysincludedirs config);
  p f "includedirs: [%a]@;" pp_list (includedirs config);
  p f "local_packages: [%a]@;" pp_list
    (List.map MlFront_Core.PackageId.full_name (local_packages config));
  p f "build_number: %s@;" (build_number config);
  p f "integrity: %s@;"
    (match integrity config with
    | `None -> "None"
    | `Existence -> "Existence"
    | `Checksum -> "Checksum");
  p f "valuestore: %a@;" MlFront_Core.FilePath.pp (valuestore config);
  p f "tracestore: %a@;" MlFront_Core.FilePath.pp (tracestore config);
  p f "tracefile: %s@;" (tracefile config);
  p f "install_home: %a@;" MlFront_Core.FilePath.pp (install_home config);
  p f "install_cache: %a@;" MlFront_Core.FilePath.pp (install_cache config);
  p f "install_data: %a@;" MlFront_Core.FilePath.pp (install_data config);
  p f "install_config: %a@;" MlFront_Core.FilePath.pp (install_config config);
  p f "install_state: %a@;" MlFront_Core.FilePath.pp (install_state config);
  p f "install_runtime: %a@;" MlFront_Core.FilePath.pp (install_runtime config);
  p f "build_pubkey: @[%a@]@;"
    (pp_print_list ~pp_sep:pp_print_cut (fun ppf v -> fprintf ppf "%s" v))
    (match build_pubkey config with
    | `PublicKey s -> String.split_on_char '\n' s);
  p f "build_seckey: %s@;"
    (match build_seckey config with `SecretKey _ -> "<secret key>");
  p f "metadb: %a@;" MlFront_Cache.MetaDb.pp (metadb config);
  p f "builtin_values: [%a]@;"
    (pp_print_list
       ~pp_sep:(fun fmt () -> fprintf fmt "; ")
       (fun ppf v -> fprintf ppf "%s" (BuildCore.Io.file_origin v)))
    (builtin_values config);
  p f "@]"