From 3df27ffb2bd40f3eaeed6dfb08ef3041cc60bfe0 Mon Sep 17 00:00:00 2001 From: ·𐑑𐑴𐑕𐑑𐑩𐑀 Date: Wed, 10 Dec 2025 13:00:26 +0000 Subject: ocaml onset --- lib/dune | 11 + lib/editor.ml | 19 ++ lib/error.ml | 77 +++++ lib/input.ml | 362 ++++++++++++++++++++++++ lib/input_foreman.ml | 722 +++++++++++++++++++++++++++++++++++++++++++++++ lib/kdl_lens_result.ml | 390 +++++++++++++++++++++++++ lib/lock_loader.ml | 404 ++++++++++++++++++++++++++ lib/lockfile.ml | 474 +++++++++++++++++++++++++++++++ lib/manifest.ml | 718 ++++++++++++++++++++++++++++++++++++++++++++++ lib/name.ml | 73 +++++ lib/nixtamal.ml | 190 +++++++++++++ lib/prefetch.ml | 96 +++++++ lib/util.ml | 196 +++++++++++++ lib/working_directory.ml | 76 +++++ 14 files changed, 3808 insertions(+) create mode 100644 lib/dune create mode 100644 lib/editor.ml create mode 100644 lib/error.ml create mode 100644 lib/input.ml create mode 100644 lib/input_foreman.ml create mode 100644 lib/kdl_lens_result.ml create mode 100644 lib/lock_loader.ml create mode 100644 lib/lockfile.ml create mode 100644 lib/manifest.ml create mode 100644 lib/name.ml create mode 100644 lib/nixtamal.ml create mode 100644 lib/prefetch.ml create mode 100644 lib/util.ml create mode 100644 lib/working_directory.ml (limited to 'lib') diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..bd587da --- /dev/null +++ b/lib/dune @@ -0,0 +1,11 @@ +(library + (public_name nixtamal) + (name nixtamal) + (libraries eio eio_main jingoo jsont jsont.bytesrw kdl logs saturn uri) + (preprocess + (pps + ppx_deriving.enum + ppx_deriving.eq + ppx_deriving.ord + ppx_deriving.make + ppx_deriving.show))) diff --git a/lib/editor.ml b/lib/editor.ml new file mode 100644 index 0000000..a0a6752 --- /dev/null +++ b/lib/editor.ml @@ -0,0 +1,19 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception β”‚ +└─────────────────────────────────────────────────────────────────────────────*) + +let find () = + match Sys.getenv_opt "VISUAL" with + | Some v -> v + | None -> + match Sys.getenv_opt "EDITOR" with + | Some e -> e + | None -> "vi" + +let run_on file = + match find () with + | ed when String.contains ed ' ' -> + Unix.execvp "/bin/sh" [|"/bin/sh"; "-c"; ed ^ " " ^ file|] + | ed -> + Unix.execvp ed [|ed; file|] diff --git a/lib/error.ml b/lib/error.ml new file mode 100644 index 0000000..4255c79 --- /dev/null +++ b/lib/error.ml @@ -0,0 +1,77 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +open Name + +type manifest_error = [ + | `Parsing of Util.KDL.Valid.err list + | `Not_set_up + | `File_already_exists +] +[@@deriving show] + +type lockfile_error = [ + | `Parsing of string + | `Serializing of string +] +[@@deriving show] + +type prefetch_method = [ + | `URL + | `Git + | `Darcs + | `Pijul +] +[@@deriving show] + +type prefetch_error = [ + | `Empty_output of prefetch_method + | `Stderr of prefetch_method * string + | `JSON_parsing of prefetch_method * string + | `Darcs_context of string + | `Exception of prefetch_method * string +] +[@@deriving show] + +type input_foreman_error = [ + | `Could_not_add of Name.t + | `Could_not_drop of Name.t + | `Could_not_get of Name.t + | `Could_not_set of Name.t + | `Latest_cmd_empty of Name.t + | `Latest_cmd_fail of Name.t * string + | `Latest_cmd_stderr of Name.t * string + | `Prefetch of Name.t * prefetch_error + | `Pool_exception of string + (* FIXME: string list *) + | `Many_errors of string list +] +[@@deriving show] + +type error = [ + | `Manifest of manifest_error + | `Lockfile of lockfile_error + | `Version_mismatch of string * string + | `Input_foreman of input_foreman_error +] +[@@deriving show] + +let [@inline]tag_manifest (res : ('a, manifest_error) result) = + Result.map_error (fun err -> `Manifest err) res + +let [@inline]tag_lockfile (res : ('a, lockfile_error) result) = + Result.map_error (fun err -> `Lockfile err) res + +let [@inline]tag_input_foreman res = + Result.map_error (fun err -> `Input_foreman err) res + +let pp ppf = function + | `Manifest err -> + Fmt.(pf ppf "%a" pp_manifest_error err) + | `Lockfile err -> + Fmt.(pf ppf "%a" pp_lockfile_error err) + | `Version_mismatch (mnfst, lock) -> + Fmt.pf ppf "Version mismatch: Manifest@@%s & Lockfile@@%s" mnfst lock + | `Input_foreman (`CouldNotAdd name) -> + Fmt.pf ppf "Could not set %a" Name.pp name diff --git a/lib/input.ml b/lib/input.ml new file mode 100644 index 0000000..6ff5e6e --- /dev/null +++ b/lib/input.ml @@ -0,0 +1,362 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +open Name + +type jg_models2 = string -> Jingoo.Jg_types.tvalue + +module Template = struct + type t = + Template of string + [@@unboxed] + [@@deriving show] + + let [@inline]make t = Template t + let [@inline]take (Template t) = t + let [@inline]fill ~(models : jg_models2) tpl = + Jingoo.Jg_template2.from_string ~models (take tpl) +end + +module Latest = struct + module Cmd = struct + type 'a non_empty_list = + ('a * 'a list) + [@@deriving show] + + type cmd = { + prog: Template.t; + args: Template.t list; + } + [@@deriving show, make] + + type t = cmd non_empty_list + [@@deriving show] + + let (~$) x = (x, []) + let (|:) (x, xs) x' = (x, x' :: xs) + let (@) (x, xs) (y, ys) = (x, xs @ y :: ys) + end + + type t = { + cmd: Cmd.t option; + value: string option; + } + [@@deriving show, make] +end + +(* KINDS **********************************************************************) + +module File = struct + type t = { + url: Template.t; + mirrors: Template.t list; + } + [@@deriving show, make] +end + +module Archive = struct + type t = { + url: Template.t; + mirrors: Template.t list; + } + [@@deriving show, make] +end + +module Git = struct + module Reference = struct + type t = [ + | `Branch of string + | `Ref of string + ] + [@@deriving show] + end + + type t = { + repository: Template.t; + mirrors: Template.t list; + reference: Reference.t; + datetime: string option; (* ISO 8601 RFC 3339 *) + submodules: bool; [@default false] + lfs: bool; [@default false] + latest_revision: string option; + } + [@@deriving show, make] + + let default_latest_cmd git : Latest.Cmd.t = + let open Latest.Cmd in + let git_ls_remote flag value : t = + let m = Latest.Cmd.make_cmd in + let t = Template.make in + ~$(m ~prog: (t "git") ~args: [t "ls-remote"; t flag; git.repository; t "--refs"; t value] ()) + |: (m ~prog: (t "cut") ~args: [t "-f1"] ()) + in + match git.reference with + | `Branch b -> git_ls_remote "--branches" b + | `Ref r -> git_ls_remote "--heads" r +end + +module Darcs = struct + module Reference = struct + type t = [ + | `Context of [`Assumed of string option | `Stated of string] + | `Tag of string + ] + [@@deriving show] + end + + type t = { + repository: Template.t; + mirrors: Template.t list; + reference: Reference.t; + datetime: string option; (* ISO 8601 RFC 3339 *) + latest_weak_hash: string option; + } + [@@deriving show, make] + + let pp fmt t = Fmt.pf fmt "%s" (show t) +end + +module Pijul = struct + module Reference = struct + type t = [ + | `Channel of string + | `State of string + | `Change of string + ] + [@@deriving show] + end + + type t = { + remote: Template.t; + mirrors: Template.t list; + reference: Reference.t; + datetime: string option; (* ISO 8601 RFC 3339 *) + latest_state: string option; + } + [@@deriving show, make] +end + +module Hash = struct + type algorithm = + | SHA256 + | SHA512 + | BLAKE3 + [@@deriving enum, eq, ord, show] + + let algorithm_to_string = function + | SHA256 -> "SHA256" + | SHA512 -> "SHA512" + | BLAKE3 -> "BLAKE3" + + let algorithm_to_string_lower = + Fun.compose String.lowercase_ascii algorithm_to_string + + let algorithm_of_string = function + | "SHA256" | "sha256" -> Some SHA256 + | "SHA512" | "sha512" -> Some SHA512 + | "BLAKE3" | "blake3" -> Some BLAKE3 + | _ -> None + + (* many of the builtin fetchers may only work with SHA256 *) + let default_algorithm = SHA256 + + type t = { + algorithm: algorithm; + [@default default_algorithm] + (* None is for not yet calculated *) + value: string option; + (* used to assert in fetching for manually-updated pins *) + expected: string option; + } + [@@deriving show, make] +end + +(* INPUT *******************************************************************) + +module Kind = struct + type t = [ + | `File of File.t + | `Archive of Archive.t + | `Git of Git.t + | `Darcs of Darcs.t + | `Pijul of Pijul.t + ] + [@@deriving show] +end + +let make_kind_file ~url ?mirrors () = + `File (File.make ~url ?mirrors ()) + +let make_kind_archive ~url ?mirrors () = + `Archive (Archive.make ~url ?mirrors ()) + +let make_kind_darcs ~repository ?mirrors ~reference ?latest_weak_hash () = + `Darcs (Darcs.make ~repository ?mirrors ~reference ?latest_weak_hash ()) + +let make_kind_pijul ~remote ?mirrors ~reference ?latest_state () = + `Pijul (Pijul.make ~remote ?mirrors ~reference ?latest_state ()) + +let make_kind_git ~repository ?mirrors ~reference ?latest_revision ?submodules ?lfs () = + `Git (Git.make ~repository ?mirrors ~reference ?latest_revision ?submodules ?lfs ()) + +type t = { + name: Name.t; + kind: Kind.t; + (* This is use to override or provide a command to get the latest change or + revision or timestamp or whatever. *) + latest: Latest.t; [@default Latest.make ()] + hash: Hash.t; [@default Hash.make ()] + frozen: bool; [@default false] +} +[@@deriving show, make] + +let latest_cmd (input : t) : Latest.Cmd.t option = + match input.latest.cmd with + | None -> + ( + match input.kind with + | `Git g -> Some (Git.default_latest_cmd g) + (* Would be nice if other tools did a better job letting you query the + remote repository directly, but that isn’t where we are *) + | _ -> None + ) + | Some cmd -> Some cmd + +(* JINGOO MODELS **************************************************************) + +let jg_models2 (input : t) (needle : string) : Jingoo.Jg_types.tvalue = + let open Jingoo.Jg_types in + let opt_count = Option.fold ~none: 0 ~some: (Fun.const 1) in + (* presupplied with global values *) + let make_hashtbl (further_size : int) : (string, tvalue) Hashtbl.t = + let size = 1 + opt_count input.latest.value in + let htbl = Hashtbl.create (size + further_size) in + Hashtbl.add htbl "name" (Tstr (Name.take input.name)); + Option.iter (fun v -> Hashtbl.add htbl "cmd_value" (Tstr v)) input.latest.value; + htbl + in + let hashtbl = + match input.kind with + | `File _ -> + make_hashtbl 0 + | `Archive _ -> + make_hashtbl 0 + | `Git g -> + begin + let htbl = make_hashtbl 5 in + ( + match g.reference with + | `Branch b -> Hashtbl.add htbl "branch" (Tstr b) + | `Ref r -> Hashtbl.add htbl "ref" (Tstr r) + ); + Option.iter (fun d -> Hashtbl.add htbl "datetime" (Tstr d)) g.datetime; + Hashtbl.add htbl "lfs" (Tbool g.lfs); + Hashtbl.add htbl "submodules" (Tbool g.submodules); + Option.iter + (fun r -> + List.iter (fun key -> Hashtbl.add htbl key (Tstr r)) ["rev"; "revision"] + ) + g.latest_revision; + htbl + end + | `Darcs d -> + begin + let htbl = make_hashtbl 2 in + ( + match d.reference with + | `Context (`Stated sc) -> + Hashtbl.add htbl "context" (Tstr sc) + | `Context (`Assumed ac) -> + Option.iter (fun c -> Hashtbl.add htbl "context" (Tstr c)) ac + | `Tag t -> + Hashtbl.add htbl "tag" (Tstr t) + ); + Option.iter (fun d -> Hashtbl.add htbl "datetime" (Tstr d)) d.datetime; + Option.iter (fun w -> Hashtbl.add htbl "weak_hash" (Tstr w)) d.latest_weak_hash; + htbl + end + | `Pijul p -> + begin + let htbl = make_hashtbl 2 in + ( + match p.reference with + | `Channel c -> Hashtbl.add htbl "channel" (Tstr c) + | `State s -> Hashtbl.add htbl "state" (Tstr s) + | `Change c -> Hashtbl.add htbl "change" (Tstr c) + ); + Option.iter (fun d -> Hashtbl.add htbl "datetime" (Tstr d)) p.datetime; + Option.iter (fun s -> Hashtbl.add htbl "state" (Tstr s)) p.latest_state; + htbl + end + in + try Hashtbl.find hashtbl needle with Not_found -> Tnull + +(* NIXPKGS ********************************************************************) + +(* Nixpkgs is so critical & valuable to the Nix ecosystem that it gets its own + special treatment; it is also *required* to get access to many of the + fetchers *) +module Nixpkgs = struct + let name = Name.make "nixpkgs" + + let default_git_repository = Template.make "https://github.com/NixOS/nixpkgs.git" + + (* NOTE: "refs/heads/nixpkgs-unstable" is probably good enough for your + project, but defaulting to nixos-unstable since it is β€˜safer’, requiring + that all the NixOS tests pass *) + let default_ref = "refs/heads/nixos-unstable" + + let default_hash = Hash.make ~algorithm: Hash.SHA256 () + + let known_git_mirrors : Template.t list = + List.map Template.make [ + "https://mirrors.tuna.tsinghua.edu.cn/git/nixpkgs.git" + ] + + let mk_latest ~reference ?latest_value () : Latest.t = + let mk_latest_cmd ~flag ~arg : Latest.Cmd.t = + let open Latest.Cmd in + let m = Latest.Cmd.make_cmd in + let t = Template.make in + ~$(m ~prog: (t "git") ~args: [t "ls-remote"; t flag; default_git_repository; t "--refs"; t arg] ()) + |: (m ~prog: (t "cut") ~args: [t "-f1"] ()) + in + { + cmd = begin + match reference with + | `Ref r -> Some (mk_latest_cmd ~flag: "--heads" ~arg: r); + | `Branch b -> Some (mk_latest_cmd ~flag: "--branches" ~arg: b); + end; + value = latest_value; + } + + let make_archive ?(reference = `Ref default_ref) ?latest_value () = + let latest = mk_latest ~reference ?latest_value () in + let url = + Template.make "https://github.com/NixOS/nixpkgs/archive/{{cmd_value}}.tar.gz" + in + let kind = make_kind_archive ~url () in + make ~name ~kind ~latest ~hash: default_hash () + + (* The TUNA mirror is a Git mirror, so normalize on Git *) + let make_git_with_known_mirrors + ?(extra_mirrors = []) + ?(reference = `Ref default_ref) + ?latest_revision + ?submodules + ?lfs + () + = + let kind = + make_kind_git + ~repository: default_git_repository + ~mirrors: (known_git_mirrors @ extra_mirrors) + ~reference + ?latest_revision + ?submodules + ?lfs + () + in + make ~name ~kind ~hash: default_hash () +end diff --git a/lib/input_foreman.ml b/lib/input_foreman.ml new file mode 100644 index 0000000..4808d6d --- /dev/null +++ b/lib/input_foreman.ml @@ -0,0 +1,722 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +open Name + +type error = Error.input_foreman_error + +module Htbl = Saturn.Htbl + +type t = (Name.t, Input.t) Htbl.t + +let inputs : t = + Htbl.create + ~hashed_type: (module struct + type t = Name.t + let equal = Name.equal + let hash n = Hashtbl.hash (Name.take n) + end) + ~min_buckets: 8 + ~max_buckets: 1024 + () + +let pp fmt inputs' = + let name_map : Input.t NameMap.t = + Htbl.to_seq inputs' + |> Seq.fold_left + (fun acc (name, input) -> NameMap.add name input acc) + NameMap.empty + in + Fmt.pf fmt "%a" (NameMap.pp Input.pp) name_map + +(* Ugly, but *shrug* *) +let pp_for_earthlings pff = + let hp_k_v ppf' (k, v) = Fmt.pf ppf' "\t%s: %s" k v in + let hp_betupled_input ppf' (name, kind, data) = + Fmt.pf ppf' "%s: (%s)@;" (Name.take name) kind; + Fmt.pf ppf' "%a" (Fmt.list ~sep: (Fmt.any "@.") hp_k_v) data; + and betuple (input : Input.t) : Name.t * string * (string * string) list = + let models = Input.jg_models2 input in + let fill = Input.Template.fill ~models in + let kind_name, kind_tuples = + match input.kind with + | `File f -> + "file", + ("url", fill f.url) :: List.map (fun m -> "mirror", fill m) f.mirrors + | `Archive a -> + "archive", + ("url", fill a.url) :: List.map (fun m -> "mirror", fill m) a.mirrors + | `Git g -> + "git", + List.concat [ + ["repository", fill g.repository]; + (List.map (fun m -> "mirror", fill m) g.mirrors); + ( + match g.reference with + | `Branch b -> ["branch", b] + | `Ref r -> ["ref", r] + ); + Option.fold ~none: [] ~some: (fun d -> ["datetime", d]) g.datetime; + ["submodules", Fmt.str "%a" Fmt.bool g.submodules; + "lfs", Fmt.str "%a" Fmt.bool g.lfs; + ]; + Option.fold ~none: [] ~some: (fun r -> ["latest-revision", r]) g.latest_revision; + ] + | `Darcs d -> + "darcs", + List.concat [ + ["repository", fill d.repository]; + (List.map (fun m -> ("mirror", fill m)) d.mirrors); + ( + match d.reference with + | `Context (`Assumed None) -> [] + | `Context (`Assumed (Some ac)) -> ["context (assumed)", ac] + | `Context (`Stated sc) -> ["context (stated)", sc] + | `Tag t -> [("tag", t)] + ); + Option.fold ~none: [] ~some: (fun d -> ["datetime", d]) d.datetime; + Option.fold ~none: [] ~some: (fun w -> ["latest-weak-hash", w]) d.latest_weak_hash; + ] + | `Pijul p -> + "pijul", + List.concat [ + [("remote", fill p.remote)]; + (List.map (fun m -> "mirror", fill m) p.mirrors); + ( + match p.reference with + | `Channel c -> ["channel", c] + | `State s -> ["state", s] + | `Change c -> ["change", c] + ); + Option.fold ~none: [] ~some: (fun d -> ["datetime", d]) p.datetime; + Option.fold ~none: [] ~some: (fun s -> ["latest-state", s]) p.latest_state; + ] + in + let data_tuples : (string * string) list = + List.concat [ + kind_tuples; + ( + match input.latest.cmd with + | None -> [] + | Some (cmd, cmds) -> + let cmd_str_filled ({prog; args}: Input.Latest.Cmd.cmd) = + List.map fill (prog :: args) + in + let cmds' = + List.map cmd_str_filled (cmd :: cmds) + and formatter = + Fmt.list ~sep: (Fmt.any " ") (Fmt.list ~sep: (Fmt.any " ") Fmt.string) + in + [("latest-cmd", Fmt.str "$ %a" formatter cmds')] + ); + Option.fold ~none: [] ~some: (fun v -> ["latest-value", v]) input.latest.value; + ["hash-algorithm", Input.Hash.algorithm_to_string input.hash.algorithm]; + Option.fold ~none: [] ~some: (fun r -> ["hash-value", r]) input.hash.value; + Option.fold ~none: [] ~some: (fun r -> ["hash-expected", r]) input.hash.expected; + ["frozen", Fmt.str "%a" Fmt.bool input.frozen]; + ] + in + (input.name, kind_name, data_tuples) + in + Htbl.to_seq inputs + |> Seq.fold_left (fun acc ((Name.Name name), input) -> (Name.Name name, betuple input) :: acc) [] + |> List.stable_sort (fun (name_a, _) (name_b, _) -> Name.compare name_a name_b) + |> List.map (fun (_, s) -> s) + |> Fmt.pf pff "%a" (Fmt.list ~sep: (Fmt.any "@.@.") hp_betupled_input) + +let get name : (Input.t, error) result = + Logs.debug (fun m -> m "Get input %a" Name.pp name); + match Htbl.find_opt inputs name with + | Some s -> Ok s + | None -> Error (`Could_not_get name) + +let set name input : (unit, error) result = + Logs.debug (fun m -> m "Set input ⟨%a, %a⟩" Name.pp name Input.pp input); + if Htbl.try_set inputs name input then + Ok () + else + Error (`Could_not_set name) + +let add name input : (unit, error) result = + Logs.debug (fun m -> m "Add input ⟨%a, %a⟩" Name.pp name Input.pp input); + if Htbl.try_add inputs name input then + Ok () + else + Error (`Could_not_add name) + +let drop name : (unit, error) result = + Logs.debug (fun m -> m "Drop input %a" Name.pp name); + if Htbl.try_remove inputs name then + Ok () + else + Error (`Could_not_drop name) + +let to_manifest mk = + Htbl.to_seq inputs + |> Seq.fold_left (fun acc (name, input) -> (name, mk input) :: acc) [] + |> List.stable_sort (fun (name_a, _) (name_b, _) -> Name.compare name_a name_b) + |> List.concat_map (fun (_, manifest_node) -> manifest_node) + +let to_lockfile mk = + Htbl.to_seq inputs + |> Seq.fold_left + (fun acc (name, input) -> NameMap.add name (mk input) acc) + NameMap.empty + +let cp_darcs_context ~env ~(name : Name.t) ~context = + let (let*) = Result.bind in + let original_path = + if String.starts_with ~prefix: "/" context then + Eio.Path.(Eio.Stdenv.fs env / context) + else + Eio.Path.(Working_directory.get () / context) + in + let* () = Working_directory.set_up_darcs_context_if_needed () in + let path = + Eio.Path.( + Working_directory.(get () / darcs_context_dir / (Fmt.str "%s.txt" (Name.take name))) + ) + in + Logs.app (fun m -> + m + "Copying Darcs context file for %a from %a to %a …" + Name.pp + name + Eio.Path.pp + original_path + Eio.Path.pp + path + ); + let () = + Eio.Path.with_open_in original_path @@ fun input -> + Eio.Path.with_open_out ~create: (`Or_truncate 0o644) path @@ fun output -> + Eio.Flow.copy input output + in + Ok (Fmt.str "./%s/%s.txt" Working_directory.darcs_context_dir (Name.take name)) + +exception Proc_error of string + +let prefetch ~env ~proc_mgr ~name () : (unit, error) result = + Logs.app (fun m -> m "Prefetching input %a … (this may take a while)" Name.pp name); + let open Input in + let (let*) = Result.bind in + let* input = get name in + let hash_algo_type_val = Input.Hash.algorithm_to_string_lower input.hash.algorithm in + let proc_env = + let unix_env = Unix.environment () in + Array.append unix_env [|"NIX_HASH_ALGO=" ^ hash_algo_type_val|] + in + let stdout_buf = Buffer.create 1024 + and stderr_buf = Buffer.create 1024 + in + let stdout_sink = Eio.Flow.buffer_sink stdout_buf + and stderr_sink = Eio.Flow.buffer_sink stderr_buf + and models = Input.jg_models2 input + in + let prefetch_file (f : File.t) : (Input.t, Error.prefetch_error) result = + let method' = `URL + and url = Uri.of_string (Input.Template.fill f.url ~models) + in + let cmd = [ + "nix-prefetch-url"; + Uri.to_string url; + "--type"; + hash_algo_type_val; + ] + in + Logs.debug (fun m -> m "Running file cmd: %a" (Fmt.list ~sep: Fmt.sp Fmt.string) cmd); + try + let () = + Eio.Process.run + proc_mgr + ~env: proc_env + ~stdout: stdout_sink + ~stderr: stderr_sink + cmd + in + let stderr_str = String.trim @@ Buffer.contents stderr_buf in + (* Fkin’ A… why use stderr for *not* errors, Nixβ€½ *) + if stderr_str <> "" && not (String.starts_with ~prefix: "path is" stderr_str) then + Error (`Stderr (method', stderr_str)) + else + let stdin_str = String.trim @@ Buffer.contents stdout_buf in + Logs.debug (fun m -> m "Command output: %s" stdin_str); + let last_nonempty_line = + String.split_on_char '\n' stdin_str + |> List.rev + |> List.find_opt (fun line -> line <> "") + in + match last_nonempty_line with + | None -> Error (`Empty_output method') + | value -> Ok {input with hash = {input.hash with value}} + with + | exn -> Error (`Exception (method', Printexc.to_string exn)) + + and prefetch_archive (a : Archive.t) : (Input.t, Error.prefetch_error) result = + let method' = `URL + and url = Uri.of_string (Input.Template.fill a.url ~models) + in + let cmd = [ + "nix-prefetch-url"; + Uri.to_string url; + "--unpack"; + "--type"; + hash_algo_type_val; + ] + in + Logs.debug (fun m -> m "Running archive cmd: %a" (Fmt.list ~sep: Fmt.sp Fmt.string) cmd); + try + let () = + Eio.Process.run + proc_mgr + ~env: proc_env + ~stdout: stdout_sink + ~stderr: stderr_sink + cmd + in + let stderr_str = String.trim @@ Buffer.contents stderr_buf in + (* Fkin’ A… why use stderr for *not* errors, Nixβ€½ *) + if stderr_str <> "" && not (String.starts_with ~prefix: "path is" stderr_str) then + Error (`Stderr (method', stderr_str)) + else + let stdin_str = String.trim @@ Buffer.contents stdout_buf in + Logs.debug (fun m -> m "Command output: %s" stdin_str); + let last_nonempty_line = + String.split_on_char '\n' stdin_str + |> List.rev + |> List.find_opt (fun line -> line <> "") + in + match last_nonempty_line with + | None -> Error (`Empty_output method') + | value -> Ok {input with hash = {input.hash with value}} + with + | exn -> Error (`Exception (method', Printexc.to_string exn)) + + and prefetch_git (g : Git.t) : (Input.t, Error.prefetch_error) result = + let method' = `Git + and repository = Uri.of_string (Input.Template.fill g.repository ~models) + in + let cmd = [ + "nix-prefetch-git"; + "--no-deepClone"; + "--quiet"; + "--url"; + Uri.to_string repository; + ] + in + Logs.debug (fun m -> m "Running Git cmd: %a" (Fmt.list ~sep: Fmt.sp Fmt.string) cmd); + let cmd = + List.concat [ + cmd; + ( + match g.reference with + | `Branch b -> ["--branch-name"; b] + | `Ref r -> ["--rev"; r] + ); + if g.submodules then ["--fetch-submodules"] else []; + if g.lfs then ["--fetch-lfs"] else []; + ]; + in + try + let () = + Eio.Process.run + proc_mgr + ~env: proc_env + ~stdout: stdout_sink + ~stderr: stderr_sink + cmd + in + let stderr_str = String.trim @@ Buffer.contents stderr_buf in + if stderr_str <> "" then + Error (`Stderr (method', stderr_str)) + else + let stdin_str = Buffer.contents stdout_buf in + Logs.debug (fun m -> m "Command output: %s" stdin_str); + let* data = + if stdin_str = "" then + Error (`Empty_output method') + else + Jsont_bytesrw.decode_string Prefetch.Git.jsont stdin_str + |> Result.map_error (fun err -> `JSON_parsing (method', err)) + in + Ok {input with + kind = + `Git {g with + latest_revision = Some data.rev; + datetime = data.datetime; + }; + hash = {input.hash with + algorithm = data.hash.algorithm; + value = Some data.hash.value; + }; + } + with + | exn -> Error (`Exception (method', Printexc.to_string exn)) + + and prefetch_darcs (d : Darcs.t) : (Input.t, Error.prefetch_error) result = + let method' = `Darcs + and repository = Input.Template.fill d.repository ~models + in + let cmd = ["nix-prefetch-darcs"] in + (* formatter looks ugly so doing cmd = cmd @ […] *) + let cmd = + match d.reference with + | `Context (`Assumed _) -> cmd + | `Context (`Stated sc) -> cmd @ ["--context"; sc] + | `Tag t -> cmd @ ["--tag"; t] + in + let cmd = cmd @ [repository] in + Logs.debug (fun m -> m "Running Darcs cmd: %a" (Fmt.list ~sep: Fmt.sp Fmt.string) cmd); + try + let () = + Eio.Process.run + proc_mgr + ~env: proc_env + ~stdout: stdout_sink + ~stderr: stderr_sink + cmd + in + let stderr_str = String.trim @@ Buffer.contents stderr_buf in + if stderr_str <> "" then + Error (`Stderr (method', stderr_str)) + else + let stdin_str = Buffer.contents stdout_buf in + Logs.debug (fun m -> m "Command output: %s" stdin_str); + let* data = + if stdin_str = "" then + Error (`Empty_output method') + else + Jsont_bytesrw.decode_string Prefetch.Darcs.jsont stdin_str + |> Result.map_error (fun err -> `JSON_parsing (method', err)) + in + let* reference = + match d.reference with + | `Context (`Assumed _) -> + (* TODO: copy file *) + let* new_ctx = + cp_darcs_context ~env ~name ~context: data.context + |> Result.map_error (fun err -> `Darcs_context err) + in + Ok (`Context (`Assumed (Some new_ctx))) + | _ -> + Ok d.reference + in + Ok {input with + kind = + `Darcs {d with + reference; + datetime = data.datetime; + latest_weak_hash = Some data.weak_hash; + }; + hash = {input.hash with + algorithm = data.hash.algorithm; + value = Some data.hash.value; + }; + } + with + | exn -> Error (`Exception (method', Printexc.to_string exn)) + + and prefetch_pijul (p : Pijul.t) : (Input.t, Error.prefetch_error) result = + let method' = `Pijul + and cmd = [ + "nix-prefetch-pijul"; + "--remote"; + Input.Template.fill p.remote ~models; + ] + in + let cmd = + cmd @ + match p.reference with + | `Change c -> ["--change"; c] + | `Channel c -> ["--channel"; c] + | `State s -> ["--state"; s] + in + Logs.debug (fun m -> m "Running Pijul cmd: %a" (Fmt.list ~sep: Fmt.sp Fmt.string) cmd); + try + let () = + Eio.Process.run + proc_mgr + ~env: proc_env + ~stdout: stdout_sink + ~stderr: stderr_sink + cmd + in + let stderr_str = String.trim @@ Buffer.contents stderr_buf in + if stderr_str <> "" then + Error (`Stderr (method', stderr_str)) + else + let stdin_str = Buffer.contents stdout_buf in + Logs.debug (fun m -> m "Command output: %s" stdin_str); + let* data = + if stdin_str = "" then + Error (`Empty_output method') + else + Jsont_bytesrw.decode_string Prefetch.Pijul.jsont stdin_str + |> Result.map_error (fun err -> `JSON_parsing (method', err)) + in + Ok {input with + kind = + `Pijul {p with + datetime = data.datetime; + latest_state = Some data.state; + }; + hash = {input.hash with + algorithm = data.hash.algorithm; + value = Some data.hash.value; + }; + } + with + | exn -> Error (`Exception (method', Printexc.to_string exn)) + in + let* new_input : Input.t = + Result.map_error (fun err -> `Prefetch (input.name, err)) @@ begin + match input.kind with + | `File f -> prefetch_file f + | `Archive a -> prefetch_archive a + | `Git g -> prefetch_git g + | `Darcs d -> prefetch_darcs d + | `Pijul p -> prefetch_pijul p + end + in + Logs.app (fun m -> m "Prefetched %a." Name.pp input.name); + set name new_input + +let run_pipeline ~sw ~proc_mgr ~(models : Input.jg_models2) cmds = + let open Input.Latest.Cmd in + let rec build_pipeline ?stdin = function + | {prog; args}, [] -> + begin + let stdout_buf = Buffer.create 512 + and stderr_buf = Buffer.create 512 + in + let stdout_sink = Eio.Flow.buffer_sink stdout_buf + and stderr_sink = Eio.Flow.buffer_sink stderr_buf + and cmd = List.map (Input.Template.fill ~models) (prog :: args) + in + try + Eio.Process.run proc_mgr ?stdin ~stdout: stdout_sink ~stderr: stderr_sink cmd; + Option.iter Eio.Resource.close stdin; + (* close pipe input after last process *) + Ok (stdout_buf, stderr_buf) + with + | exn -> Error (Printexc.to_string exn) + end + | {prog; args}, next :: rest -> + begin + let pipe_in, pipe_out = Eio.Process.pipe ~sw proc_mgr in + let stderr_buf = Buffer.create 512 in + let stderr_sink = Eio.Flow.buffer_sink stderr_buf + and cmd = List.map (Input.Template.fill ~models) (prog :: args) + in + try + Eio.Process.run proc_mgr ?stdin ~stdout: pipe_out ~stderr: stderr_sink cmd; + Eio.Resource.close pipe_out; + (* close writer after child is spawned *) + build_pipeline ~stdin: pipe_in (next, rest) + with + | exn -> Error (Printexc.to_string exn) + end + in + build_pipeline cmds + +let get_latest ~sw ~proc_mgr input : (string option, error) result = + match Input.latest_cmd input with + | None -> + Ok None + | Some cmds -> + let name = input.name + and models = Input.jg_models2 input + in + match run_pipeline ~sw ~proc_mgr ~models cmds with + | Error err -> Error (`Latest_cmd_fail (name, err)) + | Ok (stdout_buf, stderr_buf) -> + let stderr_str = String.trim @@ Buffer.contents stderr_buf in + (* & shame on you for putting non-errors in the stderr *) + if stderr_str <> "" then + Error (`Latest_cmd_stderr (name, stderr_str)) + else + let latest_str = String.trim @@ Buffer.contents stdout_buf in + if latest_str = "" then + Error (`Latest_cmd_empty name) + else + Ok (Some latest_str) + +type latest_result = [ + | `LacksCmd + | `AlreadyLatest + | `NewLatestValue of string +] +[@@deriving show] + +let lock_one ~env ~sw ~proc_mgr ~force ~name : (unit, error) result = + Logs.info (fun m -> + if force then m "Locking input %a …" Name.pp name + else m "Locking input %a if needed …" Name.pp name + ); + let (let*) = Result.bind in + let* input = get name in + let* () = + match input.latest.cmd, input.latest.value, force with + (* Only if we have a command, but no value or forced *) + | Some _, None, _ | Some _, _, true -> + Logs.app (fun m -> m "Fetching latest value for %a …" Name.pp name); + begin + match get_latest ~sw ~proc_mgr input with + | Error err -> Error err + | Ok None -> Ok () + | Ok (Some new_value) -> + Logs.info (fun m -> m "New latest value: %a" Fmt.string new_value); + let latest = {input.latest with value = Some new_value} in + set name {input with latest} + end + | _, _, _ -> Ok () + in + let needs_prefetch : bool = + force + || if Option.is_none input.hash.value then + true + else + match input.kind with + | `File _ -> false + | `Archive _ -> false + | `Git g -> Option.is_none g.latest_revision + | `Darcs d -> Option.is_none d.latest_weak_hash + | `Pijul p -> Option.is_none p.latest_state + in + if needs_prefetch then + prefetch ~env ~proc_mgr ~name () + else + Ok () + +let lock_many ~env ~sw ~proc_mgr ~domain_count ~force ~(names : Name.t list) : (unit, error) result = + Logs.debug (fun m -> m "Locking many: %a" Fmt.(brackets (list ~sep: semi Name.pp)) names); + let dm = Eio.Stdenv.domain_mgr env in + let pool = Eio.Executor_pool.create ~sw ~domain_count dm in + let any_succeed, errors = + names + |> List.map + (fun name -> + Eio.Executor_pool.submit ~weight: 1.0 pool (fun () -> + lock_one ~env ~sw ~proc_mgr ~force ~name + ) + ) + |> List.fold_left + (fun (suc, errs) -> + function + | Ok (Ok()) -> + true, errs + | Ok (Error err) -> + suc, err :: errs + | Error exn -> + suc, (`Pool_exception (Printexc.to_string exn)) :: errs + ) + (false, []) + in + match any_succeed, errors with + | true, errs -> + let warn err = + Logs.warn (fun m -> m "Couldn’t lock: %a" Error.pp_input_foreman_error err) + in + List.iter warn errs; + Ok () + | false, [err] -> + Error err + | false, errs -> + let err_str = List.map (fun err -> Fmt.str "%a" Error.pp_input_foreman_error err) errs in + Error (`Many_errors err_str) + +let lock ~env ~sw ~proc_mgr ~domain_count ?(force = false) ?names () : (unit, error) result = + match names with + | None | Some [] -> + let all_names = + Htbl.to_seq inputs + |> Seq.fold_left (fun acc (name, _) -> name :: acc) [] + in + lock_many ~env ~sw ~proc_mgr ~domain_count ~force ~names: all_names + | Some [name] -> + lock_one ~env ~sw ~proc_mgr ~force ~name + | Some names -> + lock_many ~env ~sw ~proc_mgr ~domain_count ~force ~names + +let refresh_one ~env ~sw ~proc_mgr ~name : (unit, error) result = + Logs.app (fun m -> m "Refreshing input %a …" Name.pp name); + let (let*) = Result.bind in + let* input = get name in + let* latest_result : latest_result = + match get_latest ~sw ~proc_mgr input with + | Error err -> Error err + | Ok None -> Ok `LacksCmd + | Ok (Some(new_value : string)) -> + Logs.info (fun m -> m "Old latest value: %a" (Fmt.option ~none: (Fmt.const Fmt.string "βˆ…") Fmt.string) input.latest.value); + Logs.info (fun m -> m "New latest value: %a" Fmt.string new_value); + let is_outdated : string option -> bool = + Option.fold ~none: true ~some: (Fun.compose not (String.equal new_value)) + in + if is_outdated input.latest.value then + Ok (`NewLatestValue new_value) + else + Ok `AlreadyLatest + in + match latest_result with + | `LacksCmd -> + Logs.warn (fun m -> m "No β€œlatest-cmd” set for %a or a default for its kind … fetching from scratch (probably wastefully)." Name.pp input.name); + prefetch ~env ~proc_mgr ~name () + | `AlreadyLatest -> + Logs.app (fun m -> m "%a already at latest; moving on." Name.pp input.name); + Ok () + | `NewLatestValue new_value -> + let latest = {input.latest with value = Some new_value} in + let* () = set name {input with latest} in + (* If we had a new version, then it is time to prefetch *) + prefetch ~env ~proc_mgr ~name () + +let refresh_many ~env ~sw ~proc_mgr ~domain_count ~(names : Name.t list) : (unit, error) result = + Logs.debug (fun m -> m "Refreshing many: %a" Fmt.(brackets (list ~sep: semi Name.pp)) names); + let dm = Eio.Stdenv.domain_mgr env in + let pool = Eio.Executor_pool.create ~sw ~domain_count dm in + let any_succeed, errors = + names + |> List.map + (fun name -> + Eio.Executor_pool.submit ~weight: 1.0 pool (fun () -> + refresh_one ~env ~sw ~proc_mgr ~name + ) + ) + |> List.fold_left + (fun (suc, errs) -> + function + | Ok (Ok()) -> + true, errs + | Ok (Error err) -> + suc, err :: errs + | Error exn -> + suc, (`Pool_exception (Printexc.to_string exn)) :: errs + ) + (false, []) + in + match any_succeed, errors with + | true, errs -> + let warn err = + Logs.warn (fun m -> m "Couldn’t refresh: %a" Error.pp_input_foreman_error err) + in + List.iter warn errs; + Ok () + | false, [err] -> + Error err + | false, errs -> + let err_str = List.map (fun err -> Fmt.str "%a" Error.pp_input_foreman_error err) errs in + Error (`Many_errors err_str) + +let refresh ~env ~sw ~proc_mgr ~domain_count ?names () : (unit, error) result = + match names with + | None | Some [] -> + let all_names = + Htbl.to_seq inputs + |> Seq.fold_left (fun acc (name, _) -> name :: acc) [] + in + refresh_many ~env ~sw ~proc_mgr ~domain_count ~names: all_names + | Some [name] -> + refresh_one ~env ~sw ~proc_mgr ~name + | Some names -> + refresh_many ~env ~sw ~proc_mgr ~domain_count ~names diff --git a/lib/kdl_lens_result.ml b/lib/kdl_lens_result.ml new file mode 100644 index 0000000..3455f38 --- /dev/null +++ b/lib/kdl_lens_result.ml @@ -0,0 +1,390 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: eilveli β”‚ +β”‚ SPDX-FileContributor: toastal Fmt.pf fmt "Cannot each" + | `Cannot_replace -> Fmt.pf fmt "Cannot replace" + | `Missing_annot -> Fmt.pf fmt "Missing annotation" + | `Missing_arg arg -> Fmt.pf fmt "Missing argument β€œ%s”" arg + | `Missing_prop prop -> Fmt.pf fmt "Missing property β€œ%s”" prop + | `Missing_index idx -> Fmt.pf fmt "Missing index β€œ%d”" idx + | `Missing_top -> Fmt.pf fmt "Missing top-level node" + | `Not_found (name, annot) -> + begin + match annot with + | None -> Fmt.pf fmt "Not found β€œ%s”" name + | Some a -> Fmt.pf fmt "Not found β€œ%s” with annotation (%s)" name a + end + | `Mismatched_type -> Fmt.pf fmt "Mismatched type" + | `Wrong_type_bool -> Fmt.pf fmt "Wrong type, expected a boolean" + | `Wrong_type_float -> Fmt.pf fmt "Wrong type, expected a float" + | `Wrong_type_Int -> Fmt.pf fmt "Wrong type, expected an int" + | `Wrong_type_Int32 -> Fmt.pf fmt "Wrong type, expected an int32" + | `Wrong_type_Int64 -> Fmt.pf fmt "Wrong type, expected an int64" + | `Wrong_type_native_int -> Fmt.pf fmt "Wrong type, expected a native int" + | `Wrong_type_null -> Fmt.pf fmt "Wrong type, expected a null" + | `Wrong_type_number -> Fmt.pf fmt "Wrong type, expected a number" + | `Wrong_type_string -> Fmt.pf fmt "Wrong type, expected a string" + | `Wrong_type_stringNumber -> Fmt.pf fmt "Wrong type, expected a string number" + +open Kdl + +(* note: we can possibly replace option with result for more detailed errors *) + +type ('s, 'a) lens = { + get: 's -> ('a, lerr) result; + set: 'a -> 's -> ('s, lerr) result; +} + +let get a lens = lens.get a + +let set a v lens = lens.set v a + +let get_exn a lens = + match lens.get a with + | Ok v -> v + (*| Error e -> failwith (String.concat "; " (List.map lerr_to_string e))*) + | Error e -> failwith (show_lerr e) + +let set_exn a v lens = + match lens.set v a with + | Ok v -> v + (*| Error e -> failwith (String.concat "; " (List.map lerr_to_string e))*) + | Error e -> failwith (show_lerr e) + +(* note: update can possibly be added to the definition of [lens] to increase + performance with more specialized implementations *) + +let update f a lens = + match lens.get a with + | Error e -> Error e + | Ok value -> + match f value with + | Ok value' -> lens.set value' a + | Error e -> Error e + +let compose l1 l2 = { + get = (fun x -> + match l2.get x with + | Ok x' -> l1.get x' + | Error e -> Error e + ); + set = (fun v a -> update (l1.set v) a l2) +} + +let ( // ) l1 l2 = compose l2 l1 + +let (|--) = ( // ) + +let (.@()) = get +let (.@() <-) a l v = set a v l + +let (.@!()) = get_exn +let (.@!() <-) a l v = set_exn a v l + +let node_name = { + get = (fun node -> Ok node.name); + set = (fun name node -> Ok {node with name}); +} + +let node_annot = { + get = (fun node -> Option.to_result ~none: `Missing_annot node.annot); + set = (fun annot node -> Ok {node with annot = Some annot}); +} + +(* Unset the annotation by passing None *) +let node_annot_opt = { + get = (fun node -> Ok node.annot); + set = (fun annot node -> Ok {node with annot}); +} + +let args = { + get = (fun node -> Ok node.args); + set = (fun args node -> Ok {node with args}); +} + +let props = { + get = (fun node -> Ok node.props); + set = (fun props node -> Ok {node with props}); +} + +let children = { + get = (fun node -> Ok node.children); + set = (fun children node -> Ok {node with children}); +} + +let top = { + get = (function node :: _ -> Ok node | [] -> Error `Missing_top); + set = (fun node -> function _ :: xs -> Ok (node :: xs) | [] -> Error `Missing_top); +} + +open struct + let nth_and_replace n x' list = + let found = ref false in + (* Note: Unlike List.mapi, this stops iterating when we've found the element *) + let [@tail_mod_cons] rec go i = function + | [] -> [] + | _ :: xs when i = n -> found := true; x' :: xs + | x :: xs -> x :: go (i + 1) xs + in + let result = go 0 list in + if !found then Ok result else Error (`Missing_index n) + + let filter_and_replace f replace_list list = + let found = ref false in + let f (replace, result) x = + if f x then + begin + found := true; + match replace with + | x' :: xs -> xs, x' :: result + | [] -> [], x :: result + end + else + replace, x :: result + in + let _, list = List.fold_left f (replace_list, []) list in + if !found then Ok (List.rev list) else Error `Cannot_replace + + let [@inline]matches_node ?annot name node = + String.equal node.name name + && ( + match annot with + | Some a -> + ( + match node.annot with + | Some a' -> String.equal a a' + | None -> false + ) + | None -> true + ) + + let rec find_node n annot name = function + | [] -> Error (`Not_found (name, annot)) + | x :: xs when matches_node ?annot name x -> + if n <= 0 then Ok x else find_node (n - 1) annot name xs + | _ :: xs -> find_node n annot name xs + + let find_and_replace_node nth annot name x' list = + let found = ref false in + let [@tail_mod_cons] rec go n = function + | [] -> [] + | x :: xs when matches_node ?annot name x -> + if n <= 0 then (found := true; x' :: xs) else x :: go (n - 1) xs + | x :: xs -> x :: go n xs + in + let result = go nth list in + if !found then Ok result else Error (`Not_found (name, annot)) +end + +let nth n = { + get = (fun list -> + List.nth_opt list n + |> Option.to_result ~none: (`Missing_index n) + ); + set = (fun x' list -> nth_and_replace n x' list) +} + +(* these operations are O(n), and update is quite inefficient *) +let arg n = { + (* Inlined [nth] instead of [args // nth n] *) + get = (fun node -> + List.nth_opt node.args n + |> Option.to_result ~none: (`Missing_index n) + ); + set = (fun arg' node -> + nth_and_replace n arg' node.args + |> Result.map (fun args -> {node with args}) + ) +} + +let first_arg = arg 0 + +let prop key = { + get = (fun node -> + List.assoc_opt key node.props + |> Option.to_result ~none: (`Missing_prop key) + ); + set = (fun v' node -> + let found = ref false in + let f (k, v) = if k = key then (found := true; k, v') else k, v in + let props = List.map f node.props in + if !found then Ok {node with props} else Error (`Missing_prop key) + ) +} + +let node ?(nth = 0) ?annot (name : string) = { + get = (fun nodes -> find_node nth annot name nodes); + set = (fun node' nodes -> find_and_replace_node nth annot name node' nodes) +} + +let node_many ?annot (name : string) = + let matches = matches_node ?annot name in + { + get = (fun nodes -> + match List.filter matches nodes with + | [] -> Error (`Not_found (name, annot)) + | xs -> Ok xs + ); + set = (fun nodes' nodes -> filter_and_replace matches nodes' nodes) + } + +let node_nth : int -> (node list, node) lens = nth + +(* TODO: get node by annot only? *) + +let child ?nth ?annot name = children // node ?nth ?annot name +let child_many ?annot name = children // node_many ?annot name +let child_nth n = children // node_nth n + +let value : (annot_value, value) lens = { + get = (fun (_, v) -> Ok v); + set = (fun v' (a, _) -> Ok (a, v')); +} + +let annot : (annot_value, string) lens = { + get = (fun (a, _) -> Option.to_result ~none: `Missing_annot a); + set = (fun a' (_, v) -> Ok (Some a', v)); +} + +let annot_opt : (annot_value, string option) lens = { + get = (fun (a, _) -> Ok a); + set = (fun a' (_, v) -> Ok (a', v)); +} + +let string = { + get = (function `String str -> Ok str | _ -> Error `Wrong_type_string); + set = (fun value' _value -> Ok (`String value')); +} + +(* Ast.Num.of_string not exposed *) +let number : (value, number) lens = { + get = (fun n -> L.number.get n |> Option.to_result ~none: `Wrong_type_number); + set = (fun num n -> L.number.set num n |> Option.to_result ~none: `Wrong_type_number); +} + +let string_number : (value, string) lens = { + get = (fun n -> L.string_number.get n |> Option.to_result ~none: `Wrong_type_stringNumber); + set = (fun x n -> L.string_number.set x n |> Option.to_result ~none: `Wrong_type_stringNumber); +} + +let float_number : (value, float) lens = { + get = (fun n -> L.float_number.get n |> Option.to_result ~none: `Wrong_type_float); + set = (fun x n -> L.float_number.set x n |> Option.to_result ~none: `Wrong_type_float); +} + +let int_number : (value, int) lens = { + get = (fun n -> L.int_number.get n |> Option.to_result ~none: `Wrong_type_Int); + set = (fun x n -> L.int_number.set x n |> Option.to_result ~none: `Wrong_type_Int); +} + +let int32_number : (value, int32) lens = { + get = (fun n -> L.int32_number.get n |> Option.to_result ~none: `Wrong_type_Int32); + set = (fun x n -> L.int32_number.set x n |> Option.to_result ~none: `Wrong_type_Int32); +} + +let int64_number : (value, int64) lens = { + get = (fun n -> L.int64_number.get n |> Option.to_result ~none: `Wrong_type_Int64); + set = (fun x n -> L.int64_number.set x n |> Option.to_result ~none: `Wrong_type_Int64); +} + +let nativeint_number : (value, nativeint) lens = { + get = (fun n -> L.nativeint_number.get n |> Option.to_result ~none: `Wrong_type_native_int); + set = (fun x n -> L.nativeint_number.set x n |> Option.to_result ~none: `Wrong_type_native_int); +} + +let bool = { + get = (function `Bool b -> Ok b | _ -> Error `Wrong_type_bool); + set = (fun value' _value -> Ok (`Bool value')) +} + +let null = { + get = (function `Null -> Ok () | _ -> Error `Wrong_type_null); + set = (fun _ _ -> Ok `Null) +} + +let string_value : (annot_value, string) lens = value // string +let number_value : (annot_value, number) lens = value // number +let string_number_value : (annot_value, string) lens = value // string_number +let float_number_value : (annot_value, float) lens = value // float_number +let int_number_value : (annot_value, int) lens = value // int_number +let int32_number_value : (annot_value, int32) lens = value // int32_number +let int64_number_value : (annot_value, int64) lens = value // int64_number +let nativeint_number_value : (annot_value, nativeint) lens = + value // nativeint_number +let bool_value : (annot_value, bool) lens = value // bool +let null_value : (annot_value, unit) lens = value // null + +let filter f = { + get = (fun list -> Ok (List.filter f list)); + set = (fun replace list -> filter_and_replace f replace list) +} + +open struct + exception Short_circuit + + let mapm_option f list = + let g a = + match f a with + | Ok x -> x + | Error _ -> raise_notrace Short_circuit + in + try + Ok (List.map g list) + with + | Short_circuit -> Error `Cannot_each +end + +let each l = { + get = (fun list -> mapm_option l.get list); + set = (fun replace_list list -> + let f (replace, result) v = + match replace with + | v' :: replace_rest -> + ( + match l.set v' v with + | Ok x -> replace_rest, x :: result + | Error _ -> raise_notrace Short_circuit + ) + | [] -> [], v :: result + in + try + let _, list = List.fold_left f (replace_list, []) list in + Ok (List.rev list) + with + | Short_circuit -> Error `Cannot_each + ) +} diff --git a/lib/lock_loader.ml b/lib/lock_loader.ml new file mode 100644 index 0000000..a313d55 --- /dev/null +++ b/lib/lock_loader.ml @@ -0,0 +1,404 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +(* Loads the lockfile for Nix usage broadly *) +let filename = "default.nix" + +module Features = struct + type t = int [@@deriving show] + + let empty = 0 + + (* only build features needed *) + let file = 1 lsl 0 + let archive = 1 lsl 1 + let git = 1 lsl 2 + let darcs = 1 lsl 3 + let pijul = 1 lsl 4 + + let [@inline]has mask v = (mask land v) <> 0 + let [@inline]add mask v = mask lor v + let [@inline]drop mask v = mask land (lnot v) + + let value = ref empty + + let add_input (input : Input.t) : t -> t = + match input.kind with + | `File _ -> add file + | `Archive _ -> add archive + | `Git _ -> add git + | `Darcs _ -> add darcs + | `Pijul _ -> add pijul + + let drop_input (input : Input.t) : t -> t = + match input.kind with + | `File _ -> drop file + | `Archive _ -> drop archive + | `Git _ -> drop git + | `Darcs _ -> drop darcs + | `Pijul _ -> drop pijul +end + +open Fmt + +let pp_banner (ppf : Format.formatter) = + let maker = "toastal" + and year_range = + let first = 2025 in + (* replaced by Nix *) + match int_of_string_opt "@release_year@" with + | Some last when last > first -> Fmt.str "%a–%a" Fmt.int first Fmt.int last + | _ -> Fmt.str "%a" Fmt.int first + and margin = Format.pp_get_margin ppf () + in + let hr = + (*──────────────────────────────*) + let uchar = Uchar.of_int 0x2500 + and buf = Buffer.create (margin * 3) + in + for _ = 1 to margin do + Buffer.add_utf_8_uchar buf uchar + done; + Buffer.contents buf + in + pf ppf "/*@."; + pf ppf "SPDX-FileCopyrightText: %a %a@." Fmt.string year_range Fmt.string maker; + pf ppf "SPDX-License-Identifier: ISC@."; + pf ppf "@."; + pf ppf "@[Permission@ to@ use,@ copy,@ modify,@ and/or@ distribute@ "; + pf ppf "this@ software@ for@ any@ purpose@ with@ or@ without@ fee@ is@ "; + pf ppf "hereby@ granted,@ provided@ that@ the@ above@ copyright@ notice@ &@ "; + pf ppf "this@ permission@ notice@ appear@ in@ all@ copies.@]@."; + pf ppf "@."; + pf ppf "@[THE@ SOFTWARE@ IS@ PROVIDED@ β€œAS@ IS”@ &@ ISC@ DISCLAIMS@ "; + pf ppf "ALL@ WARRANTIES@ WITH@ REGARD@ TO@ THIS@ SOFTWARE@ INCLUDING@ ALL@ "; + pf ppf "IMPLIED@ WARRANTIES@ OF@ MERCHANTABILITY@ &@ FITNESS.@ IN@ NO@ "; + pf ppf "EVENT@ SHALL@ ISC@ BE@ LIABLE@ FOR@ ANY@ SPECIAL,@ DIRECT,@ "; + pf ppf "INDIRECT,@ OR@ CONSEQUENTIAL@ DAMAGES@ OR@ ANY@ DAMAGES@ WHATSOEVER@ "; + pf ppf "RESULTING@ FROM@ LOSS@ OF@ USE,@ DATA@ OR@ PROFITS,@ WHETHER@ IN@ "; + pf ppf "AN@ ACTION@ OF@ CONTRACT,@ NEGLIGENCE@ OR@ OTHER@ TORTIOUS@ ACTION,@ "; + pf ppf "ARISING@ OUT@ OF@ OR@ IN@ CONNECTION@ WITH@ THE@ USE@ OR@ "; + pf ppf "PERFORMANCE@ OF@ THIS@ SOFTWARE.@]@."; + pf ppf "@."; + pf ppf "%a@." Fmt.string hr; + pf ppf "@[This file was generated by Nixtamal.@;"; + pf ppf "Do not edit as it will be overwritten.@]@."; + pf ppf "%a@." Fmt.string hr; + pf ppf "*/@." + +let pp_nix_named_arg (ppf : Format.formatter) ((name, default): (string * string option)) = + pf ppf "%a%a" string name (option (fun ppf v -> pf ppf " ? %s" v)) default + +let pp_nix_named_args fmt args = + let pp_args = list ~sep: (any ",@;") pp_nix_named_arg in + let break = Format.pp_print_custom_break ~fits: ("", 0, "") ~breaks: (",", 0, "") in + pf fmt "@[{@;<0 1>@[@[%a@]@]%t@]}:" pp_args args break + +let pp_cfg (ppf : Format.formatter) = + pp_nix_named_args ppf [ + ("system", Some "builtins.currentSystem"); + ("bootstrap-nixpkgs-name", Some "null"); + ] + +(* TODO: consider *not* doing manually as this is ugly AF, but would probably + involve building a Nix AST to do properly *) +let pp_body ~version (ppf : Format.formatter) () = + let feats = !Features.value in + pf ppf {|let lock = builtins.fromJSON (builtins.readFile ./lock.json); in@.|}; + pf ppf {|assert (lock.v == "%a");@.|} string version; + pf ppf {|let@.|}; + pf ppf {| try-fetch = name: fetcher:@.|}; + pf ppf {| let@.|}; + pf ppf {| try-fetch' = failed-urls: url: urls:@.|}; + pf ppf {| let result = builtins.tryEval (fetcher url); in@.|}; + pf ppf {| if result.success then@.|}; + pf ppf {| result.value@.|}; + pf ppf {| else@.|}; + pf ppf {| let failed-urls' = [ url ] ++ failed-urls; in@.|}; + pf ppf {| if builtins.length urls <= 0 then@.|}; + pf ppf {| let fus = builtins.concatStringsSep " " failed-urls'; in@.|}; + pf ppf {| builtins.throw "Input γ€Œ${name}」 fetchable @ [ ${fus} ]"@.|}; + pf ppf {| else@.|}; + pf ppf {| try-fetch' failed-urls' (builtins.head urls) (builtins.tail urls);@.|}; + pf ppf {| in@.|}; + pf ppf {| try-fetch' [ ];@.|}; + pf ppf {|@.|}; + if Features.has Features.file feats then + begin + pf ppf {| builtin-fetch-url = {name, kind, hash}:@.|}; + pf ppf {| try-fetch name (url:@.|}; + pf ppf {| builtins.fetchurl {@.|}; + pf ppf {| inherit url name;@.|}; + pf ppf {| ${hash.al} = hash.vl;@.|}; + pf ppf {| }@.|}; + pf ppf {| ) kind.ur kind.ms;@.|}; + pf ppf {|@.|}; + end; + if Features.has Features.archive feats then + begin + pf ppf {| builtin-fetch-tarball = {name, kind, hash}:@.|}; + pf ppf {| try-fetch name (url:@.|}; + pf ppf {| builtins.fetchTarball {@.|}; + pf ppf {| inherit url;@.|}; + pf ppf {| ${hash.al} = hash.vl;@.|}; + pf ppf {| }@.|}; + pf ppf {| ) kind.ur kind.ms;@.|}; + pf ppf {|@.|} + end; + if Features.has Features.git feats then + begin + pf ppf {| builtin-fetch-git = {name, kind}:@.|}; + pf ppf {| try-fetch name (url:@.|}; + pf ppf {| builtins.fetchGit {@.|}; + pf ppf {| inherit url;@.|}; + pf ppf {| rev = kind.lr;@.|}; + pf ppf {| submodules = kind.sm;@.|}; + pf ppf {| lfs = kind.lf;@.|}; + pf ppf {| shallow = true;@.|}; + pf ppf {| }@.|}; + pf ppf {| ) kind.rp kind.ms;@.|}; + pf ppf {|@.|} + end; + pf ppf {| builtin-to-input = name: input:@.|}; + pf ppf {| let k = builtins.head input.kd; in@.|}; + pf ppf {| |}; + let builtin_fetch_ifs = Dynarray.create () in + if Features.has Features.file feats then + Dynarray.add_last builtin_fetch_ifs ( + Fmt.str "@[%a@]" (list ~sep: cut string) [ + {| if k == 0 then|}; + {| builtin-fetch-url {|}; + {| inherit name;|}; + {| kind = builtins.elemAt input.kd 1;|}; + {| hash = input.ha;|}; + {| }|}; + ] + ); + if Features.has Features.archive feats then + Dynarray.add_last builtin_fetch_ifs ( + Fmt.str "@[%a@]" (list ~sep: cut string) [ + {|if k == 1 then|}; + {| builtin-fetch-tarball {|}; + {| inherit name;|}; + {| kind = builtins.elemAt input.kd 1;|}; + {| hash = input.ha;|}; + {| }|}; + ] + ); + if Features.has Features.git feats then + Dynarray.add_last builtin_fetch_ifs ( + Fmt.str "@[%a@]" (list ~sep: cut string) [ + {|if k == 2 then|}; + {| builtin-fetch-git {|}; + {| inherit name;|}; + {| kind = builtins.elemAt input.kd 1;|}; + {| }|}; + ] + ); + pf ppf "@[%a@]@." (list ~sep: (any "@;else ") string) (Dynarray.to_list builtin_fetch_ifs); + Dynarray.clear builtin_fetch_ifs; + pf ppf {| else@.|}; + pf ppf {| throw "Unsupported input kind β€œ${builtins.toString k}”.";@.|}; + pf ppf {|@.|}; + pf ppf {| nixpkgs = builtin-to-input "nixpkgs-for-nixtamal" (@.|}; + pf ppf {| if builtins.isNull bootstrap-nixpkgs-name then@.|}; + pf ppf {| lock.i.nixpkgs-nixtamal or lock.i.nixpkgs@.|}; + pf ppf {| else@.|}; + pf ppf {| lock.i.${bootstrap-nixpkgs-name}@.|}; + pf ppf {| );@.|}; + pf ppf {|@.|}; + pf ppf {| pkgs = import nixpkgs {inherit system;};@.|}; + pf ppf {|@.|}; + pf ppf {| inherit (pkgs) lib;@.|}; + pf ppf {|@.|}; + if Features.has Features.file feats then + begin + pf ppf {| fetch-url = {name, kind, hash}: pkgs.fetchurl {@.|}; + pf ppf {| inherit name;@.|}; + pf ppf {| url = kind.ur;@.|}; + pf ppf {| ${hash.al} = hash.vl;@.|}; + pf ppf {| } // lib.optionalAttrs (builtins.length kind.ms > 0) { urls = kind.ms; };@.|}; + pf ppf {|@.|} + end; + if Features.has Features.archive feats then + begin + pf ppf {| fetch-zip = {name, kind, hash}: pkgs.fetchzip {@.|}; + pf ppf {| inherit name;@.|}; + pf ppf {| url = kind.ur;@.|}; + pf ppf {| ${hash.al} = hash.vl;@.|}; + pf ppf {| } // lib.optionalAttrs (builtins.length kind.ms > 0) { urls = kind.ms; };@.|}; + pf ppf {|@.|} + end; + if Features.has Features.git feats then + begin + pf ppf {| fetch-git = {name, kind, hash}:@.|}; + pf ppf {| let@.|}; + pf ppf {| using-mirrors = kind ? ms && (builtins.length kind.ms) > 0;@.|}; + pf ppf {| mirror-support = pkgs.fetchgit.__functionArgs ? "mirrors";@.|}; + pf ppf {| in@.|}; + pf ppf {| lib.warnIf (using-mirrors && !mirror-support)@.|}; + pf ppf {| "Upstream pkgs.fetchgit doesn’t yet support mirrors for γ€Œ${name}」"@.|}; + pf ppf {| pkgs.fetchgit {@.|}; + pf ppf {| url = kind.rp;@.|}; + pf ppf {| rev = kind.lr;@.|}; + pf ppf {| fetchSubmodules = kind.sm;@.|}; + pf ppf {| fetchLFS = kind.lf;@.|}; + pf ppf {| deepClone = false;@.|}; + pf ppf {| ${hash.al} = hash.vl;@.|}; + pf ppf {| } // lib.optionalAttrs (using-mirror && mirror-support) {@.|}; + pf ppf {| mirrors = kind.ms;@.|}; + pf ppf {| };@.|}; + pf ppf {|@.|} + end; + if Features.has Features.darcs feats then + begin + pf ppf {| fetch-darcs = {name, kind, hash}:@.|}; + pf ppf {| let@.|}; + pf ppf {| using-mirrors = kind ? ms && (builtins.length kind.ms) > 0;@.|}; + pf ppf {| mirror-support = pkgs.fetchdarcs.__functionArgs ? "mirrors";@.|}; + pf ppf {| reference =@.|}; + pf ppf {| let@.|}; + pf ppf {| type = builtins.elemAt kind.rf 0;@.|}; + pf ppf {| value = builtins.elemAt kind.rf 1;@.|}; + pf ppf {| in@.|}; + pf ppf {| if type == 0 then@.|}; + pf ppf {| let path = builtins.elemAt value 1; in@.|}; + pf ppf {| assert (lib.hasSuffix ".txt" path);@.|}; + pf ppf {| let@.|}; + pf ppf {| txt-files = lib.sourceFilesBySuffices ./. [ ".txt" ];@.|}; + pf ppf {| dir = lib.fileset.toSource {@.|}; + pf ppf {| root = ./.;@.|}; + pf ppf {| fileset = lib.fileset.fromSource txt-files;@.|}; + pf ppf {| };@.|}; + pf ppf {| in@.|}; + pf ppf {| {context = "${dir}/${path}";}@.|}; + pf ppf {| else if type == 1 then@.|}; + pf ppf {| {rev = value;}@.|}; + pf ppf {| else@.|}; + pf ppf {| throw "Invalid Darcs reference";@.|}; + pf ppf {| in@.|}; + pf ppf {| lib.warnIf (using-mirrors && !mirror-support)@.|}; + pf ppf {| "Upstream pkgs.fetchdarcs doesn’t yet support mirrors for γ€Œ${name}」"@.|}; + pf ppf {| pkgs.fetchdarcs ({@.|}; + pf ppf {| url = kind.rp;@.|}; + pf ppf {| ${hash.al} = hash.vl;@.|}; + pf ppf {| } // reference // lib.optionalAttrs (using-mirrors && mirror-support){@.|}; + pf ppf {| mirrors = kind.ms;@.|}; + pf ppf {| });@.|}; + pf ppf {|@.|} + end; + if Features.has Features.pijul feats then + begin + pf ppf {| fetch-pijul = {name, kind, hash}:@.|}; + pf ppf {| let@.|}; + pf ppf {| using-mirrors = kind ? ms && (builtins.length kind.ms) > 0;@.|}; + pf ppf {| mirror-support = pkgs.fetchpijul.__functionArgs ? "mirrors";@.|}; + pf ppf {| in@.|}; + pf ppf {| lib.warnIf (using-mirrors && !mirror-support)@.|}; + pf ppf {| "Upstream pkgs.fetchpijul doesn’t yet support mirrors for γ€Œ${name}」"@.|}; + pf ppf {| pkgs.fetchpijul {@.|}; + pf ppf {| url = kind.rm;@.|}; + pf ppf