path: root/lib/lock_loader.ml

(*─────────────────────────────────────────────────────────────────────────────┐
│ SPDX-FileCopyrightText: 2025–2026 toastal <https://toast.al/contact/>        │
│ 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 "@[<hov>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 "@[<hov>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 "┏┓╻+╻ ╱┏┳┓┏┓┏┳┓┏┓╻@.";
	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 "@[<hv>{@;<0 1>@[@[<hv>%a@]@]%t@]}:" pp_args args break

let pp_cfg (ppf : Format.formatter) =
	pp_nix_named_args ppf [
		("system", Some "builtins.currentSystem");
		("nixpkgs", Some "null");
		("bootstrap-nixpkgs-lock-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 {|						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 "@[<v 1>%a@]" (list ~sep: (any "@.") 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 "@[<v 1>%a@]" (list ~sep: (any "@.") 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 "@[<v 1>%a@]" (list ~sep: (any "@.") 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' = if builtins.isNull nixpkgs then@.|};
	pf ppf {|		builtin-to-input "nixpkgs-for-nixtamal" (@.|};
	pf ppf {|			if builtins.isString bootstrap-nixpkgs-lock-name then@.|};
	pf ppf {|				lock.i.${bootstrap-nixpkgs-lock-name}@.|};
	pf ppf {|			else@.|};
	pf ppf {|				lock.i.nixpkgs-nixtamal or lock.i.nixpkgs@.|};
	pf ppf {|		)@.|};
	pf ppf {|	else@.|};
	pf ppf {|		nixpkgs;@.|};
	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}