path: root/lib/lockfile.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 error = Error.lockfile_error

let filename = "lock.json"

let encode_tag = Util.Jsont.encode_tag

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

	let [@inline]to_lock
			~(models : Input.jg_models2)
			({url; mirrors; _}: Input.File.t)
			: t
		=
		let to_uri = Fun.compose URI.of_string (Input.Template.fill ~models) in
		{
			url = to_uri url;
			mirrors = List.map to_uri mirrors;
		}

	let jsont : t Jsont.t =
		let open Jsont in
		Object.map
			~kind: "File_lock"
			(fun url mirrors -> {url; mirrors})
		|> Object.mem "ur" URI.jsont ~enc: (fun i -> i.url)
		|> Object.mem "ms" (list URI.jsont) ~enc: (fun i -> i.mirrors)
		|> Object.finish
end

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

	let [@inline]to_lock ~(models : Input.jg_models2) ({url; mirrors; _}: Input.Archive.t) : t =
		let to_uri = Fun.compose URI.of_string (Input.Template.fill ~models) in
		{
			url = to_uri url;
			mirrors = List.map to_uri mirrors;
		}

	let jsont : t Jsont.t =
		let open Jsont in
		Object.map
			~kind: "Archive_lock"
			(fun url mirrors -> {url; mirrors})
		|> Object.mem "ur" URI.jsont ~enc: (fun i -> i.url)
		|> Object.mem "ms" (list URI.jsont) ~enc: (fun i -> i.mirrors)
		|> Object.finish
end

module Git = struct
	(*
	module Reference = struct
		type t = Input.Git.Reference.t
		[@@deriving show]

		let jsont : t Jsont.t =
			let open Jsont in
			let enc = function
				| `Branch brc -> encode_tag 0 string brc
				| `Ref ref -> encode_tag 1 string ref
			and dec = function
				| [|tag; value|] ->
					begin
						match Result.bind (Json.decode' uint8 tag) (function
							| 0 -> Json.decode' string value |> Result.map (fun t -> `Branch t)
							| 1 -> Json.decode' string value |> Result.map (fun c -> `Ref c)
							| n -> Error.msgf Meta.none "Unknown reference enum tag: %d" n
						) with
						| Ok v -> v
						| Error (ctx, meta, kind) -> Error.raise ctx meta kind
					end
				| _ ->
					Error.msgf Meta.none "Expected array of length 2"
			in
			map ~kind: "Git_reference_lock" ~enc ~dec (array json)
	end
	*)

	type t = {
		repository: URI.t;
		mirrors: URI.t list;
		(*reference: Reference.t;*)
		datetime: string option;
		submodules: bool;
		lfs: bool;
		latest_revision: string option;
	}
	[@@deriving show, eq, qcheck]

	let [@inline]to_lock
			~(models : Input.jg_models2)
			({repository; mirrors; (*reference;*) datetime; submodules; lfs; latest_revision; _}: Input.Git.t)
			: t
		=
		let to_uri = Fun.compose URI.of_string (Input.Template.fill ~models) in
		{
			repository = to_uri repository;
			mirrors = List.map to_uri mirrors;
			(*reference;*)
			datetime;
			submodules;
			lfs;
			latest_revision;
		}

	let jsont : t Jsont.t =
		let open Jsont in
		Object.map
			~kind: "Git_lock"
			(fun repository mirrors (*reference*) datetime submodules lfs latest_revision ->
				{repository; mirrors; (*reference;*) datetime; submodules; lfs; latest_revision}
			)
		|> Object.mem "rp" URI.jsont ~enc: (fun i -> i.repository)
		|> Object.mem "ms" (list URI.jsont) ~enc: (fun i -> i.mirrors)
		(*|> Object.mem "rf" Reference.jsont ~enc: (fun i -> i.reference)*)
		|> Object.mem "dt" (option string) ~enc: (fun i -> i.datetime)
		|> Object.mem "sm" bool ~enc: (fun i -> i.submodules)
		|> Object.mem "lf" bool ~enc: (fun i -> i.lfs)
		|> Object.mem "lr" (option string) ~enc: (fun i -> i.latest_revision)
		|> Object.finish
end

