path: root/lib/input.ml

(*─────────────────────────────────────────────────────────────────────────────┐
│ 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 UTF8.t
	[@@unboxed]
	[@@deriving show, eq, qcheck]

	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 cmd = {
			prog: Template.t;
			args: Template.t list;
		}
		[@@deriving show, eq, make, qcheck]

		type t = cmd Util.Non_empty_list.t
		[@@deriving show, eq, qcheck]

		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: UTF8.t option;
	}
	[@@deriving show, eq, make, qcheck]
end

(* KINDS **********************************************************************)

module File = struct
	type t = {
		url: Template.t;
		mirrors: Template.t list;
	}
	[@@deriving show, eq, make, qcheck]
end

module Archive = struct
	type t = {
		url: Template.t;
		mirrors: Template.t list;
	}
	[@@deriving show, eq, make, qcheck]
end

module Git = struct
	module Reference = struct
		type t = [
			| `Branch of UTF8.t
			| `Ref of UTF8.t
		]
		[@@deriving show, eq, qcheck]
	end

	type t = {
		repository: Template.t;
		mirrors: Template.t list;
		reference: Reference.t;
		datetime: UTF8.t option; (* ISO 8601 RFC 3339 *)
		submodules: bool; [@default false]
		lfs: bool; [@default false]
		latest_revision: UTF8.t option;
	}
	[@@deriving show, eq, make, qcheck]

	let default_latest_cmd git : Latest.Cmd.t =
		let open Latest.Cmd in
		let t = Template.make in
		let git_ls_remote (ls_remote_args : Template.t list) : t =
			let args = t "ls-remote" :: git.repository :: ls_remote_args in
			~${prog = t "git"; args}
			|: {prog = t "cut"; args = [t "-f1"]}
		in
		match git.reference with
		| `Branch b -> git_ls_remote [t "--branches"; t b]
		| `Ref r -> git_ls_remote [t "--refs"; t r]
end

module Darcs = struct
	module Reference = struct
		type context_grounds = [
			| `Assumed of UTF8.t option
			| `Stated of UTF8.t
		]
		[@@deriving show, eq, qcheck]

		type t = [
			| `Context of context_grounds
			| `Tag of UTF8.t
		]
		[@@deriving show, eq, qcheck]
	end

	type t = {
		repository: Template.t;
		mirrors: Template.t list;
		reference: Reference.t;
		datetime: UTF8.t option; (* ISO 8601 RFC 3339 *)
		latest_weak_hash: UTF8.t option;
	}
	[@@deriving show, eq, make, qcheck]
end

module Pijul = struct
	module Reference = struct
		type t = [
			| `Channel of UTF8.t
			| `State of UTF8.t
			| `Change of UTF8.t
		]
		[@@deriving show, eq, qcheck]
	end

	type t = {
		remote: Template.t;
		mirrors: Template.t list;
		reference: Reference.t;
		datetime: UTF8.t option; (* ISO 8601 RFC 3339 *)
		latest_state: UTF8.t option;
	}
	[@@deriving show, eq, make, qcheck]
end

(* Nilla is a Nix framework similar to flakes but with loaders and module system.
	See: https://github.com/nilla-nix/nilla *)
module Nilla = struct
	let default_path = Template.make "./nilla.nix"

	module Reference = struct
		type t = [
			| `Branch of UTF8.t
			| `Ref of UTF8.t
		]
		[@@deriving show, eq, qcheck]
	end

	type t = {
		repository: Template.t;
		mirrors: Template.t list;
		reference: Reference.t;
		datetime: UTF8.t option; (* ISO 8601 RFC 3339 *)
		latest_revision: UTF8.t option;
		path: Template.t; (* path to nilla.nix, default: ./nilla.nix *)
			[@default default_path]
	}
	[@@deriving show, eq, make, qcheck]

	let default_latest_cmd nilla : Latest.Cmd.t =
		let open Latest.Cmd in
		let t = Template.make in
		let git_ls_remote (ls_remote_args : Template.t list) : t =
			let args = t "ls-remote" :: nilla.repository :: ls_remote_args in
			~${prog = t "git"; args}
			|: {prog = t "cut"; args = [t "-f1"]}
		in
		match nilla.reference with
		| `Branch b -> git_ls_remote [t "--heads"; t b]
		| `Ref r -> git_ls_remote [t "--refs"; t r]
end

module Fossil = struct
	module Reference = struct
		type t = [
			| `Branch of UTF8.t
			| `Tag of UTF8.t
			| `Checkin of UTF8.t
		]
		[@@deriving show, eq, qcheck]
	end

	type t = {
		repository: Template.t;
		reference: Reference.t;
		date: UTF8.t option;
		latest_checkin: UTF8.t option;
	}
	[@@deriving show, eq, make, qcheck]
end

module Hash = struct
	type algorithm =
		| SHA256
		| SHA512
		| BLAKE3
	[@@deriving enum, eq, ord, show, qcheck]

	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: UTF8.t option;
		(* used to assert in fetching for manually-updated pins *)
		expected: UTF8.t option;
	}
	[@@deriving show, eq, make, qcheck]
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
		| `Nilla of Nilla.t
		| `Fossil of Fossil.t
	]
	[@@deriving show, eq, qcheck]
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 ())

let make_kind_nilla ~repository ?mirrors ~reference ?latest_revision ?path () =
	`Nilla (Nilla.make ?mirrors ~repository ~reference ?latest_revision ?path ())

let make_kind_fossil ~repository ~reference ?date ?latest_checkin () =
	`Fossil (Fossil.make ~repository ~reference ?date ?latest_checkin ())

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, eq, make, qcheck]

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)
			| `Nilla n -> Some (Nilla.default_latest_cmd n)
			(* Would be nice if other tools did a better job letting you query the
			remote repository directly, but that isn't where we