diff options
| -rw-r--r-- | bin/cmd.ml | 331 | ||||
| -rw-r--r-- | bin/dune | 17 | ||||
| -rw-r--r-- | bin/main.ml | 36 | ||||
| -rw-r--r-- | dune-project | 23 | ||||
| -rw-r--r-- | dune-workspace | 5 | ||||
| -rw-r--r-- | lib/dune | 11 | ||||
| -rw-r--r-- | lib/editor.ml | 19 | ||||
| -rw-r--r-- | lib/error.ml | 77 | ||||
| -rw-r--r-- | lib/input.ml | 362 | ||||
| -rw-r--r-- | lib/input_foreman.ml | 722 | ||||
| -rw-r--r-- | lib/kdl_lens_result.ml | 390 | ||||
| -rw-r--r-- | lib/lock_loader.ml | 404 | ||||
| -rw-r--r-- | lib/lockfile.ml | 474 | ||||
| -rw-r--r-- | lib/manifest.ml | 718 | ||||
| -rw-r--r-- | lib/name.ml | 73 | ||||
| -rw-r--r-- | lib/nixtamal.ml | 190 | ||||
| -rw-r--r-- | lib/prefetch.ml | 96 | ||||
| -rw-r--r-- | lib/util.ml | 196 | ||||
| -rw-r--r-- | lib/working_directory.ml | 76 | ||||
| -rw-r--r-- | nix/package/nixtamal.nix | 17 | ||||
| -rw-r--r-- | nixtamal.opam | 38 | ||||
| -rw-r--r-- | release.nix | 7 | ||||
| -rw-r--r-- | test/dune | 6 | ||||
| -rw-r--r-- | test/test_main.ml | 8 | ||||
| -rw-r--r-- | test/test_nixtamal.ml | 8 | ||||
| -rw-r--r-- | test/test_source.ml | 4 |
26 files changed, 4306 insertions, 2 deletions
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 <https://toast.al/contact/> │ +│ 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 <https://toast.al/contact/> │ +│ 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 <https://toast.al/contact/>"; + `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 <toastal@posteo.net>") + +(maintainers "toastal <toastal@posteo.net>") + +(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 <https://toast.al/contact/> │ +│ 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 <https://toast.al/contact/> │ +│ 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 <https://toast.al/contact/> │ +│ 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 <https://toast.al/contact/> │ +│ 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 |