diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/dune | 2 | ||||
| -rw-r--r-- | lib/error.ml | 10 | ||||
| -rw-r--r-- | lib/input.ml | 97 | ||||
| -rw-r--r-- | lib/input_foreman.ml | 44 | ||||
| -rw-r--r-- | lib/lock_loader.ml | 6 | ||||
| -rw-r--r-- | lib/lockfile.ml | 83 | ||||
| -rw-r--r-- | lib/manifest.ml | 173 | ||||
| -rw-r--r-- | lib/nixtamal.ml | 161 | ||||
| -rw-r--r-- | lib/prefetch.ml | 119 | ||||
| -rw-r--r-- | lib/schema.ml | 31 |
10 files changed, 714 insertions, 12 deletions
@@ -10,8 +10,10 @@ jsont.bytesrw kdl logs + str saturn uri) + (flags (:standard -alert -deprecated)) (preprocess (pps ppx_deriving.enum diff --git a/lib/error.ml b/lib/error.ml index da9a271..ba92eac 100644 --- a/lib/error.ml +++ b/lib/error.ml @@ -25,6 +25,8 @@ type prefetch_method = [ | `Git | `Darcs | `Pijul + | `Nilla + | `Fossil ] [@@deriving show] @@ -34,6 +36,7 @@ type prefetch_error = [ | `JSON_parsing of prefetch_method * string | `Darcs_context of string | `Run_exception of prefetch_method * exn * string + | `Not_implemented of prefetch_method * string ] [@@deriving show] @@ -55,6 +58,7 @@ type error = [ | `Manifest of manifest_error | `Lockfile of lockfile_error | `Version_mismatch of string * string + | `Upgrade of string | `Input_foreman of input_foreman_error ] [@@deriving show] @@ -75,5 +79,7 @@ let pp ppf = function 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 + | `Upgrade msg -> + Fmt.pf ppf "Upgrade error: %s" msg + | `Input_foreman err -> + Fmt.(pf ppf "%a" pp_input_foreman_error err) diff --git a/lib/input.ml b/lib/input.ml index f2fb1a7..00ee2c9 100644 --- a/lib/input.ml +++ b/lib/input.ml @@ -137,6 +137,62 @@ module Pijul = struct [@@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 @@ -181,6 +237,8 @@ module Kind = struct | `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 @@ -200,6 +258,12 @@ let make_kind_pijul ~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; @@ -217,8 +281,9 @@ let latest_cmd (input : t) : Latest.Cmd.t option = ( 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 are *) + remote repository directly, but that isn't where we are *) | _ -> None ) | Some cmd -> Some cmd @@ -289,6 +354,36 @@ let jg_models2 (input : t) (needle : string) : Jingoo.Jg_types.tvalue = Option.iter (fun s -> Hashtbl.add htbl "state" (Tstr s)) p.latest_state; htbl end + | `Nilla n -> + begin + let htbl = make_hashtbl 4 in + ( + match n.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)) n.datetime; + Hashtbl.add htbl "path" (Tstr (Template.take n.path)); + Option.iter + (fun r -> + List.iter (fun key -> Hashtbl.add htbl key (Tstr r)) ["rev"; "revision"] + ) + n.latest_revision; + htbl + end + | `Fossil f -> + begin + let htbl = make_hashtbl 3 in + ( + match f.reference with + | `Branch b -> Hashtbl.add htbl "branch" (Tstr b) + | `Tag t -> Hashtbl.add htbl "tag" (Tstr t) + | `Checkin c -> Hashtbl.add htbl "checkin" (Tstr c) + ); + Option.iter (fun d -> Hashtbl.add htbl "datetime" (Tstr d)) f.date; + Option.iter (fun c -> Hashtbl.add htbl "latest_checkin" (Tstr c)) f.latest_checkin; + htbl + end in match Hashtbl.find_opt hashtbl needle with | Some value -> value diff --git a/lib/input_foreman.ml b/lib/input_foreman.ml index dec3f32..9fefa5f 100644 --- a/lib/input_foreman.ml +++ b/lib/input_foreman.ml @@ -102,6 +102,33 @@ let pp_for_earthlings pff = Option.fold ~none: [] ~some: (fun d -> ["datetime", d]) p.datetime; Option.fold ~none: [] ~some: (fun s -> ["latest-state", s]) p.latest_state; ] + | `Nilla n -> + "nilla", + List.concat [ + ["repository", fill n.repository]; + (List.map (fun m -> "mirror", fill m) n.mirrors); + ( + match n.reference with + | `Branch b -> ["branch", b] + | `Ref r -> ["ref", r] + ); + ["path", fill n.path]; + Option.fold ~none: [] ~some: (fun d -> ["datetime", d]) n.datetime; + Option.fold ~none: [] ~some: (fun r -> ["latest-revision", r]) n.latest_revision; + ] + | `Fossil f -> + "fossil", + List.concat [ + ["repository", fill f.repository]; + ( + match f.reference with + | `Branch b -> ["branch", b] + | `Tag t -> ["tag", t] + | `Checkin c -> ["checkin", c] + ); + Option.fold ~none: [] ~some: (fun d -> ["date", d]) f.date; + Option.fold ~none: [] ~some: (fun c -> ["latest-checkin", c]) f.latest_checkin; + ] in let data_tuples : (string * string) list = List.concat [ @@ -346,6 +373,21 @@ let prefetch ~env ~proc_mgr ~name () : (unit, error) result = }, p_data.path ) + | `Nilla n, `Nilla n_data -> + Ok ( + {input with + kind = + `Nilla {n with + latest_revision = Some n_data.rev; + datetime = n_data.datetime; + }; + hash = {input.hash with + algorithm = n_data.hash.algorithm; + value = Some n_data.hash.value; + }; + }, + n_data.path + ) | _, _ -> failwith "Prefetch kind mismatch" end in @@ -448,6 +490,8 @@ let lock_one ~env ~sw ~proc_mgr ~force ~name : (unit, error) result = | `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 + | `Nilla n -> Option.is_none n.latest_revision + | `Fossil f -> Option.is_none f.latest_checkin in if needs_prefetch then prefetch ~env ~proc_mgr ~name () diff --git a/lib/lock_loader.ml b/lib/lock_loader.ml index c1648a0..3b6d128 100644 --- a/lib/lock_loader.ml +++ b/lib/lock_loader.ml @@ -16,6 +16,8 @@ module Features = struct let git = 1 lsl 2 let darcs = 1 lsl 3 let pijul = 1 lsl 4 + let nilla = 1 lsl 5 + let fossil = 1 lsl 6 let [@inline]has mask v = (mask land v) <> 0 let [@inline]add mask v = mask lor v @@ -30,6 +32,8 @@ module Features = struct | `Git _ -> add git | `Darcs _ -> add darcs | `Pijul _ -> add pijul + | `Nilla _ -> add nilla + | `Fossil _ -> add fossil let drop_input (input : Input.t) : t -> t = match input.kind with @@ -38,6 +42,8 @@ module Features = struct | `Git _ -> drop git | `Darcs _ -> drop darcs | `Pijul _ -> drop pijul + | `Nilla _ -> drop nilla + | `Fossil _ -> drop fossil end open Fmt diff --git a/lib/lockfile.ml b/lib/lockfile.ml index 36dd069..0792886 100644 --- a/lib/lockfile.ml +++ b/lib/lockfile.ml @@ -291,6 +291,77 @@ module Pijul = struct |> Object.finish end +module Nilla = struct + type t = { + repository: URI.t; + mirrors: URI.t list; + datetime: string option; + latest_revision: string option; + path: string; + } + [@@deriving show, eq, qcheck] + + let [@inline]to_lock + ~(models : Input.jg_models2) + ({repository; mirrors; datetime; latest_revision; path; _}: Input.Nilla.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; + latest_revision; + path = Input.Template.(fill ~models path); + } + + let jsont : t Jsont.t = + let open Jsont in + Object.map ~kind: "Nilla_lock" (fun repository mirrors datetime latest_revision path -> + {repository; mirrors; datetime; latest_revision; path} + ) + |> 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 "lr" (option string) ~enc: (fun i -> i.latest_revision) + |> Object.mem "pt" string ~enc: (fun i -> i.path) + |> Object.finish +end + +module Fossil = struct + type t = { + repository: URI.t; + mirrors: URI.t list; + datetime: string option; + latest_checkin: string option; + } + [@@deriving show, eq, qcheck] + + let [@inline]to_lock + ~(models : Input.jg_models2) + ({repository; reference; date; latest_checkin; _}: Input.Fossil.t) + : t + = + let to_uri = Fun.compose URI.of_string (Input.Template.fill ~models) in + { + repository = to_uri repository; + mirrors = []; (* Fossils don't have mirrors in upstream, so empty *) + datetime = date; + latest_checkin; + } + + let jsont : t Jsont.t = + let open Jsont in + Object.map ~kind: "Fossil_lock" (fun repository mirrors datetime latest_checkin -> + {repository; mirrors; datetime; latest_checkin} + ) + |> 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 "lc" (option string) ~enc: (fun i -> i.latest_checkin) + |> Object.finish +end + module Kind = struct type t = [ | `File of File.t @@ -298,6 +369,8 @@ module Kind = struct | `Git of Git.t | `Darcs of Darcs.t | `Pijul of Pijul.t + | `Nilla of Nilla.t + | `Fossil of Fossil.t ] [@@deriving show, eq, qcheck] @@ -307,6 +380,8 @@ module Kind = struct | `Git g -> `Git (Git.to_lock ~models g) | `Darcs d -> `Darcs (Darcs.to_lock ~models d) | `Pijul p -> `Pijul (Pijul.to_lock ~models p) + | `Nilla n -> `Nilla (Nilla.to_lock ~models n) + | `Fossil f -> `Fossil (Fossil.to_lock ~models f) let jsont : t Jsont.t = let open Jsont in @@ -316,6 +391,8 @@ module Kind = struct | `Git g -> encode_tag 2 Git.jsont g | `Darcs d -> encode_tag 3 Darcs.jsont d | `Pijul p -> encode_tag 4 Pijul.jsont p + | `Nilla n -> encode_tag 5 Nilla.jsont n + | `Fossil f -> encode_tag 6 Fossil.jsont f and dec = function | [|tag; value|] -> begin @@ -335,6 +412,12 @@ module Kind = struct | 4 -> Json.decode' Pijul.jsont value |> Result.map (fun v -> `Pijul v) + | 5 -> + Json.decode' Nilla.jsont value + |> Result.map (fun v -> `Nilla v) + | 6 -> + Json.decode' Fossil.jsont value + |> Result.map (fun v -> `Fossil v) | n -> Error.msgf Meta.none "Unknown reference enum tag: %d" n ) with diff --git a/lib/manifest.ml b/lib/manifest.ml index 1f0f255..77c75f3 100644 --- a/lib/manifest.ml +++ b/lib/manifest.ml @@ -379,6 +379,147 @@ module Pijul = struct } end +module Nilla = struct + module Reference = struct + type t = Input.Nilla.Reference.t + [@@deriving show, eq, qcheck] + + let codec : t KDL.codec = { + to_kdl = (fun ref -> + let open KDL in + match ref with + | `Branch b -> [KDL.node "branch" ~args: [arg (`String b)] []] + | `Ref r -> [KDL.node "ref" ~args: [arg (`String r)] []] + ); + of_kdl = (fun kdl -> + let open KDL.L in + let open KDL.Valid in + let node_names = ["branch"; "ref"] + and branch = ll @@ kdl.@(node "branch" // arg 0 // string_value) + and ref = ll @@ kdl.@(node "ref" // arg 0 // string_value) + in + match branch, ref with + | Ok b, Error _ -> Ok (`Branch b) + | Error _, Ok r -> Ok (`Ref r) + | Error _, Error _ -> Error [`OneRequired node_names] + | _, _ -> Error [`OnlyOneOf node_names] + ); + } + end + + type t = { + repository: Template.t; + mirrors: Template.t list; + reference: Reference.t; + path: Template.t; + } + [@@deriving show, eq, make, qcheck] + + let [@inline]to_manifest ({repository; mirrors; reference; path; _}: Input.Nilla.t) : t = + make ~repository ~mirrors ~reference ~path () + + let [@inline]of_manifest ({repository; mirrors; reference; path}: t) : Input.Nilla.t = + Input.Nilla.make ~repository ~mirrors ~reference ~path () + + let codec : t KDL.codec = { + to_kdl = (fun nilla -> + let open KDL in + let repository = + node "repository" ~args: [Template.to_arg nilla.repository] [] + and path = + node "path" ~args: [Template.to_arg nilla.path] [] + and nodes = + Reference.codec.to_kdl nilla.reference + in + let nodes = + if List.is_empty nilla.mirrors then + nodes + else + node "mirrors" ~args: (List.map Template.to_arg nilla.mirrors) [] :: nodes + in + let nodes = path :: repository :: nodes in + [node "nilla" nodes] + ); + of_kdl = (fun kdl -> + let open KDL.L in + let open KDL.Valid in + let* nilla = ll @@ kdl.@(node "nilla") in + let+ repository = Template.of_child ~name: "repository" nilla + and+ mirrors = Template.of_mirrors nilla + and+ reference = Reference.codec.of_kdl nilla.children + and+ path = Template.of_child ~name: "path" nilla + in + {repository; mirrors; reference; path} + ); + } +end + +module Fossil = struct + module Reference = struct + type t = Input.Fossil.Reference.t + [@@deriving show, eq, qcheck] + + let codec : t KDL.codec = { + to_kdl = (fun ref -> + let open KDL in + match ref with + | `Branch c -> [KDL.node "branch" ~args: [arg (`String c)] []] + | `Tag s -> [KDL.node "tag" ~args: [arg (`String s)] []] + | `Checkin c -> [KDL.node "check-in" ~args: [arg (`String c)] []] + ); + of_kdl = (fun kdl -> + let open KDL.L in + let open KDL.Valid in + let node_names = ["branch"; "tag"; "check-in"] + and branch = ll @@ kdl.@(node "branch" // arg 0 // string_value) + and tag = ll @@ kdl.@(node "tag" // arg 0 // string_value) + and checkin = ll @@ kdl.@(node "check-in" // arg 0 // string_value) + in + match branch, tag, checkin with + | Ok b, Error _, Error _ -> Ok (`Branch b) + | Error _, Ok t, Error _ -> Ok (`Tag t) + | Error _, Error _, Ok c -> Ok (`Checkin c) + | Error _, Error _, Error _ -> Error [`OneRequired node_names] + | _, _, _ -> Error [`OnlyOneOf node_names] + ); + } + end + + type t = { + repository: Template.t; + reference: Reference.t; + } + [@@deriving show, eq, make, qcheck] + + let [@inline]to_manifest ({repository; reference; _}: Input.Fossil.t) : t = + make ~repository ~reference + + let [@inline]of_manifest ({repository; reference}: t) : Input.Fossil.t = + Input.Fossil.make ~repository ~reference () + + let codec : t KDL.codec = { + to_kdl = (fun fossil -> + let open KDL in + let repository = + node "repository" ~args: [Template.to_arg fossil.repository] [] + and nodes = + Reference.codec.to_kdl fossil.reference + in + let nodes = repository :: nodes in + [node "fossil" nodes] + ); + of_kdl = (fun kdl -> + let open KDL.L in + let open KDL.Valid in + let* fossil = ll @@ kdl.@(node "fossil") in + let+ repository = Template.of_child ~name: "repository" fossil + and+ reference = Reference.codec.of_kdl fossil.children + in + {repository; reference} + ); + } +end + module Kind = struct type t = [ | `File of File.t @@ -386,6 +527,8 @@ module Kind = struct | `Git of Git.t | `Darcs of Darcs.t | `Pijul of Pijul.t + | `Nilla of Nilla.t + | `Fossil of Fossil.t ] [@@deriving show, eq, qcheck] @@ -395,6 +538,8 @@ module Kind = struct | `Git g -> `Git (Git.to_manifest g) | `Darcs d -> `Darcs (Darcs.to_manifest d) | `Pijul p -> `Pijul (Pijul.to_manifest p) + | `Nilla n -> `Nilla (Nilla.to_manifest n) + | `Fossil f -> `Fossil (Fossil.to_manifest f) let of_manifest : t -> Input.Kind.t = function | `File f -> `File (File.of_manifest f) @@ -402,6 +547,8 @@ module Kind = struct | `Git g -> `Git (Git.of_manifest g) | `Darcs d -> `Darcs (Darcs.of_manifest d) | `Pijul p -> `Pijul (Pijul.of_manifest p) + | `Nilla n -> `Nilla (Nilla.of_manifest n) + | `Fossil f -> `Fossil (Fossil.of_manifest f) let codec : t KDL.codec = { to_kdl = (function @@ -410,27 +557,35 @@ module Kind = struct | `Git g -> Git.codec.to_kdl g | `Darcs d -> Darcs.codec.to_kdl d | `Pijul p -> Pijul.codec.to_kdl p + | `Nilla n -> Nilla.codec.to_kdl n + | `Fossil f -> Fossil.codec.to_kdl f ); of_kdl = (fun kdl -> - let kind_names = ["file"; "archive"; "git"; "darcs"; "pijul"] in + let kind_names = ["file"; "archive"; "git"; "darcs"; "pijul"; "nilla"; "fossil"] in match File.codec.of_kdl kdl, Archive.codec.of_kdl kdl, Git.codec.of_kdl kdl, Darcs.codec.of_kdl kdl, - Pijul.codec.of_kdl kdl with - | Ok file, Error _, Error _, Error _, Error _ -> + Pijul.codec.of_kdl kdl, + Nilla.codec.of_kdl kdl, + Fossil.codec.of_kdl kdl with + | Ok file, Error _, Error _, Error _, Error _, Error _, Error _ -> Ok (`File file) - | Error _, Ok archive, Error _, Error _, Error _ -> + | Error _, Ok archive, Error _, Error _, Error _, Error _, Error _ -> Ok (`Archive archive) - | Error _, Error _, Ok git, Error _, Error _ -> + | Error _, Error _, Ok git, Error _, Error _, Error _, Error _ -> Ok (`Git git) - | Error _, Error _, Error _, Ok darcs, Error _ -> + | Error _, Error _, Error _, Ok darcs, Error _, Error _, Error _ -> Ok (`Darcs darcs) - | Error _, Error _, Error _, Error _, Ok pijul -> + | Error _, Error _, Error _, Error _, Ok pijul, Error _, Error _ -> Ok (`Pijul pijul) - | Error _, Error _, Error _, Error _, Error _ -> + | Error _, Error _, Error _, Error _, Error _, Ok nilla, Error _ -> + Ok (`Nilla nilla) + | Error _, Error _, Error _, Error _, Error _, Error _, Ok fossil -> + Ok (`Fossil fossil) + | Error _, Error _, Error _, Error _, Error _, Error _, Error _ -> Error [`OneRequired kind_names] - | _, _, _, _, _ -> + | _, _, _, _, _, _, _ -> Error [`OnlyOneOf kind_names] ); } diff --git a/lib/nixtamal.ml b/lib/nixtamal.ml index 9ceaa36..a9435ab 100644 --- a/lib/nixtamal.ml +++ b/lib/nixtamal.ml @@ -10,6 +10,7 @@ module Input = Input module Input_foreman = Input_foreman module Working_directory = Working_directory module KDL = KDL +module Schema = Schema type error = Error.error @@ -34,6 +35,10 @@ let meld_input_with_lock (input : Input.t) (lock : Lockfile.Input'.t) : Input.t } | `Pijul pijul, `Pijul({datetime; latest_state; _}: Lockfile.Pijul.t) -> `Pijul {pijul with datetime; latest_state} + | `Nilla nilla, `Nilla({datetime; latest_revision; _}: Lockfile.Nilla.t) -> + `Nilla {nilla with datetime; latest_revision} + | `Fossil fossil, `Fossil({datetime; latest_checkin; _}: Lockfile.Fossil.t) -> + `Fossil {fossil with date = datetime; latest_checkin} | _, _ -> failwith "Input kind mismatch." ); hash = {input.hash with value = lock.hash.value}; @@ -63,6 +68,16 @@ let read_manifest_and_lockfile () : (Name.Name.t list, error) result = | Some lock when not (String.equal manifest.version lock.version) -> Error (`Version_mismatch (manifest.version, lock.version)) | _ -> + let lockfile_opt = match lockfile_opt with + | Some lock -> Some lock + | None -> + Logs.info (fun m -> m "Lockfile missing, creating new empty lockfile"); + match Lockfile.make ~version: manifest.version () with + | Ok lock -> Some lock + | Error e -> + Logs.warn (fun m -> m "Failed to create lockfile: %a" Error.pp_lockfile_error e); + None + in let to_input d = let input = Manifest.Input'.of_manifest d in let found_input = @@ -203,3 +218,149 @@ let refresh ~env ~domain_count ?names () : (unit, error) result = Lock_loader.write (); Input_foreman.clean_unlisted_from_silo (); Ok () + +let backup_path (filename : string) : string = filename ^ ".bak" + +let upgrade ?from ?(to_ = Schema.Version.current) ?(dry_run = false) () : (unit, error) result = + let (let*) = Result.bind in + let working_dir = Working_directory.get () in + let lockfile_path = Eio.Path.(working_dir / Lockfile.filename) in + let manifest_path = Eio.Path.(working_dir / Manifest.filename) in + let manifest_content = + Eio.Path.with_open_in manifest_path @@ fun flow -> + let buf = Eio.Buf_read.of_flow flow ~max_size: max_int in + Eio.Buf_read.take_all buf + in + Logs.info (fun m -> m "Current schema version: %a" Schema.Version.pp Schema.Version.current); + let* manifest_version = + let open KDL.L in + let open KDL.Valid in + match Eio.Path.with_open_in manifest_path KDL.of_flow with + | Error _ -> Error (`Manifest `Not_set_up) + | Ok kdl_doc -> + match ll @@ kdl_doc.@(node "version" // arg 0 // string_value) with + | Error _ -> Error (`Upgrade "Manifest version not found") + | Ok version_str -> + match Schema.Version.of_string version_str with + | Some v -> Ok v + | None -> Error (`Upgrade (Fmt.str "Unknown manifest schema version: %s" version_str)) + in + Logs.info (fun m -> m "Manifest version: %a" Schema.Version.pp manifest_version); + let* lockfile_version = + match Lockfile.read () with + | Ok (Some lock) -> + begin match Schema.Version.of_string lock.version with + | Some v -> Ok v + | None -> Error (`Upgrade (Fmt.str "Unknown lockfile schema version: %s" lock.version)) + end + | Ok None -> Error (`Upgrade "Lockfile missing, cannot determine version") + | Error err -> Error (`Lockfile (`Parsing err)) + in + Logs.info (fun m -> m "Lockfile version: %a" Schema.Version.pp lockfile_version); + let* () = + match from with + | None -> Ok () + | Some from' when from' <> manifest_version -> + Error (`Version_mismatch (Schema.Version.to_string manifest_version, Schema.Version.to_string from')) + | Some from' when from' <> lockfile_version -> + Error (`Version_mismatch (Schema.Version.to_string lockfile_version, Schema.Version.to_string from')) + | Some _ -> Ok () + in + let needs_manifest_upgrade = manifest_version < to_ + and needs_lock_upgrade = lockfile_version < to_ + in + if not needs_lock_upgrade && not needs_manifest_upgrade then begin + Logs.app (fun m -> m "Already at %a" Schema.Version.pp to_); + Ok () + end else if dry_run then begin + if needs_manifest_upgrade then + Logs.app (fun m -> + m "Would upgrade %s: %a → %a" + Manifest.filename Schema.Version.pp manifest_version Schema.Version.pp to_ + ); + if needs_lock_upgrade then + Logs.app (fun m -> + m "Would upgrade %s: %a → %a" + Lockfile.filename Schema.Version.pp lockfile_version Schema.Version.pp to_ + ); + Logs.app (fun m -> m "No changes applied."); + Ok () + end + else + let manifest_backup_path = Eio.Path.(working_dir / backup_path Manifest.filename) + and lock_backup_path = Eio.Path.(working_dir / backup_path Lockfile.filename) + and manifest_backup_created = ref false + and lock_backup_created = ref false + in + let cleanup_backups () = + Logs.info (fun m -> m "Cleaning up backups…"); + if !manifest_backup_created then + try Eio.Path.unlink manifest_backup_path + with _ -> Logs.err (fun m -> m "Failed to cleanup manifest backup"); + if !lock_backup_created then + try Eio.Path.unlink lock_backup_path + with _ -> Logs.err (fun m -> m "Failed to cleanup lock backup") + in + let rollback () = + Logs.info (fun m -> m "Rolling back backups…"); + if !manifest_backup_created then + try Eio.Path.rename manifest_backup_path manifest_path + with _ -> Logs.err (fun m -> m "Failed to rollback manifest"); + if !lock_backup_created then + try Eio.Path.rename lock_backup_path lockfile_path + with _ -> Logs.err (fun m -> m "Failed to rollback lock"); + cleanup_backups () + in + try + let* () = + if needs_lock_upgrade then + match Lockfile.read () with + | Error err -> Error (`Lockfile (`Parsing err)) + | Ok lockfile_opt -> + match lockfile_opt with + | None -> Error (`Upgrade "Lockfile not set up for upgrade") + | Some lockfile -> + Logs.app (fun m -> m "Upgrading %s: %a → %a" Lockfile.filename Schema.Version.pp lockfile_version Schema.Version.pp to_); + let upgraded = {lockfile with version = Schema.Version.to_string to_} in + Lockfile.lockfile := Some upgraded; + Eio.Path.rename lockfile_path lock_backup_path; + match Lockfile.write () with + | Error err -> Error (`Lockfile err) + | Ok () -> + lock_backup_created := true; + Ok () + else Ok () + in + let* () = + if needs_manifest_upgrade then + Error.tag_manifest @@ begin + Logs.app (fun m -> + m "Upgrading %s: %a → %a" + Manifest.filename Schema.Version.pp manifest_version Schema.Version.pp to_ + ); + let upgraded_content = Str.global_replace (Str.regexp "0\\.1\\.1") (Schema.Version.to_string to_) manifest_content in + Eio.Path.rename manifest_path manifest_backup_path; + Eio.Path.with_open_out ~create:(`Or_truncate 0o644) manifest_path @@ fun flow -> + Eio.Flow.copy_string upgraded_content flow; + manifest_backup_created := true; + Ok () + end + else Ok () + in + let* () = + match Manifest.read () with + | Ok _ -> Logs.info (fun m -> m "Manifest verified."); Ok () + | Error e -> Error (`Manifest (`Parsing [`ParseError e])) + in + let* () = + match Lockfile.read () with + | Ok _ -> Logs.info (fun m -> m "Lockfile verified."); Ok () + | Error e -> Error (`Lockfile (`Parsing e)) + in + cleanup_backups (); + Ok () + with + | exn -> + Logs.err (fun m -> m "Upgrade failed: %s" (Printexc.to_string exn)); + rollback (); + Error (`Upgrade "Failed") diff --git a/lib/prefetch.ml b/lib/prefetch.ml index f4923f5..eb65e60 100644 --- a/lib/prefetch.ml +++ b/lib/prefetch.ml @@ -50,6 +50,17 @@ module Hash = struct |> Object.opt_mem "blake3" string |> Object.opt_mem "sha256" string |> Object.opt_mem "sha512" string + + (* Parse SRI hash like "sha256-XpTlkQ6FXaK0SgN0bu/yji2NASPDuseVaO5bgdFROkM=" *) + let make_from_SRI_hash (value : string) : t = + match String.split_on_char '-' value with + | [algo_str; sri_value] -> + ( + match Input.Hash.algorithm_of_string algo_str with + | Some algorithm -> {algorithm; value = sri_value} + | None -> Jsont.Error.msgf Jsont.Meta.none "Unsupported hash algorithm: %s" algo_str + ) + | _ -> Jsont.Error.msgf Jsont.Meta.none "Invalid SRI hash format: %s" value end module File = struct @@ -264,6 +275,106 @@ module Pijul = struct |> Result.map_error (fun err -> `JSON_parsing (method', err)) end +module Nilla = struct + type t = { + datetime: string option; + path: string; + rev: string; + hash: Hash.t; + } + [@@deriving make, show] + + let jsont : t Jsont.t = + let open Jsont in + Object.map + ~kind: "Prefetch_Nilla" + (fun path datetime rev blake3 sha256 sha512 -> + let hash = Hash.make_from_opts blake3 sha256 sha512 in + make ~path ?datetime ~rev ~hash () + ) + |> Object.mem "path" string ~enc: (fun i -> i.path) + |> Object.opt_mem "date" string ~enc: (fun i -> i.datetime) + |> Object.mem "rev" string ~enc: (fun i -> i.rev) + |> Hash.add_jsont_case + |> Object.finish + + let latest_cmd (n : Input.Nilla.t) ~models = + let cmd = [ + "nix-prefetch-git"; + "--no-deepClone"; + "--quiet"; + "--url"; + URI.to_string (URI.of_string (Input.Template.fill n.repository ~models)); + ] + in + List.concat [ + cmd; + ( + match n.reference with + | `Branch b -> ["--branch-name"; b] + | `Ref r -> ["--rev"; r] + ); + ] + + let get_latest ~proc_mgr ~proc_env (n : Input.Nilla.t) ~models = + let (let*) = Result.bind in + let method' = `Nilla in + let* stdout = run_and_gather ~proc_mgr ~proc_env method' (latest_cmd n ~models) in + let* parsed = Jsont_bytesrw.decode_string jsont stdout + |> Result.map_error (fun err -> `JSON_parsing (method', err)) + in + let nilla_path = Input.Template.fill n.path ~models in + let full_path = Filename.concat parsed.path nilla_path in + if Sys.file_exists full_path then + Ok {parsed with path = full_path} + else + Error (`Bad_output (method', Printf.sprintf "nilla.nix not found at path '%s' in repository" nilla_path)) +end + +module Fossil = struct + type t = { + path: string; + datetime: string option; + checkin: string; + hash: Hash.t + } + [@@deriving make, show] + + let jsont : t Jsont.t = + let open Jsont in + Object.map + ~kind: "Prefetch_Fossil" + (fun path datetime checkin hash_str -> + let hash = Hash.make_from_SRI_hash hash_str in + make ~path ?datetime ~checkin ~hash () + ) + |> Object.mem "path" string ~enc: (fun i -> i.path) + |> Object.opt_mem "date" string ~enc: (fun i -> i.datetime) + |> Object.mem "rev" string ~enc: (fun i -> i.checkin) + |> Object.mem "hash" string + |> Object.finish + + let latest_cmd (f : Input.Fossil.t) ~models = + let cmd = [ + "nix-prefetch-fossil"; + "--url"; + URI.to_string (URI.of_string (Input.Template.fill f.repository ~models)); + ] + in + cmd @ + match f.reference with + | `Branch b -> ["--rev"; b] + | `Tag t -> ["--rev"; t] + | `Checkin c -> ["--rev"; c] + + let get_latest ~proc_mgr ~proc_env (f : Input.Fossil.t) ~models = + let (let*) = Result.bind in + let method' = `Fossil in + let* stdout = run_and_gather ~proc_mgr ~proc_env method' (latest_cmd f ~models) in + Jsont_bytesrw.decode_string jsont stdout + |> Result.map_error (fun err -> `JSON_parsing (method', err)) +end + type prefetch_kind_result = ( [ | `File of File.t @@ -271,6 +382,8 @@ type prefetch_kind_result = ( | `Git of Git.t | `Darcs of Darcs.t | `Pijul of Pijul.t + | `Nilla of Nilla.t + | `Fossil of Fossil.t ], error ) result @@ -298,3 +411,9 @@ let get_latest ~env ~proc_mgr (input : Input.t) : prefetch_kind_result = | `Pijul pijul -> Pijul.get_latest ~proc_mgr ~proc_env pijul ~models |> Result.map (fun p -> `Pijul p) + | `Nilla nilla -> + Nilla.get_latest ~proc_mgr ~proc_env nilla ~models + |> Result.map (fun n -> `Nilla n) + | `Fossil fossil -> + Fossil.get_latest ~proc_mgr ~proc_env fossil ~models + |> Result.map (fun f -> `Fossil f) diff --git a/lib/schema.ml b/lib/schema.ml new file mode 100644 index 0000000..40b058a --- /dev/null +++ b/lib/schema.ml @@ -0,0 +1,31 @@ +(*─────────────────────────────────────────────────────────────────────────────┐ +│ SPDX-FileCopyrightText: 2025 toastal <https://toast.al/contact/> │ +│ SPDX-License-Identifier: LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception │ +└─────────────────────────────────────────────────────────────────────────────*) +module Version = struct + type t = + | V0_1_1 + | V0_2_0 + [@@deriving show, enum, eq, ord] + + let of_string s = + match s with + | "0.1.1" -> Some V0_1_1 + | "0.2.0" -> Some V0_2_0 + | _ -> None + + let to_string = f |