module Darcs = struct
	module Reference = struct
		type t = Input.Darcs.Reference.t
		[@@deriving show, eq, qcheck]

		let jsont : t Jsont.t =
			let open Jsont in
			let context_jsont =
				let enc = function
					| `Assumed (Some actx) -> encode_tag 0 string actx
					| `Stated sctx -> encode_tag 1 string sctx
					(* We can’t lock without a stable reference *)
					| `Assumed None ->
						Error.msgf Meta.none "Darcs context cannot be None when locking"
				and dec = function
					| [|tag; value|] ->
						begin
							match Result.bind (Json.decode' uint8 tag) (function
								| 0 -> Json.decode' string value |> Result.map (fun a -> `Assumed (Some a))
								| 1 -> Json.decode' string value |> Result.map (fun s -> `Stated s)
								| n -> Error.msgf Meta.none "Unknown context enum tag: %d" n
							) with
							| Ok v -> v
							| Error (ctx, meta, kind) -> Error.raise ctx meta kind
						end
					| _ ->
						Error.msgf Meta.none "Expected array of length 2"
				in
				map ~kind: "Darcs_reference_context_lock" ~enc ~dec (array json)
			in
			let enc = function
				| `Context ctx -> encode_tag 0 context_jsont ctx
				| `Tag tag -> encode_tag 1 string tag
			and dec = function
				| [|tag; value|] ->
					begin
						match Result.bind (Json.decode' uint8 tag) (function
							| 0 -> Json.decode' context_jsont value |> Result.map (fun c -> `Context c)
							| 1 -> Json.decode' string value |> Result.map (fun t -> `Tag t)
							| n -> Error.msgf Meta.none "Unknown reference enum tag: %d" n
						) with
						| Ok v -> v
						| Error (ctx, meta, kind) -> Error.raise ctx meta kind
					end
				| _ ->
					Error.msgf Meta.none "Expected array of length 2"
			in
			map ~kind: "Darcs_reference_lock" ~enc ~dec (array json)
	end

	type t = {
		repository: URI.t;
		mirrors: URI.t list;
		datetime: string option;
		(* Darcs isn’t like the other girls; we don’t have a simple stable reference point.
			Either the tag or context can be used. *)
		reference: Reference.t;
		latest_weak_hash: string option;
	}
	[@@deriving show, eq, qcheck]

	let [@inline]to_lock
			~(models : Input.jg_models2)
			({repository; mirrors; datetime; reference; latest_weak_hash; _}: Input.Darcs.t)
			: t
		=
		let to_uri = Fun.compose URI.of_string (Input.Template.fill ~models) in
		{
			repository = to_uri repository;
			mirrors = List.map to_uri mirrors;
			datetime;
			reference;
			latest_weak_hash;
		}

	let jsont : t Jsont.t =
		let open Jsont in
		Object.map
			~kind: "Darcs_lock"
			(fun repository mirrors datetime reference latest_weak_hash ->
				{repository; mirrors; datetime; reference; latest_weak_hash}
			)
		|> Object.mem "rp" URI.jsont ~enc: (fun i -> i.repository)
		|> Object.mem "ms" (list URI.jsont) ~enc: (fun i -> i.mirrors)
		|> Object.mem "dt" (option string) ~enc: (fun i -> i.datetime)
		|> Object.mem "rf" Reference.jsont ~enc: (fun i -> i.reference)
		|> Object.mem "lw" (option string) ~enc: (fun i -> i.latest_weak_hash)
		|> Object.finish
end

module Pijul = struct
	(*
	module Reference = struct
		type t = Input.Pijul.Reference.t
		[@@deriving show]

		let jsont : t Jsont.t =
			let open Jsont in
			let enc = function
				| `Channel chn -> encode_tag 0 string chn
				| `State stt -> encode_tag 1 string stt
				| `Change chg -> encode_tag 2 string chg
			and dec = function
				| [|tag; value|] ->
					begin
						match Result.bind (Json.decode' uint8 tag) (function
							| 0 -> Json.decode' string value |> Result.map (fun c -> `Channel c)
							| 1 -> Json.decode' string value |> Result.map (fun c -> `State c)
							| 2 -> Json.decode' string value |> Result.map (fun t -> `Change t)
							| n -> Error.msgf Meta.none "Unknown reference enum tag: %d" n
						) with
						| Ok v -> v
						| Error (ctx, meta, kind) -> Error.raise ctx meta kind
					end
				| _ ->
					Error.msgf Meta.none "Expected array of length 2"
			in
			map ~kind: "Pijul_reference_lock" ~enc ~dec (array json)
	end
	*)

	type t = {
		remote: URI.t;
		mirrors: URI.t list;
		datetime: string option;
		(*reference: Reference.t;*)
		latest_state: string option;
	}
	[@@deriving show, eq, qcheck]

	let [@inline]to_lock
			~(models : Input.jg_models2)
			({remote; mirrors; datetime; latest_state; _}: Input.Pijul.t)
			: t
		=
		let to_uri = Fun.compose URI.of_string (Input.Template