From 3df27ffb2bd40f3eaeed6dfb08ef3041cc60bfe0 Mon Sep 17 00:00:00 2001 From: ·𐑑𐑴𐑕𐑑𐑩𐑀 Date: Wed, 10 Dec 2025 13:00:26 +0000 Subject: ocaml onset --- bin/cmd.ml | 331 ++++++++++++++++++++++ bin/dune | 17 ++ bin/main.ml | 36 +++ dune-project | 23 ++ dune-workspace | 5 + 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 +++++ nix/package/nixtamal.nix | 17 +- nixtamal.opam | 38 +++ release.nix | 7 +- test/dune | 6 + test/test_main.ml | 8 + test/test_nixtamal.ml | 8 + test/test_source.ml | 4 + 26 files changed, 4306 insertions(+), 2 deletions(-) create mode 100644 bin/cmd.ml create mode 100644 bin/dune create mode 100644 bin/main.ml create mode 100644 dune-project create mode 100644 dune-workspace 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 create mode 100644 nixtamal.opam create mode 100644 test/dune create mode 100644 test/test_main.ml create mode 100644 test/test_nixtamal.ml create mode 100644 test/test_source.ml diff --git a/bin/cmd.ml b/bin/cmd.ml new file mode 100644 index 0000000..72438d4 --- /dev/null +++ b/bin/cmd.ml @@ -0,0 +1,331 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: GPL-3.0-or-later β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +let prefixed_env_info ?doc ?deprecated var = + Cmdliner.Cmd.Env.info ("NIXTAMAL_" ^ var) ?doc ?deprecated + +let common_man = [ + `S "BUGS"; + `P "During alpha, contact the maker directly or join the XMPP MUC."; +] + +module Global = struct + type t = { + style_renderer: Fmt.style_renderer option; + level: Logs.level option; + dir: string option; + jobs: int; + } + + let directory_arg = + let open Cmdliner in + let env = prefixed_env_info ~doc: "Directory for Nixtamal" "DIRECTORY" in + Arg.( + value + & opt (some string) None + & info + ["directory"] + ~env + ~doc: "Working directory for Nixtamal-related files (default: $PWD/nix/tamal)" + ~docv: "PATH" + ) + + let jobs_arg = + let open Cmdliner in + let domain_count : int = Stdlib.Domain.recommended_domain_count () in + Arg.( + value + & opt int domain_count + & info + ["j"; "jobs"] + ~env: (prefixed_env_info "JOBS") + ~doc: "Nixtamal’s executor pool domain size." + ~docv: "INT" + ) + + let args = + let open Cmdliner in + let open Term in + ret + ( + const (fun style_renderer level dir jobs -> + `Ok {style_renderer; level; dir; jobs} + ) + $ Fmt_cli.style_renderer ~env: (prefixed_env_info "OUTPUT_COLOR") () + $ Logs_cli.level ~env: (prefixed_env_info "LOG_LEVEL") () + $ directory_arg + $ jobs_arg + ) + + let run ~env {style_renderer; level; dir; jobs} = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level ( + match level with + | None -> Some Logs.Info + | Some lvl -> Some lvl + ); + Logs.set_reporter (Logs_fmt.reporter ()); + Kdl.indent := 1; + let () = + match dir with + | None -> + Nixtamal.Working_directory.set_default ~env () + | Some d -> + let cwd = Eio.Stdenv.cwd env in + let directory = Eio.Path.(cwd / d) in + Nixtamal.Working_directory.set ~directory + in + fun f -> f ~env ~domain_count: jobs +end + +module Set_up = struct + let nixpkgs_mismatch = "Both --nixpkgs-branch & --nixpkgs-ref cannot be used at the same time" + + let info = + Cmdliner.Cmd.info + "set-up" + ~doc: "Set up working directory for Nixtamal. By default, also adds Nixpkgs from upstream to the project’s inputs." + ~man: common_man + + let run ~env ~domain_count: _ nixpkgs : unit = + match Nixtamal.set_up ~env ?nixpkgs () with + | Ok() -> () + | Error err -> failwith (Fmt.str "%a" Nixtamal.Error.pp_error err) + + let term ~env = + let open Cmdliner in + let no_nixpkgs_arg = + Arg.( + value + & flag + & info + ["no-nixpkgs"] + ~env: (prefixed_env_info "NO_NIXPKGS") + ~doc: "Do not add Nixpkgs to the pinned inputs list by default." + ) + and use_nixpkgs_git_mirrors_arg = + Arg.( + value + & flag + & info + ["use-nixpkgs-git-mirrors"] + ~env: (prefixed_env_info "USE_NIXPKGS_GIT_MIRRORS") + ~doc: "For resiliance, add known Nixpkgs git mirrors to fallback on when the Nixpkgs’s Microsoft GitHub host inevitably goes down again. Off by default as the Git updating is slightly slower & some users might object to TUNA’s hosting origin state." + ) + and nixpkgs_branch_arg = + Arg.( + value + & opt (some string) None + & info + ["nixpkgs-branch"] + ~env: (prefixed_env_info "NIXPKGS_BRANCH") + ~doc: (Fmt.str "Nixpkgs Git branch for Nixtamal setup (shorthand for refs/branches/*). %s." nixpkgs_mismatch) + ~docv: "BRANCH_NAME" + ) + and nixpkgs_ref_arg = + Arg.( + value + & opt (some string) None + & info + ["nixpkgs-ref"] + ~env: (prefixed_env_info "NIXPKGS_REF") + ~doc: (Fmt.str "Nixpkgs Git ref for Nixtamal setup (default: %s). %s." Nixtamal.Input.Nixpkgs.default_ref nixpkgs_mismatch) + ~docv: "REF" + ) + in + let nixpkgs_reference_arg = + let open Term in + let mk_reference nixpkgs_branch nixpkgs_ref = + match nixpkgs_branch, nixpkgs_ref with + | None, None -> `Ok None + | Some branch, None -> `Ok (Some (`Branch branch)) + | None, Some ref -> `Ok (Some (`Ref ref)) + | Some _, Some _ -> `Error (true, nixpkgs_mismatch) + in + ret + ( + const mk_reference + $ nixpkgs_branch_arg + $ nixpkgs_ref_arg + ) + and nixpkgs_revision_arg = + Arg.( + value + & opt (some string) None + & info + ["nixpkgs-revision"] + ~env: (prefixed_env_info "NIXPKGS_REVISION") + ~doc: ("Nixpkgs Git revision for Nixtamal setup. The value will be used as the latest revision/change.") + ~docv: "REVISION" + ) + in + let nixpkgs_arg = + let open Term in + let open Nixtamal.Input in + let mk_arg no_nixpkgs use_nixpkgs_git_mirrors (reference : Git.Reference.t option) nixpkgs_revision = + if no_nixpkgs then + `Ok None + else if use_nixpkgs_git_mirrors then + let latest_revision = nixpkgs_revision in + let input = Nixpkgs.make_git_with_known_mirrors ?reference ?latest_revision () in + `Ok (Some input) + else + let latest_value = nixpkgs_revision in + let input = Nixpkgs.make_archive ?reference ?latest_value () in + `Ok (Some input) + in + ret + ( + const mk_arg + $ no_nixpkgs_arg + $ use_nixpkgs_git_mirrors_arg + $ nixpkgs_reference_arg + $ nixpkgs_revision_arg + ) + in + Term.( + const (fun glb -> Global.run ~env glb @@ run) + $ Global.args + $ nixpkgs_arg + ) + + let cmd ~env = Cmdliner.Cmd.v info (term ~env) +end + +module Check_soundness = struct + let info = + Cmdliner.Cmd.info + "check-soundness" + ~doc: "Checks that the manifest Γ— lockfile is sound." + ~man: common_man + + let run ~env ~domain_count: _ : unit = + match Nixtamal.check_soundness ~env () with + | Ok() -> () + (* TODO: use these errors for error codes *) + | Error err -> failwith (Fmt.str "%a" Nixtamal.Error.pp_error err) + + let term ~env = + let open Cmdliner in + Term.( + const (fun glb -> Global.run ~env glb @@ run) + $ Global.args + ) + + let cmd ~env = Cmdliner.Cmd.v info (term ~env) +end + +module Tweak = struct + let info = + Cmdliner.Cmd.info + "tweak" + ~doc: "Tweak the manifest file with \\$VISUAL, \\$EDITOR, or vi" + ~man: common_man + + let run ~env ~domain_count: _ : unit = + match Nixtamal.tweak ~env () with + | Ok() -> () + (* TODO: use these errors for error codes *) + | Error err -> failwith (Fmt.str "%a" Nixtamal.Error.pp_error err) + + let term ~env = + let open Cmdliner in + Term.( + const (fun glb -> Global.run ~env glb @@ run) + $ Global.args + ) + + let cmd ~env = Cmdliner.Cmd.v info (term ~env) +end + +module Show = struct + let info = + Cmdliner.Cmd.info + "show" + ~doc: "Shows current inputs as understood by Nixtamal for earthlings." + ~man: common_man + + let run ~env ~domain_count: _ : unit = + match Nixtamal.show ~env () with + | Ok() -> () + | Error err -> failwith (Fmt.str "%a" Nixtamal.Error.pp_error err) + + let term ~env = + let open Cmdliner in + Term.( + const (fun glb -> Global.run ~env glb @@ run) + $ Global.args + ) + + let cmd ~env = Cmdliner.Cmd.v info (term ~env) +end + +module Lock = struct + let info = + Cmdliner.Cmd.info + "lock" + ~doc: "Lock all not-yet-locked inputs." + ~man: common_man + + let run ~env ~domain_count force names : unit = + let names = List.map Nixtamal.Name.Name.make names in + match Nixtamal.lock ~env ~domain_count ~force ~names () with + | Ok() -> () + | Error err -> failwith (Fmt.str "%a" Nixtamal.Error.pp_error err) + + let term ~env = + let open Cmdliner in + let force_arg = + Arg.( + value + & flag + & info ["f"; "force"] ~doc: "Force input to lock (useful if changing the manifest in a manner that otherwise wouldn’t trigger a lock)." + ) + and names_arg = + Arg.( + value + & pos_all string [] + & info [] ~docv: "INPUT_NAME" ~doc: "Input names to lock (if already locked, will skip)." + ) + in + Term.( + const (fun glb force -> Global.run ~env glb @@ run force) + $ Global.args + $ force_arg + $ names_arg + ) + + let cmd ~env = Cmdliner.Cmd.v info (term ~env) +end + +module Refresh = struct + let info = + Cmdliner.Cmd.info + "refresh" + ~doc: "Refreshes all non-frozen inputs using the latest-cmdβ€Šβ€”β€Šor the default latest-cmd for certain kinds with a reasonable default (Git)." + ~man: common_man + + let run ~env ~domain_count names : unit = + let names = List.map Nixtamal.Name.Name.make names in + match Nixtamal.refresh ~env ~domain_count ~names () with + | Ok() -> () + | Error err -> failwith (Fmt.str "%a" Nixtamal.Error.pp_error err) + + let term ~env = + let open Cmdliner in + let names_arg = + Arg.( + value + & pos_all string [] + & info [] ~docv: "INPUT_NAME" ~doc: "Input names to refresh." + ) + in + Term.( + const (fun glb -> Global.run ~env glb @@ run) + $ Global.args + $ names_arg + ) + + let cmd ~env = Cmdliner.Cmd.v info (term ~env) +end diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..3dc72b3 --- /dev/null +++ b/bin/dune @@ -0,0 +1,17 @@ +(executable + (public_name nixtamal) + (name main) + (libraries + nixtamal + cmdliner + eio + eio_main + fmt + fmt.cli + fmt.tty + logs + logs.cli + logs.fmt + uri) + (preprocess + (pps ppx_deriving.show ppx_deriving.eq ppx_deriving.ord ppx_deriving.make))) diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..618b9db --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,36 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +β”‚ SPDX-FileCopyrightText: 2025 toastal β”‚ +β”‚ SPDX-License-Identifier: GPL-3.0-or-later β”‚ +└─────────────────────────────────────────────────────────────────────────────*) +let info = + let top_level_man = [ + `S "LICENSE"; + `P "GNU General Public License, version 3.0 later (GPL-3.0-or-later)"; + `S "MAKER"; + `P "toastal "; + `S "FUNDING"; + `P "See: https://toast.al/funding/"; + ] + in + Cmdliner.Cmd.info + "nixtamal" + ~version: "@version@" + ~doc: "fulfilling input pinning for Nix" + ~man: (top_level_man @ Cmd.common_man) + +let cmd ~env = + let subcommands = [ + Cmd.Set_up.cmd ~env; + Cmd.Check_soundness.cmd ~env; + Cmd.Tweak.cmd ~env; + Cmd.Show.cmd ~env; + Cmd.Lock.cmd ~env; + Cmd.Refresh.cmd ~env; + ] + in + Cmdliner.Cmd.group info subcommands + +let () = + Eio_main.run @@ fun env -> + (* if !Sys.interactive then () else *) + exit @@ Cmdliner.Cmd.eval (cmd ~env) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..de7d7f5 --- /dev/null +++ b/dune-project @@ -0,0 +1,23 @@ +(lang dune 3.20) + +(name nixtamal) + +(generate_opam_files true) + +(source + (uri "https://darcs.toastal.in.th/nixtamal/trunk")) + +(authors "toastal ") + +(maintainers "toastal ") + +(license GPL-3.0-or-later) + +(package + (name nixtamal) + (synopsis "Fulfilling Nix version pinning") + (description "TODO") + (depends aloctest cmdliner eio eio_main fmt jingoo jsont kdl logs uri) + (tags ("nix"))) + +; See the complete stanza docs at https://dune.readthedocs.io/en/stable/reference/dune-project/index.html diff --git a/dune-workspace b/dune-workspace new file mode 100644 index 0000000..1e3d1c8 --- /dev/null +++ b/dune-workspace @@ -0,0 +1,5 @@ +(lang dune 3.20) + +(env + (dev + (flags :standard -warn-error -27-32))) 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 =