From 00920433dc5c11c8d7702e55ee7a763f7efc464f Mon Sep 17 00:00:00 2001 From: devkit Date: Wed, 23 Sep 2026 19:12:16 +0000 Subject: [PATCH 01/34] Add devkit package-manager dashboard Scan installed software across winget/npm/pipx/uv/cargo, merge with a pkgs.txt manifest, and export a restore-ready snapshot. Custom tools via tools.sexp plugins. --- .gitignore | 3 + .ocamlformat | 2 + README.md | 67 ++++++ bin/dune | 4 + bin/main.ml | 146 ++++++++++++ devkit.opam | 38 ++++ dune-project | 25 +++ lib/app.ml | 349 +++++++++++++++++++++++++++++ lib/app.mli | 37 ++++ lib/bootstrap.ml | 398 +++++++++++++++++++++++++++++++++ lib/bootstrap.mli | 52 +++++ lib/dashboard.ml | 264 ++++++++++++++++++++++ lib/dashboard.mli | 23 ++ lib/dune | 4 + lib/fetch.ml | 25 +++ lib/fetch.mli | 8 + lib/gh.ml | 88 ++++++++ lib/gh.mli | 21 ++ lib/hash.ml | 94 ++++++++ lib/hash.mli | 15 ++ lib/install.ml | 195 ++++++++++++++++ lib/install.mli | 34 +++ lib/inventory.ml | 268 ++++++++++++++++++++++ lib/inventory.mli | 24 ++ lib/pkgfile.ml | 105 +++++++++ lib/pkgfile.mli | 34 +++ lib/plugin.ml | 360 ++++++++++++++++++++++++++++++ lib/plugin.mli | 49 ++++ lib/proc.ml | 52 +++++ lib/proc.mli | 12 + lib/strutil.ml | 27 +++ lib/strutil.mli | 7 + lib/winget_json.ml | 59 +++++ lib/winget_json.mli | 4 + lib/winget_parse.ml | 137 ++++++++++++ lib/winget_parse.mli | 22 ++ lib/zipx.ml | 250 +++++++++++++++++++++ lib/zipx.mli | 24 ++ test/dune | 49 ++++ test/fixtures/bundle.zip | Bin 0 -> 825 bytes test/fixtures/evil.zip | Bin 0 -> 311 bytes test/fixtures/good.zip | Bin 0 -> 337 bytes test/fixtures/nox64.zip | Bin 0 -> 374 bytes test/test_app.ml | 236 ++++++++++++++++++++ test/test_bootstrap.ml | 466 +++++++++++++++++++++++++++++++++++++++ test/test_dashboard.ml | 149 +++++++++++++ test/test_gh.ml | 76 +++++++ test/test_hash.ml | 150 +++++++++++++ test/test_install.ml | 363 ++++++++++++++++++++++++++++++ test/test_inventory.ml | 139 ++++++++++++ test/test_pkgfile.ml | 116 ++++++++++ test/test_plugin.ml | 239 ++++++++++++++++++++ test/test_winget.ml | 109 +++++++++ test/test_winget_json.ml | 89 ++++++++ test/test_zipx.ml | 114 ++++++++++ 55 files changed, 5621 insertions(+) create mode 100644 .gitignore create mode 100644 .ocamlformat create mode 100644 README.md create mode 100644 bin/dune create mode 100644 bin/main.ml create mode 100644 devkit.opam create mode 100644 dune-project create mode 100644 lib/app.ml create mode 100644 lib/app.mli create mode 100644 lib/bootstrap.ml create mode 100644 lib/bootstrap.mli create mode 100644 lib/dashboard.ml create mode 100644 lib/dashboard.mli create mode 100644 lib/dune create mode 100644 lib/fetch.ml create mode 100644 lib/fetch.mli create mode 100644 lib/gh.ml create mode 100644 lib/gh.mli create mode 100644 lib/hash.ml create mode 100644 lib/hash.mli create mode 100644 lib/install.ml create mode 100644 lib/install.mli create mode 100644 lib/inventory.ml create mode 100644 lib/inventory.mli create mode 100644 lib/pkgfile.ml create mode 100644 lib/pkgfile.mli create mode 100644 lib/plugin.ml create mode 100644 lib/plugin.mli create mode 100644 lib/proc.ml create mode 100644 lib/proc.mli create mode 100644 lib/strutil.ml create mode 100644 lib/strutil.mli create mode 100644 lib/winget_json.ml create mode 100644 lib/winget_json.mli create mode 100644 lib/winget_parse.ml create mode 100644 lib/winget_parse.mli create mode 100644 lib/zipx.ml create mode 100644 lib/zipx.mli create mode 100644 test/dune create mode 100644 test/fixtures/bundle.zip create mode 100644 test/fixtures/evil.zip create mode 100644 test/fixtures/good.zip create mode 100644 test/fixtures/nox64.zip create mode 100644 test/test_app.ml create mode 100644 test/test_bootstrap.ml create mode 100644 test/test_dashboard.ml create mode 100644 test/test_gh.ml create mode 100644 test/test_hash.ml create mode 100644 test/test_install.ml create mode 100644 test/test_inventory.ml create mode 100644 test/test_pkgfile.ml create mode 100644 test/test_plugin.ml create mode 100644 test/test_winget.ml create mode 100644 test/test_winget_json.ml create mode 100644 test/test_zipx.ml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9a93bba --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +_build/ +_opam/ +*.install diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..a8b2df7 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,2 @@ +profile = janestreet +version = 0.29.0 diff --git a/README.md b/README.md new file mode 100644 index 0000000..d068fae --- /dev/null +++ b/README.md @@ -0,0 +1,67 @@ +# devkit + +Scan your PC for installed software across package managers, merge the +result with a `pkgs.txt` manifest, and export a restore-ready snapshot. + +## Build + +System OCaml 5.5.0 + opam `system` switch. Deps: +`alcotest cmdliner yojson digestif decompress sexplib re ocamlformat`. + +```sh +eval $(opam env --switch=system) +dune build +dune runtest # 129 alcotests, must stay green +dune exec bin/main.exe -- --help +``` + +`dune-project` is the source of truth for packaging; `devkit.opam` is +generated (see AGENTS.md for the regen dance). Every `lib/*.ml` has a +`.mli`; format with `ocamlformat -i` before testing. + +## Commands + +```sh +devkit # dashboard: manifest status, or full scan +devkit import FILE # preview a manifest against this machine +devkit add ID... # append installed apps to pkgs.txt +devkit append [--new] # append newly-detected apps (or given ids) +devkit export [-o FILE] # write pkgs.txt + winget import-ready JSON +``` + +`export` writes two files: the plain manifest (`pkgs.txt`) and a +`winget import -i`-compatible JSON sibling (schema 2.0.0, installed +versions pinned; skipped when no winget apps are installed). + +## Custom package managers (`tools.sexp`) + +Built-ins: winget, npm, pipx, uv, cargo. Anything else goes in an +s-expression file — `tools.sexp` next to `pkgs.txt` first, then +`~/.config/devkit/tools.sexp` (`%LOCALAPPDATA%\devkit\tools.sexp` on +Windows). First file wins per tool name; built-in names are reserved. + +```scheme +;; ; comments allowed. Only name/prog/row_re are required. +(tools + (tool + (name mytool) + (prog mytool) + (list --list --short) ; argv for the list command + (skip_prefixes ("- " "WARN")) ; ignore shim/warning lines + (row_re "^(\\S+)\\s+v?([0-9][^ ]*)") ; group 1 = name, group 2 = version + (strip_version_prefix v) ; strip AFTER matching, so row_re + ; must tolerate the raw prefix + (install (mytool install {id})) ; {id} is the only variable + (upgrade (mytool upgrade {id})))) +``` + +A broken config fails loudly at startup (unknown field, bad regex, +missing key) — never silently. `row_re` is PCRE; a missing group 2 +means unversioned. Custom tools scan after the built-ins in file order, +participate in dashboard/export, and install through their templates +(missing template or failed spawn = error outcome, never a skip). + +## Docs + +- `AGENTS.md` — toolchain, phased plan, conventions. +- `CHANGES.md` — changelog, newest first. diff --git a/bin/dune b/bin/dune new file mode 100644 index 0000000..d6467d1 --- /dev/null +++ b/bin/dune @@ -0,0 +1,4 @@ +(executable + (public_name devkit) + (name main) + (libraries devkit cmdliner unix)) diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 0000000..1a26392 --- /dev/null +++ b/bin/main.ml @@ -0,0 +1,146 @@ +(** devkit CLI. + + Commands: default (dashboard), import, add, append [--new], export + [-o]. The default view prints the plain-text dashboard; the + interactive TUI arrives in Phase 5. *) + +open Devkit + +let real_fs : App.fs = + { read_file = + (fun path -> + try + let ic = open_in path in + let n = in_channel_length ic in + let s = really_input_string ic n in + close_in ic; + Some s + with + | _ -> None) + ; append_file = + (fun path text -> + try + let oc = open_out_gen [ Open_append; Open_creat ] 0o644 path in + output_string oc text; + close_out oc; + Ok () + with + | e -> Error (Printexc.to_string e)) + ; write_file = + (fun path text -> + try + let oc = open_out path in + output_string oc text; + close_out oc; + Ok () + with + | e -> Error (Printexc.to_string e)) + } +;; + +let make_env () : App.env = + let fetch = Fetch.curl_fetch Proc.default_runner in + { run = Proc.default_runner; fs = real_fs; bio = Bootstrap.real_io fetch } +;; + +(** Custom tools from [tools.sexp] (cwd) + config dir. A broken file + exits with an error: silently ignoring the user's tools would be worse. *) +let load_tools () : Plugin.tool list = + match + Plugin.load_many + ~read:real_fs.read_file + ~reserved:Inventory.reserved_names + (Plugin.default_paths ()) + with + | Ok tools -> tools + | Error e -> + prerr_endline ("devkit: " ^ e); + exit 1 +;; + +let print_lines lines = List.iter print_endline lines + +let default_term = + Cmdliner.Term.( + const (fun () -> + let tools = load_tools () in + print_string (App.default_view ~tools (make_env ()))) + $ const ()) +;; + +let default_info = + Cmdliner.Cmd.info + "devkit" + ~doc: + "Scan your PC for installed software and manage packages. With pkgs.txt: shows \ + status. Without: shows everything installed." +;; + +let import_cmd = + let file = Cmdliner.Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE") in + let run path = + match App.import_view ~tools:(load_tools ()) (make_env ()) path with + | Error e -> + prerr_endline ("devkit: " ^ e); + exit 1 + | Ok s -> print_string s + in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info "import" ~doc:"Import and install packages from a file") + Cmdliner.Term.(const run $ file) +;; + +let add_cmd = + let ids = Cmdliner.Arg.(non_empty & pos_all string [] & info [] ~docv:"ID") in + let run ids = print_lines (App.run_add ~tools:(load_tools ()) (make_env ()) ids) in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info "add" ~doc:"Append specific installed apps to pkgs.txt") + Cmdliner.Term.(const run $ ids) +;; + +let append_cmd = + let ids = Cmdliner.Arg.(value & pos_all string [] & info [] ~docv:"ID") in + let is_new = + Cmdliner.Arg.( + value & flag & info [ "new" ] ~doc:"append all newly-detected apps (no TUI yet)") + in + let run ids is_new = + let tools = load_tools () in + print_lines + (if is_new + then App.run_append_new ~tools (make_env ()) + else App.run_append ~tools (make_env ()) ids) + in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info + "append" + ~doc:"Append newly-detected apps (or given ids) to pkgs.txt") + Cmdliner.Term.(const run $ ids $ is_new) +;; + +let export_cmd = + let output = + Cmdliner.Arg.( + value + & opt string "pkgs.txt" + & info [ "o"; "output" ] ~docv:"FILE" ~doc:"output file path") + in + let run output = + print_lines (App.run_export ~tools:(load_tools ()) (make_env ()) output) + in + Cmdliner.Cmd.v + (Cmdliner.Cmd.info + "export" + ~doc:"Scan PC and write all installed software to pkgs.txt") + Cmdliner.Term.(const run $ output) +;; + +let () = + let group = + Cmdliner.Cmd.group + ~default:default_term + default_info + [ import_cmd; add_cmd; append_cmd; export_cmd ] + in + exit (Cmdliner.Cmd.eval group) +;; diff --git a/devkit.opam b/devkit.opam new file mode 100644 index 0000000..7243dec --- /dev/null +++ b/devkit.opam @@ -0,0 +1,38 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Cross package-manager inventory dashboard" +description: + "Scan your PC for installed software across package managers, merge the result with a pkgs.txt manifest, and export a restore-ready snapshot." +maintainer: ["devkit contributors"] +authors: ["devkit contributors"] +license: "MIT" +homepage: "https://github.com/anomalyco/devkit" +bug-reports: "https://github.com/anomalyco/devkit/issues" +depends: [ + "ocaml" {>= "5.2"} + "dune" {>= "3.24"} + "cmdliner" {>= "1.2"} + "yojson" {>= "2.0"} + "digestif" {>= "1.2"} + "decompress" {>= "1.5"} + "sexplib" {>= "0.17"} + "re" {>= "1.11"} + "alcotest" {>= "1.7" & with-test} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/anomalyco/devkit.git" +x-maintenance-intent: ["(latest)"] diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..d861074 --- /dev/null +++ b/dune-project @@ -0,0 +1,25 @@ +(lang dune 3.24) + +(name devkit) + +(generate_opam_files true) + +(source (github anomalyco/devkit)) +(license MIT) +(authors "devkit contributors") +(maintainers "devkit contributors") + +(package + (name devkit) + (synopsis "Cross package-manager inventory dashboard") + (description "Scan your PC for installed software across package managers, merge the result with a pkgs.txt manifest, and export a restore-ready snapshot.") + (depends + (ocaml (>= 5.2)) + (dune (>= 3.24)) + (cmdliner (>= 1.2)) + (yojson (>= 2.0)) + (digestif (>= 1.2)) + (decompress (>= 1.5)) + (sexplib (>= 0.17)) + (re (>= 1.11)) + (alcotest (and (>= 1.7) :with-test)))) diff --git a/lib/app.ml b/lib/app.ml new file mode 100644 index 0000000..53e71a7 --- /dev/null +++ b/lib/app.ml @@ -0,0 +1,349 @@ +(** CLI orchestration: the [run*] commands. + + Default view, import, add, append, append-new and export, plus + [append_selected], manifest loading, scan fallback and the [winget + show] enrichment. Everything runs against an injected environment so + tests fake scan results, winget output and the filesystem without + spawning processes. + + Deliberate omissions: + - No silent manifest rewrite: it would destroy user edits, so it + stays out. + - No dead append helper: only wired commands ship. + - [--new] appends every newly-detected app; TUI selection lands in + Phase 5. + - [winget show] enrichment runs sequentially; parallelize when it + measurably hurts. + - pm order: [winget; npm; pipx; uv; cargo]. *) + +open Pkgfile +open Dashboard + +let pm_order = [ "winget"; "npm"; "pipx"; "uv"; "cargo" ] + +type fs = + { read_file : string -> string option + ; append_file : string -> string -> (unit, string) result + ; write_file : string -> string -> (unit, string) result + } + +type env = + { run : Proc.runner + ; fs : fs + ; bio : Bootstrap.io + } + +let lower s = String.lowercase_ascii s + +(** [parsePkgFile]: missing/unparseable file yields empty sections, as Go + ignores both errors. *) +let load_manifest (fs : fs) (path : string) : section list * string = + match fs.read_file path with + | None -> [], "" + | Some text -> + let r = Pkgfile.parse text in + r.sections, r.winget_path +;; + +(** Best-effort winget info from the scan when [winget list] fails. *) +let info_from_scan (apps : app list) : Winget_parse.info Winget_parse.IdMap.t = + List.fold_left + (fun m (a : app) -> + if a.pm = "winget" && a.name <> "" + then + Winget_parse.IdMap.add + (lower a.name) + { Winget_parse.id = a.name + ; name = a.name + ; version = a.version + ; available = "" + } + m + else m) + Winget_parse.IdMap.empty + apps +;; + +(** [winget show --id ] → repo's latest version, "" on failure. *) +let winget_show (bio : Bootstrap.io) (winget : string) (id : string) : string = + if winget = "" + then "" + else ( + let out, ok = bio.spawn winget [ "show"; "--id"; id; "--accept-source-agreements" ] in + if not ok + then "" + else ( + let lines = String.split_on_char '\n' out in + let rec find = function + | [] -> "" + | ln :: rest -> + let t = String.trim ln in + let pre = "Version:" in + if + String.length t >= String.length pre + && String.sub t 0 (String.length pre) = pre + then ( + let v = + String.trim + (String.sub t (String.length pre) (String.length t - String.length pre)) + in + if v <> "" then v else find rest) + else find rest + in + find lines)) +;; + +type scan = + { apps : app list + ; info : Winget_parse.info Winget_parse.IdMap.t option + ; winget : string + } + +(** One scan + update check; the memoized [winget list] fetch is shared by + both, so a command spawns winget once per 8s window. A failed ensure + degrades to winget-less operation (""). *) +let scan (e : env) ~(override_path : string) ~(extra : Plugin.tool list) : scan = + let winget = + match Bootstrap.ensure ~override_path e.bio with + | Ok w -> w + | Error _ -> "" + in + let fetch, _ = Proc.winget_list e.run in + let apps = Inventory.scan_all e.run ~winget:(fun () -> fetch winget) ~extra in + let info = + match fetch winget with + | None -> + let m = info_from_scan apps in + if Winget_parse.IdMap.is_empty m then None else Some m + | Some out -> + let m = Winget_parse.parse_list_table out in + if Winget_parse.IdMap.is_empty m + then ( + let fb = info_from_scan apps in + if Winget_parse.IdMap.is_empty fb then None else Some fb) + else Some m + in + { apps; info; winget } +;; + +let to_dashboard_apps (apps : app list) : Dashboard.app list = + List.map + (fun (a : app) -> { Dashboard.name = a.name; version = a.version; pm = a.pm }) + apps +;; + +(** Default view: scan, enrich, merge with pkgs.txt, render plain text. + Returns the rendered dashboard (the TUI takes over in Phase 5). *) +let default_view (e : env) ~(tools : Plugin.tool list) : string = + let sections, winget_path = load_manifest e.fs "pkgs.txt" in + let s = scan e ~override_path:winget_path ~extra:tools in + let show id = + let v = winget_show e.bio s.winget id in + if v = "" then None else Some v + in + let dash = build_sections ~show (to_dashboard_apps s.apps) sections s.info in + render dash +;; + +let import_view (e : env) ?(tools : Plugin.tool list = []) (path : string) + : (string, string) result + = + match e.fs.read_file path with + | None -> Error ("open: " ^ path) + | Some text -> + let r = Pkgfile.parse text in + let s = scan e ~override_path:r.winget_path ~extra:tools in + let show id = + let v = winget_show e.bio s.winget id in + if v = "" then None else Some v + in + Ok (render (build_sections ~show (to_dashboard_apps s.apps) r.sections s.info)) +;; + +let type_string = function + | Winget -> "winget" + | GitHub -> "github" + | Url -> "url" +;; + +(** [appendSelected]: persists items under a "# Newly detected" section, + grouped in pm order. Existing entries are never touched. *) +let append_selected (fs : fs) (path : string) (items : item list) : (unit, string) result = + if items = [] + then Ok () + else ( + let buf = Buffer.create 256 in + Buffer.add_string buf "\n# Newly detected\n"; + List.iter + (fun pm -> + List.iter + (fun it -> + if type_string it.typ = pm + then Buffer.add_string buf (Printf.sprintf "%s:%s\n" pm it.value)) + items) + pm_order; + fs.append_file path (Buffer.contents buf)) +;; + +let is_new_section (sec : section) : bool = + let n = lower sec.name in + n = "newly detected" || n = "pending updates" +;; + +(** StatusNew items from Newly-detected (+ Pending-updates when [extra]). *) +let new_items ?(extra : bool = false) (sections : section list) : item list = + List.concat_map + (fun (sec : section) -> + if + lower sec.name = "newly detected" || (extra && lower sec.name = "pending updates") + then List.filter (fun it -> it.status = New) sec.items + else []) + sections +;; + +(** [runAdd]: appends given ids (must be installed, not already known). *) +let run_add (e : env) ?(tools : Plugin.tool list = []) (ids : string list) : string list = + let s = scan e ~override_path:"" ~extra:tools in + let installed = Hashtbl.create 64 in + (match s.info with + | Some m -> Winget_parse.IdMap.iter (fun id _ -> Hashtbl.replace installed id true) m + | None -> ()); + List.iter + (fun (a : app) -> + if a.pm = "winget" && a.name <> "" + then Hashtbl.replace installed (lower a.name) true) + s.apps; + let sections, _ = load_manifest e.fs "pkgs.txt" in + let known = Hashtbl.create 64 in + List.iter + (fun (sec : section) -> + List.iter (fun it -> Hashtbl.replace known (lower it.value) true) sec.items) + sections; + let msgs = ref [] in + let emit m = msgs := m :: !msgs in + let to_append = ref [] in + List.iter + (fun raw -> + let id = lower raw in + if Hashtbl.mem known id + then emit (Printf.sprintf " skip (already in manifest): %s" raw) + else if not (Hashtbl.mem installed id) + then emit (Printf.sprintf " skip (not installed): %s" raw) + else ( + let ver, avail = + match s.info with + | Some m -> + (match Winget_parse.IdMap.find_opt id m with + | Some inf -> inf.version, inf.available + | None -> "", "") + | None -> "", "" + in + to_append + := { (make_item Winget raw) with + installed_version = ver + ; available_version = avail + ; status = New + } + :: !to_append)) + ids; + (match List.rev !to_append with + | [] -> emit " nothing to append" + | items -> + (match append_selected e.fs "pkgs.txt" items with + | Error e -> emit (" error: " ^ e) + | Ok () -> + emit (Printf.sprintf " appended %d app(s) to pkgs.txt" (List.length items)))); + List.rev !msgs +;; + +(** [runAppend]: no ids → every newly-detected winget-installable app; + with ids → behaves like [runAdd]. *) +let run_append (e : env) ?(tools : Plugin.tool list = []) (ids : string list) + : string list + = + if ids <> [] + then run_add e ~tools ids + else ( + let s = scan e ~override_path:"" ~extra:tools in + let sections, _ = load_manifest e.fs "pkgs.txt" in + let dash = build_sections (to_dashboard_apps s.apps) sections s.info in + let items = new_items ~extra:true dash in + if items = [] + then [ " nothing new to append" ] + else ( + match append_selected e.fs "pkgs.txt" items with + | Error e -> [ " error: " ^ e ] + | Ok () -> [ Printf.sprintf " appended %d app(s) to pkgs.txt" (List.length items) ])) +;; + +(** [runAppendNew] (--new): newly-detected apps only (no pending updates). *) +let run_append_new (e : env) ~(tools : Plugin.tool list) : string list = + let s = scan e ~override_path:"" ~extra:tools in + let sections, _ = load_manifest e.fs "pkgs.txt" in + let dash = build_sections (to_dashboard_apps s.apps) sections s.info in + let items = new_items dash in + if items = [] + then [ " no newly detected apps" ] + else ( + match append_selected e.fs "pkgs.txt" items with + | Error e -> [ " error: " ^ e ] + | Ok () -> [ Printf.sprintf " appended %d app(s) to pkgs.txt" (List.length items) ]) +;; + +(** [runExport]: scan → write manifest grouped in pm order, plus a + [winget import]-compatible JSON next to it (same basename, [.json] + extension). Only winget-tracked apps land in the JSON; the rest live + in the pkgs file alone. *) +let json_sibling (output : string) : string = + if Filename.check_suffix output ".txt" + then Filename.chop_suffix output ".txt" ^ ".json" + else output ^ ".json" +;; + +(** Export groups by {!pm_order} plus any custom tool names in file + order, so custom tools are never dropped from the manifest. *) +let order_for (tools : Plugin.tool list) : string list = + pm_order + @ List.filter + (fun n -> not (List.mem n pm_order)) + (List.map (fun (t : Plugin.tool) -> t.name) tools) +;; + +let run_export (e : env) ?(tools : Plugin.tool list = []) (output : string) : string list = + let s = scan e ~override_path:"" ~extra:tools in + if s.apps = [] + then [ " no installed software found" ] + else ( + let buf = Buffer.create 512 in + Buffer.add_string buf "# Generated by devkit export\n"; + List.iter + (fun pm -> + let apps = List.filter (fun (a : app) -> a.pm = pm) s.apps in + if apps <> [] + then ( + Buffer.add_string buf (Printf.sprintf "\n# %s\n" pm); + List.iter + (fun (a : app) -> Buffer.add_string buf (Printf.sprintf "%s:%s\n" pm a.name)) + apps)) + (order_for tools); + match e.fs.write_file output (Buffer.contents buf) with + | Error e -> [ " error: " ^ e ] + | Ok () -> + let json_path = json_sibling output in + let winget_apps = List.filter (fun (a : app) -> a.pm = "winget") s.apps in + let base = Printf.sprintf "wrote %s (%d apps)" output (List.length s.apps) in + (* An empty Packages list violates the schema (minItems 1) and + winget import would reject it, so the file is skipped instead. *) + if winget_apps = [] + then [ base; " no winget apps, json skipped" ] + else ( + match e.fs.write_file json_path (Winget_json.to_string s.apps) with + | Error e -> [ base; " winget json skipped: " ^ e ] + | Ok () -> + [ base + ; Printf.sprintf + "wrote %s (%d winget apps, winget import -i ready)" + json_path + (List.length winget_apps) + ])) +;; diff --git a/lib/app.mli b/lib/app.mli new file mode 100644 index 0000000..c952525 --- /dev/null +++ b/lib/app.mli @@ -0,0 +1,37 @@ +(** CLI orchestration: the [run*] commands. *) + +val pm_order : string list + +type fs = + { read_file : string -> string option + ; append_file : string -> string -> (unit, string) result + ; write_file : string -> string -> (unit, string) result + } + +type env = + { run : Proc.runner + ; fs : fs + ; bio : Bootstrap.io + } + +type scan = + { apps : Dashboard.app list + ; info : Winget_parse.info Winget_parse.IdMap.t option + ; winget : string + } + +(** Missing/unparseable file yields empty sections. *) +val load_manifest : fs -> string -> Pkgfile.section list * string + +val winget_show : Bootstrap.io -> string -> string -> string +val scan : env -> override_path:string -> extra:Plugin.tool list -> scan +val default_view : env -> tools:Plugin.tool list -> string +val import_view : env -> ?tools:Plugin.tool list -> string -> (string, string) result +val append_selected : fs -> string -> Pkgfile.item list -> (unit, string) result +val new_items : ?extra:bool -> Pkgfile.section list -> Pkgfile.item list +val run_add : env -> ?tools:Plugin.tool list -> string list -> string list +val run_append : env -> ?tools:Plugin.tool list -> string list -> string list +val run_append_new : env -> tools:Plugin.tool list -> string list +val json_sibling : string -> string +val order_for : Plugin.tool list -> string list +val run_export : env -> ?tools:Plugin.tool list -> string -> string list diff --git a/lib/bootstrap.ml b/lib/bootstrap.ml new file mode 100644 index 0000000..d001a5c --- /dev/null +++ b/lib/bootstrap.ml @@ -0,0 +1,398 @@ +(** Winget location + bootstrap download. + + Resolution order: [# winget:] override → portable candidates walking + up 4 levels from the cwd, then the exe dir → exe-adjacent [winget/] + subfolder → PATH lookup of ["winget"] (no [.exe]) → [cmd /c where + winget] alias resolution with a [--version] probe → + [%LOCALAPPDATA%/…/WindowsApps/winget.exe] with probe → cached + [AppInstaller.exe] → download. + + Design notes: + + - [winget_runs] needs only one spawn: {!spawn} always returns combined + output, so one [--version] call decides. + - Failures come back as values. {!ensure} returns the error (with cert + advice appended when it fits) and lets the CLI layer decide what to + display. *) + +(** [spawn prog args] runs the command, returning combined output and + whether it exited zero. Unlike {!Proc.runner} the output survives + failure: the installer needs winget's text even on non-zero exit. *) +type spawn = string -> string list -> string * bool + +(** Real backend on top of [Unix.open_process_args_in]. *) +let real_spawn : spawn = + fun prog args -> + try + let cmd = Array.of_list (prog :: args) in + let ic = Unix.open_process_args_in prog cmd in + let buf = Buffer.create 256 in + (try + while true do + Buffer.add_channel buf ic 4096 + done + with + | End_of_file -> ()); + let out = String.trim (Buffer.contents buf) in + match Unix.close_process_in ic with + | Unix.WEXITED 0 -> out, true + | _ -> out, false + with + | _ -> "", false +;; + +(** Injected OS surface. Tests fake the filesystem/spawns; production uses + {!real_io}. *) +type io = + { getenv : string -> string option + ; is_file : string -> bool + ; spawn : spawn + ; cwd : unit -> (string, string) result + ; exe_dir : unit -> (string, string) result + ; mkdir_p : string -> (unit, string) result + ; cache_dir : unit -> string + ; latest_winget_cli : unit -> (Gh.release, string) result + ; download : url:string -> (string, string) result + ; unzip : zip:string -> dir:string -> (unit, string) result + } + +(** Production wiring: curl fetcher, digestif verifier, central-dir zip + reader. [cache_dir] is [%LOCALAPPDATA%] on Windows, + [$XDG_CACHE_HOME/~/.cache] elsewhere, + [devkit/winget]. *) +let real_io (fetch : Fetch.fetch) : io = + { getenv = Sys.getenv_opt + ; is_file = Sys.file_exists + ; spawn = real_spawn + ; cwd = + (fun () -> + try Ok (Unix.getcwd ()) with + | e -> Error (Printexc.to_string e)) + ; exe_dir = (fun () -> Ok (Filename.dirname Sys.executable_name)) + ; mkdir_p = + (fun dir -> + try + Zipx.mkdir_p dir; + Ok () + with + | e -> Error (Printexc.to_string e)) + ; cache_dir = + (fun () -> + let base = + match Sys.getenv_opt "XDG_CACHE_HOME" with + | Some d when d <> "" -> d + | _ -> + (match Sys.getenv_opt "HOME" with + | Some h when h <> "" -> Filename.concat h ".cache" + | _ -> + (match Sys.getenv_opt "LOCALAPPDATA" with + | Some l when l <> "" -> Filename.concat l "cache" + | _ -> ".")) + in + Filename.concat (Filename.concat base "devkit") "winget") + ; latest_winget_cli = (fun () -> Gh.latest_release fetch "microsoft/winget-cli") + ; download = (fun ~url -> Hash.download_and_verify fetch Hash.No_expected url) + ; unzip = (fun ~zip ~dir -> Zipx.extract ~zip_path:zip ~dest_dir:dir) + } +;; + +let portable_names = [ "winget.exe"; "AppInstaller.exe" ] +let portable_subs = [ []; [ "winget" ]; [ "build"; "winget" ] ] + +(** [find_portable ~is_file base] returns the first portable winget under + [base], checking each level's 6 candidates (2 names × 3 subfolders) + while walking up 4 levels. *) +let find_portable ~is_file (base : string) : string = + let candidates dir = + List.concat_map + (fun sub -> + List.map + (fun name -> List.fold_left Filename.concat dir (sub @ [ name ])) + portable_names) + portable_subs + in + let rec level dir n = + if n = 0 + then "" + else ( + match List.find_opt is_file (candidates dir) with + | Some p -> p + | None -> + let parent = Filename.dirname dir in + if parent = dir then "" else level parent (n - 1)) + in + level base 4 +;; + +(** PATH lookup for [name]. Splits on both [:] and [;] so fakes stay + platform-independent. *) +let find_on_path ~getenv ~is_file (name : string) : string = + let raw = + match getenv "PATH" with + | None -> "" + | Some p -> p + in + let dirs = + String.split_on_char ':' raw + |> List.concat_map (String.split_on_char ';') + |> List.filter (fun d -> d <> "") + in + match List.find_opt (fun d -> is_file (Filename.concat d name)) dirs with + | None -> "" + | Some d -> Filename.concat d name +;; + +(** True when [path] answers [--version] with exit 0, or prints anything + at all (some builds emit the version to stderr with a non-zero exit; + those count too). *) +let winget_runs ~spawn (path : string) : bool = + if path = "" + then false + else ( + let out, ok = spawn path [ "--version" ] in + ok || String.trim out <> "") +;; + +(** Resolve the Store app-execution alias through [cmd], which understands + it where [stat]/PATH lookup cannot. First probed-runnable line + mentioning [winget] wins. *) +let resolve_via_cmd ~spawn : string = + let out, ok = spawn "cmd" [ "/c"; "where"; "winget" ] in + if not ok + then "" + else ( + let rec go = function + | [] -> "" + | line :: rest -> + let line = String.trim line in + if line = "" + then go rest + else if + Strutil.contains_substring "winget" (String.lowercase_ascii line) + && winget_runs ~spawn line + then line + else go rest + in + go (String.split_on_char '\n' out)) +;; + +(** Full resolution chain. Returns [""] when nothing runs. *) +let resolve (io : io) : string = + let from_cwd = + match io.cwd () with + | Error _ -> "" + | Ok d -> find_portable ~is_file:io.is_file d + in + if from_cwd <> "" + then from_cwd + else ( + let from_exe = + match io.exe_dir () with + | Error _ -> "" + | Ok exe -> + let p = find_portable ~is_file:io.is_file exe in + if p <> "" + then p + else ( + (* Exe-adjacent [winget/] subfolder: subsumed by the walk-up in + practice, kept as a fallback. *) + let wing = Filename.concat (Filename.concat exe "winget") in + let w = wing "winget.exe" in + if io.is_file w + then w + else ( + let a = wing "AppInstaller.exe" in + if io.is_file a then a else "")) + in + if from_exe <> "" + then from_exe + else ( + let looked = find_on_path ~getenv:io.getenv ~is_file:io.is_file "winget" in + if looked <> "" + then looked + else ( + let via = resolve_via_cmd ~spawn:io.spawn in + if via <> "" + then via + else ( + let local = + match io.getenv "LOCALAPPDATA" with + | None | Some "" -> "" + | Some la -> + Filename.concat + (Filename.concat (Filename.concat la "Microsoft") "WindowsApps") + "winget.exe" + in + if local <> "" && winget_runs ~spawn:io.spawn local + then local + else ( + let cached = Filename.concat (io.cache_dir ()) "AppInstaller.exe" in + if io.is_file cached then cached else ""))))) +;; + +let cert_markers = + [ "x509"; "unknown authority"; "certificate"; "80072f0d"; "InternetOpenUrl"; "CERT_" ] +;; + +(** True when [msg] indicates a TLS/certificate failure, including + winget's WinHTTP code [0x80072f0d]. *) +let is_cert_error (msg : string) : bool = + List.exists (fun sub -> Strutil.contains_substring sub msg) cert_markers +;; + +let cert_advice = + "This looks like a TLS/proxy certificate error (0x80072f0d).\n" + ^ "Import your proxy's CA into the Windows Trusted Root store\n" + ^ "so winget's WinHTTP can validate it." +;; + +(** First asset whose name ends in [.msixbundle] (case-insensitive). *) +let find_msixbundle (rel : Gh.release) : Gh.asset option = + let suf = ".msixbundle" in + List.find_opt + (fun (a : Gh.asset) -> + let n = String.lowercase_ascii a.Gh.name in + String.length n >= String.length suf + && String.sub n (String.length n - String.length suf) (String.length suf) = suf) + rel.Gh.assets +;; + +(** Pull the x64 [.msix] out of a bundle into a temp file, then unzip it + into [dest_dir]. Entry match: contains [x64], ends [.msix], + case-insensitive, first wins. *) +let extract_bundle (io : io) (bundle_path : string) (dest_dir : string) + : (unit, string) result + = + let read_all path = + try + let ic = open_in_bin path in + let n = in_channel_length ic in + let b = Bytes.create n in + really_input ic b 0 n; + close_in ic; + Ok b + with + | Sys_error msg -> Error ("open bundle: " ^ msg) + in + match read_all bundle_path with + | Error _ as e -> e + | Ok b -> + (match Zipx.list_entries b with + | Error _ as e -> e + | Ok entries -> + let is_x64_msix (e : Zipx.entry) = + let n = String.lowercase_ascii e.Zipx.name in + Strutil.contains_substring "x64" n + && String.length n >= 5 + && String.sub n (String.length n - 5) 5 = ".msix" + in + (match List.find_opt is_x64_msix entries with + | None -> Error "no x64 .msix found in bundle" + | Some e -> + (match Zipx.extract_entry b e with + | Error _ as err -> err + | Ok payload -> + let tmp = Filename.temp_file "devkit-msix-" ".msix" in + let written = + try + let oc = open_out_bin tmp in + output_bytes oc payload; + close_out oc; + Ok () + with + | Sys_error msg -> Error msg + in + (match written with + | Error _ as err -> + (try Sys.remove tmp with + | _ -> ()); + err + | Ok () -> + let r = io.unzip ~zip:tmp ~dir:dest_dir in + (try Sys.remove tmp with + | _ -> ()); + r)))) +;; + +(** Download the latest winget-cli bundle and unpack it into the cache + dir. The temp download is removed afterwards. *) +let download_winget (io : io) : (string, string) result = + match io.latest_winget_cli () with + | Error e -> Error ("fetch winget-cli release: " ^ e) + | Ok rel -> + (match find_msixbundle rel with + | None -> Error ("no .msixbundle found in winget-cli " ^ rel.Gh.tag_name) + | Some asset -> + (match io.download ~url:asset.Gh.browser_download_url with + | Error e -> Error ("download: " ^ e) + | Ok path -> + let cleanup () = + (try Sys.remove path with + | _ -> ()); + try Unix.rmdir (Filename.dirname path) with + | _ -> () + in + let r = + match io.mkdir_p (io.cache_dir ()) with + | Error e -> Error ("cache dir: " ^ e) + | Ok () -> + (match extract_bundle io path (io.cache_dir ()) with + | Error e -> Error ("extract: " ^ e) + | Ok () -> + let exe = Filename.concat (io.cache_dir ()) "AppInstaller.exe" in + (* The user asked for winget, so the error names it. *) + if io.is_file exe + then Ok exe + else Error "winget.exe not found after extraction") + in + cleanup (); + r)) +;; + +(** Human byte count. *) +let format_size (bytes : int64) : string = + if bytes >= 1_073_741_824L + then Printf.sprintf "%.1f GB" (Int64.to_float bytes /. 1_073_741_824.0) + else if bytes >= 1_048_576L + then Printf.sprintf "%.1f MB" (Int64.to_float bytes /. 1_048_576.0) + else if bytes >= 1_024L + then Printf.sprintf "%.1f KB" (Int64.to_float bytes /. 1_024.0) + else Printf.sprintf "%Ld B" bytes +;; + +(** Memoized {!resolve}: the (slow, window-spawning) probe runs once; the + miss ([None]→[""]) is cached too. Fresh instances via {!make_path_cache} + keep tests isolated. *) +let make_path_cache () = + let cell : string option ref = ref None in + let get (io : io) : string = + match !cell with + | Some p -> p + | None -> + let p = resolve io in + cell := Some p; + p + in + get, fun () -> cell := None +;; + +let cached_path, reset_path_cache = make_path_cache () + +(** Locate winget, downloading it when nothing resolves. A non-empty + [~override_path] (the [# winget:] directive) is returned blindly: no + existence check. *) +let ensure_full ~override_path ~resolve_path (io : io) : (string, string) result = + if override_path <> "" + then Ok override_path + else ( + let w = resolve_path io in + if w <> "" + then Ok w + else ( + match download_winget io with + | Ok _ as ok -> ok + | Error e -> if is_cert_error e then Error (e ^ "\n" ^ cert_advice) else Error e)) +;; + +let ensure ~override_path (io : io) : (string, string) result = + ensure_full ~override_path ~resolve_path:cached_path io +;; diff --git a/lib/bootstrap.mli b/lib/bootstrap.mli new file mode 100644 index 0000000..eb2d536 --- /dev/null +++ b/lib/bootstrap.mli @@ -0,0 +1,52 @@ +(** winget location, portable bootstrap and download. *) + +type spawn = string -> string list -> string * bool + +(** Real backend on top of [Unix.open_process_args_in]. *) +val real_spawn : spawn + +(** Injected OS surface. Tests fake the filesystem/spawns; production uses + {!real_io}. *) +type io = + { getenv : string -> string option + ; is_file : string -> bool + ; spawn : spawn + ; cwd : unit -> (string, string) result + ; exe_dir : unit -> (string, string) result + ; mkdir_p : string -> (unit, string) result + ; cache_dir : unit -> string + ; latest_winget_cli : unit -> (Gh.release, string) result + ; download : url:string -> (string, string) result + ; unzip : zip:string -> dir:string -> (unit, string) result + } + +(** Production wiring: curl fetcher, digestif verifier, central-dir zip reader. *) +val real_io : Fetch.fetch -> io + +val find_portable : is_file:(string -> bool) -> string -> string + +val find_on_path + : getenv:(string -> string option) + -> is_file:(string -> bool) + -> string + -> string + +val winget_runs : spawn:spawn -> string -> bool +val resolve_via_cmd : spawn:spawn -> string +val resolve : io -> string +val is_cert_error : string -> bool +val cert_advice : string +val find_msixbundle : Gh.release -> Gh.asset option +val download_winget : io -> (string, string) result +val format_size : int64 -> string +val make_path_cache : unit -> (io -> string) * (unit -> unit) + +(** Locate winget, downloading it when nothing resolves. A non-empty + [~override_path] is returned blindly. *) +val ensure_full + : override_path:string + -> resolve_path:(io -> string) + -> io + -> (string, string) result + +val ensure : override_path:string -> io -> (string, string) result diff --git a/lib/dashboard.ml b/lib/dashboard.ml new file mode 100644 index 0000000..2128ff4 --- /dev/null +++ b/lib/dashboard.ml @@ -0,0 +1,264 @@ +(** Dashboard: merging scan results with the manifest, plus plain-text render. + + The [winget show] cross-reference in [build_sections] spawns processes; + here it is an injectable [?show] function ([None] by default) so the + merge stays pure and testable. *) + +open Pkgfile + +type app = + { name : string + ; version : string + ; pm : string + } + +let status_symbol = function + | Installed -> "✓" + | NeedsUpdate -> "!" + | NotFound -> "+" + | Manual -> "~" + | New -> "?" +;; + +(* NOTE: [New] renders as [?]. Whether "Newly detected" deserves its own + symbol is an open nit (like the hidden-section question below). *) + +let format_ver (it : item) : string = + if it.installed_version = "" + then if it.available_version <> "" then " " ^ it.available_version else "" + else if it.available_version <> "" && it.installed_version <> it.available_version + then " " ^ it.installed_version ^ " -> " ^ it.available_version + else " " ^ it.installed_version +;; + +(** Merge the machine scan with manifest sections into dashboard sections: + 1. "Pending updates": manifest items needing update, plus + non-manifest installed apps that have an Available version. + 2. "Newly detected": other installed apps missing from the manifest. + 3. The manifest sections minus their updated items. + A manifest section literally named "winget" is dropped (it is a + leftover artifact, never real content). *) +let build_sections + ?(show : string -> string option = fun _ -> None) + (apps : app list) + (pkgs_sections : section list) + (winget_info : Winget_parse.info Winget_parse.IdMap.t option) + : section list + = + let lower s = String.lowercase_ascii s in + let scan_lookup : (string, app) Hashtbl.t = Hashtbl.create 64 in + List.iter (fun a -> Hashtbl.replace scan_lookup (lower a.name) a) apps; + let info_of name = + match winget_info with + | None -> None + | Some m -> Winget_parse.IdMap.find_opt (lower name) m + in + (* 1. Pre-set status for manifest items. *) + let pkgs_sections = + List.map + (fun sec -> + { sec with + items = + List.map + (fun it -> + let name = lower it.value in + let it = + match Hashtbl.find_opt scan_lookup name with + | Some a -> + { it with installed_version = a.version; status = Installed } + | None -> it + in + let it = + match it.typ with + | Winget -> + (match info_of name with + | Some inf -> + let it = { it with installed_version = inf.version } in + if inf.available <> "" && inf.version <> inf.available + then + { it with + available_version = inf.available + ; status = NeedsUpdate + } + else { it with status = Installed } + | None -> { it with status = NotFound }) + | GitHub | Url -> { it with status = Manual } + in + let it = + if it.status <> Installed && it.status <> NeedsUpdate + then ( + match Hashtbl.find_opt scan_lookup name with + | Some a -> + { it with installed_version = a.version; status = Installed } + | None -> it) + else it + in + if it.typ = Winget && it.status = Installed + then ( + match info_of name with + | Some inf when inf.available <> "" && inf.version <> inf.available -> + { it with available_version = inf.available; status = NeedsUpdate } + | _ -> it) + else it) + sec.items + }) + pkgs_sections + in + (* 2. `winget show` fallback for NotFound winget items (sequential here; + Go fans out to 8 workers; parallelism can return if this proves slow). *) + let pkgs_sections = + List.map + (fun sec -> + { sec with + items = + List.map + (fun it -> + if it.typ <> Winget || it.status <> NotFound + then it + else ( + match show it.value with + | None -> it + | Some ver -> + let it = { it with available_version = ver } in + let name = lower it.value in + (match Hashtbl.find_opt scan_lookup name with + | Some a -> + { it with + installed_version = a.version + ; status = (if a.version <> ver then NeedsUpdate else Installed) + } + | None -> it))) + sec.items + }) + pkgs_sections + in + (* 3. Non-manifest installed apps with updates → pending updates. *) + let value_in_manifest name = + List.exists + (fun sec -> List.exists (fun it -> lower it.value = name) sec.items) + pkgs_sections + in + let man_updates = ref [] in + (match winget_info with + | None -> () + | Some m -> + let ids = + Winget_parse.IdMap.fold (fun k _ acc -> k :: acc) m [] |> List.sort String.compare + in + List.iter + (fun id -> + let inf = Winget_parse.IdMap.find id m in + if inf.available = "" || inf.version = inf.available + then () + else if value_in_manifest (lower id) + then () + else ( + let pkg_id = if inf.id = "" then id else inf.id in + man_updates + := { typ = Winget + ; value = pkg_id + ; installed_version = inf.version + ; available_version = inf.available + ; status = NeedsUpdate + } + :: !man_updates)) + ids); + (* 4. Split manifest updates out, preserving name and order. *) + let man_rest = ref [] in + List.iter + (fun sec -> + let rest_items = ref [] in + List.iter + (fun it -> + if it.status = NeedsUpdate + then man_updates := it :: !man_updates + else rest_items := it :: !rest_items) + sec.items; + let rest_items = List.rev !rest_items in + if rest_items <> [] then man_rest := { sec with items = rest_items } :: !man_rest) + pkgs_sections; + (* NOTE: man_updates is accumulated in reverse in steps 3 and 4. Go appends + non-manifest updates first, then manifest updates in section order; + reversing once at the end reproduces exactly that. *) + let man_updates = List.rev !man_updates in + (* 5. Newly-detected installed apps. *) + let pkg_names : (string, unit) Hashtbl.t = Hashtbl.create 64 in + List.iter + (fun sec -> + List.iter (fun it -> Hashtbl.replace pkg_names (lower it.value) ()) sec.items) + pkgs_sections; + let new_items = ref [] in + (match winget_info with + | None -> () + | Some m -> + let ids = + Winget_parse.IdMap.fold (fun k _ acc -> k :: acc) m [] |> List.sort String.compare + in + List.iter + (fun id -> + if Hashtbl.mem pkg_names (lower id) + then () + else ( + let inf = Winget_parse.IdMap.find id m in + let pkg_id = if inf.id = "" then id else inf.id in + if + String.contains pkg_id '\t' + || Strutil.contains_double_space pkg_id + || Strutil.contains_substring "ARP\\" pkg_id + then () + else ( + let avail = + if inf.available <> "" && inf.version <> inf.available + then inf.available + else "" + in + new_items + := { typ = Winget + ; value = pkg_id + ; installed_version = inf.version + ; available_version = avail + ; status = New + } + :: !new_items))) + ids); + let new_items = List.rev !new_items in + (* 6. Final order, minus the raw "winget" artifact section. + man_rest was consed in section order, so it is reversed back here. *) + let sections : section list ref = ref [] in + if man_updates <> [] + then sections := [ { name = "Pending updates"; items = (man_updates : item list) } ]; + if new_items <> [] + then sections := !sections @ [ { name = "Newly detected"; items = new_items } ]; + sections := !sections @ List.rev !man_rest; + List.filter + (fun (sec : section) -> String.lowercase_ascii sec.name <> "winget") + !sections +;; + +(** Plain-text dashboard, copyable with the terminal's native scroll. + Empty sections and "Newly detected" are skipped, including the + hidden-section wart (open nit: show vs drop). *) +let render (sections : section list) : string = + let buf = Buffer.create 256 in + Buffer.add_string buf "DEVKIT\n"; + Buffer.add_string buf "! update + not installed ~ manual\n\n"; + List.iter + (fun sec -> + if sec.items = [] || String.lowercase_ascii sec.name = "newly detected" + then () + else ( + Buffer.add_string buf (String.uppercase_ascii sec.name ^ "\n"); + List.iter + (fun it -> + Buffer.add_string + buf + (Printf.sprintf + " [%s] %s%s\n" + (status_symbol it.status) + it.value + (format_ver it))) + sec.items; + Buffer.add_char buf '\n')) + sections; + Buffer.contents buf +;; diff --git a/lib/dashboard.mli b/lib/dashboard.mli new file mode 100644 index 0000000..d943b59 --- /dev/null +++ b/lib/dashboard.mli @@ -0,0 +1,23 @@ +(** Dashboard: merging scan results with the manifest, plus plain-text render. *) + +type app = + { name : string + ; version : string + ; pm : string + } + +val format_ver : Pkgfile.item -> string + +(** Merge the machine scan with manifest sections into dashboard sections: + "Pending updates", "Newly detected", then the manifest sections minus + their updated items. [show] enriches NotFound winget items via + [winget show]. *) +val build_sections + : ?show:(string -> string option) + -> app list + -> Pkgfile.section list + -> Winget_parse.info Winget_parse.IdMap.t option + -> Pkgfile.section list + +(** Plain-text dashboard. Empty sections and "Newly detected" are skipped. *) +val render : Pkgfile.section list -> string diff --git a/lib/dune b/lib/dune new file mode 100644 index 0000000..9058a9b --- /dev/null +++ b/lib/dune @@ -0,0 +1,4 @@ +(library + (name devkit) + (libraries unix yojson digestif.c decompress.de sexplib re) + (modules pkgfile winget_parse dashboard proc inventory strutil fetch hash gh zipx bootstrap install app winget_json plugin)) diff --git a/lib/fetch.ml b/lib/fetch.ml new file mode 100644 index 0000000..0660048 --- /dev/null +++ b/lib/fetch.ml @@ -0,0 +1,25 @@ +(** HTTP fetching. + + OCaml has no stock HTTPS client, and pulling in cohttp/Lwt would clash + with the no-Lwt notty choice, so production fetching shells out to + [curl]: inbox on Windows 10 1803+ and present on most Linux systems. + The call shape stays injectable: tests and future backends substitute + [fetch]. *) + +(** [fetch url headers] performs GET [url] with [headers] ([name, value] + pairs), returning the response body. API calls get 15s ([?timeout_s]); + bulk downloads are unbounded. *) +type fetch = ?timeout_s:int -> string -> (string * string) list -> (string, string) result + +(** curl backend: [-fsSL], caller-supplied timeout, headers via [-H]. *) +let curl_fetch (run : Proc.runner) : fetch = + fun ?(timeout_s = 0) url headers -> + let args = + [ "-fsSL"; url ] + @ (if timeout_s > 0 then [ "--max-time"; string_of_int timeout_s ] else []) + @ List.concat_map (fun (k, v) -> [ "-H"; k ^ ": " ^ v ]) headers + in + match run "curl" args with + | Some body -> Ok body + | None -> Error ("curl failed: " ^ url) +;; diff --git a/lib/fetch.mli b/lib/fetch.mli new file mode 100644 index 0000000..e051d8e --- /dev/null +++ b/lib/fetch.mli @@ -0,0 +1,8 @@ +(** HTTP fetching via an injectable backend. *) + +(** [fetch url headers] performs GET [url] with [headers] ([name, value] + pairs), returning the response body. *) +type fetch = ?timeout_s:int -> string -> (string * string) list -> (string, string) result + +(** curl backend: [-fsSL], caller-supplied timeout, headers via [-H]. *) +val curl_fetch : Proc.runner -> fetch diff --git a/lib/gh.ml b/lib/gh.ml new file mode 100644 index 0000000..7f13f2c --- /dev/null +++ b/lib/gh.ml @@ -0,0 +1,88 @@ +(** GitHub releases API. + + HTTP goes through an injectable {!Fetch.fetch}; JSON through yojson. + Sends [GH_TOKEN] bearer auth and a [devkit/1.0] user agent. *) + +type asset = + { name : string + ; browser_download_url : string + ; size : int64 + } + +type release = + { tag_name : string + ; assets : asset list + } + +let asset_of_yojson (j : Yojson.Basic.t) : asset = + let open Yojson.Basic.Util in + { name = j |> member "name" |> to_string_option |> Option.value ~default:"" + ; browser_download_url = + j |> member "browser_download_url" |> to_string_option |> Option.value ~default:"" + ; size = + j + |> member "size" + |> to_int_option + |> Option.map Int64.of_int + |> Option.value ~default:0L + } +;; + +let release_of_yojson (j : Yojson.Basic.t) : release = + let open Yojson.Basic.Util in + { tag_name = j |> member "tag_name" |> to_string_option |> Option.value ~default:"" + ; assets = j |> member "assets" |> to_list |> List.map asset_of_yojson + } +;; + +let parse_release (body : string) : (release, string) result = + try Ok (release_of_yojson (Yojson.Basic.from_string body)) with + | Yojson.Json_error msg -> Error ("decode: " ^ msg) +;; + +(** Latest release for [owner/repo]. *) +let latest_release (fetch : Fetch.fetch) (repo : string) : (release, string) result = + let url = Printf.sprintf "https://api.github.com/repos/%s/releases/latest" repo in + let headers = + [ "Accept", "application/vnd.github+json"; "User-Agent", "devkit/1.0" ] + @ + match Sys.getenv_opt "GH_TOKEN" with + | None | Some "" -> [] + | Some tok -> [ "Authorization", "Bearer " ^ tok ] + in + match fetch ~timeout_s:15 url headers with + | Error e -> Error e + | Ok body -> parse_release body +;; + +(** Pick the best Windows installer asset: prefer arch-tagged + (amd64/x64/x86_64) Windows builds, fall back to any .exe/.msi. *) +let match_by_arch (assets : asset list) : asset option = + let lower s = String.lowercase_ascii s in + let ext name = + match String.rindex_opt name '.' with + | None -> "" + | Some i -> String.sub name i (String.length name - i) |> lower + in + let is_win (a : asset) = + let name = lower a.name in + let e = ext a.name in + Strutil.contains_substring "windows" name + || Strutil.contains_substring "win" name + || e = ".exe" + || e = ".msi" + in + let archs = [ "amd64"; "x64"; "x86_64" ] in + let has_arch (a : asset) = + let name = lower a.name in + List.exists (fun arch -> Strutil.contains_substring arch name) archs + in + match List.find_opt (fun a -> is_win a && has_arch a) assets with + | Some _ as hit -> hit + | None -> + List.find_opt + (fun (a : asset) -> + let e = ext a.name in + e = ".exe" || e = ".msi") + assets +;; diff --git a/lib/gh.mli b/lib/gh.mli new file mode 100644 index 0000000..b06ae5a --- /dev/null +++ b/lib/gh.mli @@ -0,0 +1,21 @@ +(** GitHub releases API. *) + +type asset = + { name : string + ; browser_download_url : string + ; size : int64 + } + +type release = + { tag_name : string + ; assets : asset list + } + +(** Latest release for [owner/repo]. *) +val parse_release : string -> (release, string) result + +val latest_release : Fetch.fetch -> string -> (release, string) result + +(** Pick the best Windows installer asset: prefer arch-tagged Windows + builds, fall back to any .exe/.msi. *) +val match_by_arch : asset list -> asset option diff --git a/lib/hash.ml b/lib/hash.ml new file mode 100644 index 0000000..3d80011 --- /dev/null +++ b/lib/hash.ml @@ -0,0 +1,94 @@ +(** SHA-256 file hashing and verification (digestif backend). + + Verification is explicit: [verify_file] takes the expected hex digest + and reports a mismatch as an error. Callers that genuinely have no + hash (winget bundle, GitHub assets) say so via [No_expected]. *) + +type expectation = + | No_expected + | Hex of string + +(** SHA-256 hex digest of a file's contents. *) +let sha256_file (path : string) : (string, string) result = + try + let ic = open_in_bin path in + let finally () = close_in_noerr ic in + let h = ref Digestif.SHA256.empty in + try + let buf = Bytes.create 65536 in + let rec loop () = + let n = input ic buf 0 65536 in + if n = 0 + then () + else ( + h := Digestif.SHA256.feed_bytes !h buf ~off:0 ~len:n; + loop ()) + in + loop (); + finally (); + Ok (Digestif.SHA256.to_hex (Digestif.SHA256.get !h)) + with + | e -> + finally (); + Error (Printexc.to_string e) + with + | Sys_error msg -> Error msg +;; + +(** Compare [expected] against [path]'s digest. [No_expected] passes (with + the caller's knowledge); [Hex ""] is rejected: an empty hash never + verifies, closing the Go hole where [""] silently skipped the check. *) +let verify_file (expected : expectation) (path : string) : (unit, string) result = + match expected with + | No_expected -> Ok () + | Hex "" -> Error "refusing to verify against an empty hash" + | Hex want -> + (match sha256_file path with + | Error e -> Error e + | Ok got -> + if String.lowercase_ascii got = String.lowercase_ascii want + then Ok () + else Error (Printf.sprintf "hash mismatch: expected %s, got %s" want got)) +;; + +(** Download [url] into a fresh temp dir, verify, return the file path. + Filename comes from the URL's last segment (query string stripped: + keeping it would produce names like [x.msix?a=b]). *) +let download_and_verify (fetch : Fetch.fetch) (expectation : expectation) (url : string) + : (string, string) result + = + let base = + match String.rindex_opt url '/' with + | None -> "download" + | Some i -> + let tail = String.sub url (i + 1) (String.length url - i - 1) in + (match String.index_opt tail '?' with + | None -> tail + | Some q -> String.sub tail 0 q) + in + let base = if base = "" then "download" else base in + let dir = Filename.temp_dir "devkit-" "" in + let path = Filename.concat dir base in + match fetch url [] with + | Error e -> Error e + | Ok body -> + (try + let oc = open_out_bin path in + output_string oc body; + close_out oc; + Ok () + with + | Sys_error msg -> Error msg) + |> (function + | Error e -> Error e + | Ok () -> + (match verify_file expectation path with + | Ok () -> Ok path + | Error e -> + (try + Sys.remove path; + Unix.rmdir dir + with + | _ -> ()); + Error e)) +;; diff --git a/lib/hash.mli b/lib/hash.mli new file mode 100644 index 0000000..0b7f5c1 --- /dev/null +++ b/lib/hash.mli @@ -0,0 +1,15 @@ +(** SHA-256 file hashing and verification. *) + +type expectation = + | No_expected + | Hex of string + +(** SHA-256 hex digest of a file's contents. *) +val sha256_file : string -> (string, string) result + +(** Compare [expected] against [path]'s digest. [No_expected] passes; + [Hex ""] is rejected. *) +val verify_file : expectation -> string -> (unit, string) result + +(** Download [url] into a fresh temp dir, verify, return the file path. *) +val download_and_verify : Fetch.fetch -> expectation -> string -> (string, string) result diff --git a/lib/install.ml b/lib/install.ml new file mode 100644 index 0000000..fec6dc5 --- /dev/null +++ b/lib/install.ml @@ -0,0 +1,195 @@ +(** App install/update dispatch. + + Status strings are [installed], [updated], [opened], [skip], [error]. + Flag sets: [winget install --id … -e] with both [--accept-…] plus + [--silent], [winget upgrade --id …] with both accepts, and the [.exe] + installer receiving all three silent switches in one invocation. + + Design notes: + + - Winget failures read [winget failed: ]: + {!Bootstrap.spawn} reports only output + ok, without the OS exit + error. + - [open_browser] waits for the opener to exit. A browser that + daemonizes returns at once either way; a missing opener surfaces + here instead of silently succeeding. + - The empty-hash hole (hash computed, never checked) is closed by + construction: {!deps.download} is [Hash.download_and_verify] with an + explicit [No_expected]. *) + +(** Outcome of installing one app. *) +type status = + | Installed + | Updated + | Opened + | Skipped of string + | Failed of string + +let status_to_string = function + | Installed -> "installed" + | Updated -> "updated" + | Opened -> "opened" + | Skipped _ -> "skip" + | Failed _ -> "error" +;; + +type outcome = + { value : string + ; status : status + } + +let succeed value status = { value; status } +let fail value msg = { value; status = Failed msg } + +(** Injected surface. {!real_deps} wires production backends. *) +type deps = + { winget : unit -> string + ; spawn : Bootstrap.spawn + ; open_browser : string -> (unit, string) result + ; latest_release : string -> (Gh.release, string) result + ; download : url:string -> (string, string) result + ; run_installer : string -> (unit, string) result + ; tools : Plugin.tool list + } + +(** Run a downloaded installer: [.msi] via [msiexec], [.exe] with silent + switches, anything else refused. Extension match is case-insensitive. *) +let run_installer (spawn : Bootstrap.spawn) (path : string) : (unit, string) result = + let ext = String.lowercase_ascii (Filename.extension path) in + match ext with + | ".msi" -> + (match spawn "msiexec" [ "/i"; path; "/quiet"; "/norestart" ] with + | _, true -> Ok () + | out, false -> Error ("msiexec failed: " ^ out)) + | ".exe" -> + (match spawn path [ "/S"; "/silent"; "/verysilent" ] with + | _, true -> Ok () + | out, false -> Error ("installer failed: " ^ out)) + | _ -> Error ("unsupported installer type: " ^ ext) +;; + +(** Open [url] in the default browser: [cmd /c start] on Windows, [open] + on macOS, [xdg-open] elsewhere. macOS is detected with [uname -s] + through [spawn], keeping the function testable. *) +let real_open_browser (spawn : Bootstrap.spawn) (url : string) : (unit, string) result = + let prog, args = + if Sys.win32 + then "cmd", [ "/c"; "start"; ""; url ] + else ( + let uname, ok = spawn "uname" [ "-s" ] in + if ok && String.trim uname = "Darwin" then "open", [ url ] else "xdg-open", [ url ]) + in + match spawn prog args with + | _, true -> Ok () + | out, false -> Error ("open browser failed: " ^ out) +;; + +(** Non-zero winget exits that still mean success (already-installed + readings, matched case-sensitively). *) +let already_markers = [ "already installed"; "No newer package versions are available" ] + +let install_winget (d : deps) (id : string) (update : bool) : outcome = + let w = d.winget () in + if w = "" + then fail id "winget unavailable" + else ( + let args = + if update + then + [ "upgrade" + ; "--id" + ; id + ; "--accept-package-agreements" + ; "--accept-source-agreements" + ] + else + [ "install" + ; "--id" + ; id + ; "-e" + ; "--accept-package-agreements" + ; "--accept-source-agreements" + ; "--silent" + ] + in + let out, ok = d.spawn w args in + let done_status = if update then Updated else Installed in + if ok + then succeed id done_status + else if List.exists (fun m -> Strutil.contains_substring m out) already_markers + then succeed id done_status + else fail id ("winget " ^ String.concat " " args ^ " failed: " ^ String.trim out)) +;; + +let install_github (d : deps) (repo : string) : outcome = + match d.latest_release repo with + | Error e -> fail repo e + | Ok rel -> + (match Gh.match_by_arch rel.Gh.assets with + | None -> + (* No Windows installer asset: open the release page instead. *) + let page = "https://github.com/" ^ repo ^ "/releases/latest" in + (match d.open_browser page with + | Ok () -> succeed repo Opened + | Error e -> fail repo e) + | Some asset -> + (match d.download ~url:asset.Gh.browser_download_url with + | Error e -> fail repo e + | Ok path -> + (match d.run_installer path with + | Ok () -> succeed repo Installed + | Error e -> fail repo e))) +;; + +(** Install/update via a plugin tool's command template. Only [{id}] + is substituted (install takes no version). A missing template or a + failed spawn is a [Failed] outcome rather than a skip. *) +let install_plugin (d : deps) (t : Plugin.tool) (id : string) (update : bool) : outcome = + let kind = if update then "upgrade" else "install" in + match if update then t.upgrade else t.install with + | None -> fail id (t.name ^ " has no " ^ kind ^ " template") + | Some argv -> + (match Plugin.expand [ "id", id ] argv with + | Error e -> fail id e + | Ok [] -> fail id (t.name ^ ": empty " ^ kind ^ " template") + | Ok (prog :: args) -> + (match d.spawn prog args with + | _, true -> succeed id (if update then Updated else Installed) + | out, false -> fail id (t.name ^ " " ^ kind ^ " failed: " ^ String.trim out))) +;; + +(** Dispatch an install/update for one manifest entry. [kind] is one of + ["winget"], ["github"], ["url"], a plugin tool name, or anything + else (a skip). winget keeps its special path (already-installed + readings); its plugin entry only documents the equivalent command. *) +let install (d : deps) (kind : string) (value : string) (update : bool) : outcome = + match kind with + | "winget" -> install_winget d value update + | "github" -> install_github d value + | "url" -> + (match d.open_browser value with + | Ok () -> succeed value Opened + | Error e -> fail value e) + | other -> + (match Plugin.find other d.tools with + | None -> { value; status = Skipped ("unsupported type \"" ^ other ^ "\"") } + | Some t -> install_plugin d t value update) +;; + +(** Production wiring: resolve winget via {!Bootstrap} (empty string when + unavailable), curl fetcher, real spawns. *) +let real_deps (fetch : Fetch.fetch) ~winget_override () : deps = + let io = Bootstrap.real_io fetch in + { winget = + (fun () -> + match Bootstrap.ensure ~override_path:winget_override io with + | Ok p -> p + | Error _ -> "") + ; spawn = Bootstrap.real_spawn + ; open_browser = real_open_browser Bootstrap.real_spawn + ; latest_release = Gh.latest_release fetch + ; download = (fun ~url -> Hash.download_and_verify fetch Hash.No_expected url) + ; run_installer = run_installer Bootstrap.real_spawn + ; tools = Inventory.built_ins + } +;; diff --git a/lib/install.mli b/lib/install.mli new file mode 100644 index 0000000..a29bcb7 --- /dev/null +++ b/lib/install.mli @@ -0,0 +1,34 @@ +(** Package installation across winget, GitHub releases and plain URLs. *) + +type status = + | Installed + | Updated + | Opened + | Skipped of string + | Failed of string + +val status_to_string : status -> string + +type outcome = + { value : string + ; status : status + } + +(** Injected surface. {!real_deps} wires production backends. *) +type deps = + { winget : unit -> string + ; spawn : Bootstrap.spawn + ; open_browser : string -> (unit, string) result + ; latest_release : string -> (Gh.release, string) result + ; download : url:string -> (string, string) result + ; run_installer : string -> (unit, string) result + ; tools : Plugin.tool list + } + +(** Run a downloaded installer: [.msi] via [msiexec], [.exe] with silent + switches, anything else refused. *) +val run_installer : Bootstrap.spawn -> string -> (unit, string) result + +val real_open_browser : Bootstrap.spawn -> string -> (unit, string) result +val install : deps -> string -> string -> bool -> outcome +val real_deps : Fetch.fetch -> winget_override:string -> unit -> deps diff --git a/lib/inventory.ml b/lib/inventory.ml new file mode 100644 index 0000000..65fb414 --- /dev/null +++ b/lib/inventory.ml @@ -0,0 +1,268 @@ +(** Inventory scanners: installed-software discovery per package manager. + + Every scanner takes a {!Proc.runner} and every parser is pure over + captured output, so tests feed fixtures without spawning processes. + + Parser edge cases (each tested): + - pipx versions lose their trailing comma. + - cargo versions lose the ["vX.Y.Z:"] trailing colon. + - uv ([uv tool list]) scans like pipx. *) + +open Dashboard + +let fields (line : string) : string list = + let parts = String.split_on_char ' ' line in + let parts = List.concat_map (String.split_on_char '\t') parts in + List.filter (fun s -> s <> "" && s <> "\r") parts +;; + +(** Trim [cut] characters from both ends. Mirrors [strings.Trim]. *) +let trim_cutset (cut : string) (s : string) : string = + let is_cut c = String.contains cut c in + let n = String.length s in + let i = ref 0 in + while !i < n && is_cut s.[!i] do + incr i + done; + let j = ref (n - 1) in + while !j >= !i && is_cut s.[!j] do + decr j + done; + if !j < !i then "" else String.sub s !i (!j - !i + 1) +;; + +let lines_of output = String.split_on_char '\n' output + +(** npm tree-drawing prefixes, all U+2500-block (E2 94 xx) plus space. *) +let is_npm_glyph_lead s i = + let n = String.length s in + i + 2 < n + 1 + && Char.code s.[i] = 0xE2 + && Char.code s.[i + 1] = 0x94 + && + let t = Char.code s.[i + 2] in + t >= 0x80 && t <= 0xAC +;; + +let s_is_space s i = s.[i] = ' ' || s.[i] = '\t' || s.[i] = '\r' + +let strip_npm_prefix (line : string) : string = + let n = String.length line in + let i = ref 0 in + let cont = ref true in + while !cont && !i < n do + if s_is_space line !i + then incr i + else if is_npm_glyph_lead line !i + then i := !i + 3 + else cont := false + done; + String.trim (String.sub line !i (n - !i)) +;; + +(** [npm list -g --depth=0]: tree rows, split on the LAST [@] so scoped + packages ([@scope/name@1.2.3]) survive. *) +let parse_npm (output : string) : app list = + List.filter_map + (fun raw -> + let line = strip_npm_prefix (String.trim raw) in + if line = "" || not (String.contains line '@') + then None + else ( + match String.rindex_opt line '@' with + | None -> None + | Some at -> + let name = String.trim (String.sub line 0 at) in + let version = + String.trim (String.sub line (at + 1) (String.length line - at - 1)) + in + if name = "" || version = "" then None else Some { name; version; pm = "npm" })) + (lines_of output) +;; + +(** [pipx list --short]: [name version …] rows. *) +let parse_pipx (output : string) : app list = + List.filter_map + (fun raw -> + match fields (String.trim raw) with + | [] -> None + | [ name ] -> + let name = trim_cutset "," name in + if name = "" then None else Some { name; version = ""; pm = "pipx" } + | name :: ver :: _ -> + let name = trim_cutset "," name in + if name = "" + then None + else Some { name; version = trim_cutset "()," ver; pm = "pipx" }) + (lines_of output) +;; + +(** [uv tool list]: [name vX.Y.Z] headers with [- exe] shim lines beneath. + [Failed to parse entry …] warnings are skipped. *) +let parse_uv (output : string) : app list = + List.filter_map + (fun raw -> + let line = String.trim raw in + if line = "" || line.[0] = '-' || Strutil.contains_substring "Failed to parse" line + then None + else ( + match fields line with + | [ name; ver ] when name <> "" -> + let version = + if String.length ver > 0 && ver.[0] = 'v' + then String.sub ver 1 (String.length ver - 1) + else ver + in + Some { name; version; pm = "uv" } + | _ -> None)) + (lines_of output) +;; + +(** [cargo install --list]: [name vX.Y.Z:] rows, detail lines indented. *) +let parse_cargo (output : string) : app list = + List.filter_map + (fun raw -> + match fields (String.trim raw) with + | name :: ver :: _ when name <> "" -> + let ver = + ver + |> (fun s -> + if String.length s > 0 && s.[String.length s - 1] = ':' + then String.sub s 0 (String.length s - 1) + else s) + |> trim_cutset "v" + in + Some { name; version = ver; pm = "cargo" } + | _ -> None) + (lines_of output) +;; + +(** winget rows via {!Winget_parse}; the Go scanner keys these by id and so + do we ([Name] is the id column). Sorted by id for deterministic output. + Go preserved winget's row order, but every consumer only needs lookup. *) +let parse_winget (output : string) : app list = + let m = Winget_parse.parse_list_table output in + Winget_parse.IdMap.fold + (fun _ (inf : Winget_parse.info) acc -> + { name = inf.id; version = inf.version; pm = "winget" } :: acc) + m + [] + |> List.sort (fun a b -> String.compare a.name b.name) +;; + +(** The five built-ins as plugin entries, so custom tools and built-ins + share one type: scan programs, row parsers and install/upgrade + templates in one place. Scan order is the list order. winget keeps + its memoized-fetch path in {!scan_all} (a raw [run] would spawn a + window per call); its entry documents the equivalent commands. + + Templates float to latest (no [{version}] yet; install takes no + version). cargo has no upgrade command ([cargo-update] is a + third-party plugin), hence [upgrade = None]. *) +let npm_tool : Plugin.tool = + { name = "npm" + ; prog = "npm" + ; list_args = [ "list"; "-g"; "--depth=0" ] + ; install = Some [ "npm"; "install"; "-g"; "{id}" ] + ; upgrade = Some [ "npm"; "update"; "-g"; "{id}" ] + ; parse = parse_npm + } +;; + +let pipx_tool : Plugin.tool = + { name = "pipx" + ; prog = "pipx" + ; list_args = [ "list"; "--short" ] + ; install = Some [ "pipx"; "install"; "{id}" ] + ; upgrade = Some [ "pipx"; "upgrade"; "{id}" ] + ; parse = parse_pipx + } +;; + +let uv_tool : Plugin.tool = + { name = "uv" + ; prog = "uv" + ; list_args = [ "tool"; "list" ] + ; install = Some [ "uv"; "tool"; "install"; "{id}" ] + ; upgrade = Some [ "uv"; "tool"; "upgrade"; "{id}" ] + ; parse = parse_uv + } +;; + +let cargo_tool : Plugin.tool = + { name = "cargo" + ; prog = "cargo" + ; list_args = [ "install"; "--list" ] + ; install = Some [ "cargo"; "install"; "{id}" ] + ; upgrade = None + ; parse = parse_cargo + } +;; + +let winget_tool : Plugin.tool = + { name = "winget" + ; prog = "winget" + ; list_args = [ "list"; "--accept-source-agreements"; "--verbose" ] + ; install = + Some + [ "winget" + ; "install" + ; "--id" + ; "{id}" + ; "-e" + ; "--accept-package-agreements" + ; "--accept-source-agreements" + ; "--silent" + ] + ; upgrade = + Some + [ "winget" + ; "upgrade" + ; "--id" + ; "{id}" + ; "--accept-package-agreements" + ; "--accept-source-agreements" + ] + ; parse = parse_winget + } +;; + +(** All built-ins in scan order. *) +let built_ins : Plugin.tool list = + [ winget_tool; npm_tool; pipx_tool; uv_tool; cargo_tool ] +;; + +(** Names that custom tools may not take (shadowing would silently + change a built-in scan). *) +let reserved_names : string list = List.map (fun (t : Plugin.tool) -> t.name) built_ins + +(** Run one plugin tool: missing binary (or failure) means skipped, as + with every built-in scanner. *) +let scan_tool (run : Proc.runner) (t : Plugin.tool) : app list = + match run t.prog t.list_args with + | None -> [] + | Some out -> t.parse out +;; + +(** Full scan order: winget, npm, pipx, uv, cargo, then [extra] custom + tools in file order. [winget] is the memoized [winget list] fetch + ([Proc.winget_list]), so a scan followed by an update check spawns + winget once per window. *) +let scan_all + (run : Proc.runner) + ~(winget : unit -> string option) + ~(extra : Plugin.tool list) + : app list + = + let winget_apps = + match winget () with + | None -> [] + | Some out -> parse_winget out + in + let apps = + List.concat_map + (fun (t : Plugin.tool) -> scan_tool run t) + [ npm_tool; pipx_tool; uv_tool; cargo_tool ] + in + winget_apps @ apps @ List.concat_map (scan_tool run) extra +;; diff --git a/lib/inventory.mli b/lib/inventory.mli new file mode 100644 index 0000000..4489039 --- /dev/null +++ b/lib/inventory.mli @@ -0,0 +1,24 @@ +(** Inventory scanners: installed-software discovery per package manager. *) + +val parse_npm : string -> Dashboard.app list +val parse_pipx : string -> Dashboard.app list +val parse_uv : string -> Dashboard.app list +val parse_cargo : string -> Dashboard.app list +val parse_winget : string -> Dashboard.app list + +(** Full scan order: winget, npm, pipx, uv, cargo, then [extra] custom + tools in file order. [winget] is the memoized [winget list] fetch. *) +val scan_all + : Proc.runner + -> winget:(unit -> string option) + -> extra:Plugin.tool list + -> Dashboard.app list + +(** The five built-ins as plugin entries (scan order). *) +val built_ins : Plugin.tool list + +(** Names custom tools may not take. *) +val reserved_names : string list + +(** Run one plugin tool; missing binary means skipped. *) +val scan_tool : Proc.runner -> Plugin.tool -> Dashboard.app list diff --git a/lib/pkgfile.ml b/lib/pkgfile.ml new file mode 100644 index 0000000..e790203 --- /dev/null +++ b/lib/pkgfile.ml @@ -0,0 +1,105 @@ +(** Manifest (pkgs.txt) parsing. + + The manifest is a sequence of [# Section] headers, [type:value] items + and an optional [# winget: ] directive. Parsing is total and + pure: unknown lines are skipped. *) + +type item_type = + | Winget + | GitHub + | Url + +type status = + | Installed + | NeedsUpdate + | NotFound + | New + | Manual + +type item = + { typ : item_type + ; value : string + ; installed_version : string + ; available_version : string + ; status : status + } + +type section = + { name : string + ; items : item list + } + +type parse_result = + { sections : section list + ; winget_path : string + } + +let make_item typ value = + { typ + ; value + ; installed_version = "" + ; available_version = "" + ; (* Fresh items carry [NotFound]; statuses are assigned later by the + merge step. *) + status = NotFound + } +;; + +let starts_with ~prefix s = + let n = String.length prefix in + String.length s >= n && String.sub s 0 n = prefix +;; + +(** [parse text] parses a pkgs.txt manifest. *) +let parse (text : string) : parse_result = + let sections = ref [] in + let winget_path = ref "" in + let push_item it = + match List.rev !sections with + | [] -> sections := [ { name = "General"; items = [ it ] } ] + | last :: rest -> + sections := List.rev ({ last with items = last.items @ [ it ] } :: rest) + in + let lines = String.split_on_char '\n' text in + List.iter + (fun raw -> + let line = String.trim raw in + if line = "" + then () + else if starts_with ~prefix:"#" line + then ( + let rest = String.trim (String.sub line 1 (String.length line - 1)) in + if starts_with ~prefix:"winget:" (String.lowercase_ascii rest) + then ( + let p = String.trim (String.sub rest 7 (String.length rest - 7)) in + if p <> "" + then winget_path := p + (* NOTE: a [# winget:]-with-empty-path falls through to become a + section, exactly like the Go original. *) + else sections := !sections @ [ { name = rest; items = [] } ]) + else if rest <> "" + then sections := !sections @ [ { name = rest; items = [] } ]) + else ( + match String.index_opt line ':' with + | None -> () + | Some colon -> + let prefix = String.lowercase_ascii (String.trim (String.sub line 0 colon)) in + let value = + String.trim (String.sub line (colon + 1) (String.length line - colon - 1)) + in + if value = "" + then () + else ( + let typ = + match prefix with + | "winget" -> Some Winget + | "github" -> Some GitHub + | "url" -> Some Url + | _ -> None + in + match typ with + | None -> () + | Some typ -> push_item (make_item typ value)))) + lines; + { sections = !sections; winget_path = !winget_path } +;; diff --git a/lib/pkgfile.mli b/lib/pkgfile.mli new file mode 100644 index 0000000..b100877 --- /dev/null +++ b/lib/pkgfile.mli @@ -0,0 +1,34 @@ +(** Manifest (pkgs.txt) parsing. *) + +type item_type = + | Winget + | GitHub + | Url + +type status = + | Installed + | NeedsUpdate + | NotFound + | New + | Manual + +type item = + { typ : item_type + ; value : string + ; installed_version : string + ; available_version : string + ; status : status + } + +type section = + { name : string + ; items : item list + } + +type parse_result = + { sections : section list + ; winget_path : string + } + +val make_item : item_type -> string -> item +val parse : string -> parse_result diff --git a/lib/plugin.ml b/lib/plugin.ml new file mode 100644 index 0000000..5eef560 --- /dev/null +++ b/lib/plugin.ml @@ -0,0 +1,360 @@ +(** User-defined package-manager tools. + + A tool is a named program devkit can scan (like the built-in npm, + pipx, uv and cargo support) plus optional install/upgrade command + templates. Tools live in s-expression files: [tools.sexp] next to + [pkgs.txt] first, then the user config dir: the first file wins per + tool name, and a custom tool may not shadow a built-in name. + + File format: + + {v + (tools + (tool + (name mytool) + (prog mytool) + (list --list --short) + (skip_prefixes ("- " "WARN")) + (skip_res ("^\\s*$")) + (row_re "^(\\S+)\\s+v?([0-9][^ ]*)") + (strip_version_prefix v) + (install (mytool install {id})) + (upgrade (mytool upgrade {id})))) + v} + + Only [name], [prog] and [row_re] are required. [row_re] is a PCRE + with group 1 = tool name, group 2 = version (optional: a missing + group means unversioned). Unknown fields are rejected, so a + misspelled key is an error rather than a silent behavior change. + S-expression [; comments] are allowed. + + Template variables: [{id}] only. Anything else in braces is an + error at install time. *) + +open Sexplib.Sexp + +(** How to read [name]/[version] rows out of a tool's list output. *) +type row_spec = + { skip_prefixes : string list + ; skip_res : Re.re list + ; row_re : Re.re + ; strip_version_prefix : string + } + +(** A package-manager tool: scan program plus optional install/upgrade + templates. [parse] turns list output into apps tagged with [name]. *) +type tool = + { name : string + ; prog : string + ; list_args : string list + ; install : string list option + ; upgrade : string list option + ; parse : string -> Dashboard.app list + } + +let starts_with ~prefix s = + let n = String.length prefix in + String.length s >= n && String.sub s 0 n = prefix +;; + +let strip_prefix ~prefix s = + if prefix <> "" && starts_with ~prefix s + then String.sub s (String.length prefix) (String.length s - String.length prefix) + else s +;; + +(** Row matching: blank lines, prefix/re skips, then [row_re] group 1/2. + Lines that match nothing are ignored (like every built-in parser). *) +let parse_rows (spec : row_spec) (pm : string) (output : string) : Dashboard.app list = + let lines = String.split_on_char '\n' output in + List.filter_map + (fun raw -> + let line = String.trim raw in + if line = "" + then None + else if List.exists (fun p -> starts_with ~prefix:p line) spec.skip_prefixes + then None + else if List.exists (fun re -> Re.execp re line) spec.skip_res + then None + else ( + match Re.exec_opt spec.row_re line with + | None -> None + | Some g -> + (match Re.Group.get g 1 with + | exception Not_found -> None + | "" -> None + | name -> + let version = + match Re.Group.get g 2 with + | exception Not_found -> "" + | v -> strip_prefix ~prefix:spec.strip_version_prefix v + in + Some { Dashboard.name; version; pm }))) + lines +;; + +(** Expand [{key}] placeholders from [vars]. Unknown or unclosed + placeholders are errors; they never pass through as literal text. *) +let expand (vars : (string * string) list) (argv : string list) + : (string list, string) result + = + let expand_arg arg = + let buf = Buffer.create (String.length arg) in + let n = String.length arg in + let rec go i = + if i >= n + then Ok (Buffer.contents buf) + else if arg.[i] = '{' + then ( + match String.index_from_opt arg (i + 1) '}' with + | None -> Error ("unclosed '{' in template: " ^ arg) + | Some j -> + let key = String.sub arg (i + 1) (j - i - 1) in + (match List.assoc_opt key vars with + | None -> Error ("unknown placeholder {" ^ key ^ "} in template: " ^ arg) + | Some v -> + Buffer.add_string buf v; + go (j + 1))) + else ( + Buffer.add_char buf arg.[i]; + go (i + 1)) + in + go 0 + in + let rec go acc = function + | [] -> Ok (List.rev acc) + | a :: rest -> + (match expand_arg a with + | Error _ as e -> e + | Ok s -> go (s :: acc) rest) + in + go [] argv +;; + +(* s-expression loading: errors surface, nothing is skipped silently. *) + +type fields = (string * string list) list + +let err source ctx msg = Error (Printf.sprintf "%s: %s: %s" source ctx msg) + +(** Split [(key value...)] entries; a bare atom value counts as one item, + and a single nested list counts as the item list (so [(list a b)] + and [(list (a b))] mean the same thing). Deeper nesting is rejected. *) +let assoc_of_sexp ~source ~ctx (sxp : t) : (fields, string) result = + let value_strings v = + match v with + | Atom s -> Ok [ s ] + | List items -> + let rec go acc = function + | [] -> Ok (List.rev acc) + | Atom s :: rest -> go (s :: acc) rest + | List _ :: _ -> err source ctx "expected atom or flat list" + in + go [] items + in + match sxp with + | Atom _ -> err source ctx "expected (key value ...) entries" + | List items -> + let rec go acc = function + | [] -> Ok (List.rev acc) + | List (Atom k :: vs) :: rest -> + let vs = + match vs with + | [ List inner ] -> inner + | _ -> vs + in + (match value_strings (List vs) with + | Error _ as e -> e + | Ok ss -> go ((k, ss) :: acc) rest) + | _ :: _ -> err source ctx "expected (key value ...) entries" + in + go [] items +;; + +let allowed_keys = + [ "name" + ; "prog" + ; "list" + ; "skip_prefixes" + ; "skip_res" + ; "row_re" + ; "strip_version_prefix" + ; "install" + ; "upgrade" + ] +;; + +let one ~source ~ctx key (fields : fields) : (string option, string) result = + match List.assoc_opt key fields with + | None -> Ok None + | Some [ s ] -> Ok (Some s) + | Some _ -> err source ctx (key ^ ": expected a single value") +;; + +let many key (fields : fields) : string list = + match List.assoc_opt key fields with + | None -> [] + | Some ss -> ss +;; + +let compile_re ~source ~ctx pattern = + try Ok (Re.compile (Re.Pcre.re pattern)) with + | e -> err source ctx ("bad regex " ^ pattern ^ ": " ^ Printexc.to_string e) +;; + +let compile_many ~source ~ctx patterns = + let rec go acc = function + | [] -> Ok (List.rev acc) + | p :: rest -> + (match compile_re ~source ~ctx p with + | Error _ as e -> e + | Ok re -> go (re :: acc) rest) + in + go [] patterns +;; + +let tool_of_sexp ~source ~index (sxp : t) : (tool, string) result = + let ctx = "tool #" ^ string_of_int index in + match sxp with + | Atom _ -> err source ctx "expected (tool ...)" + | List (Atom "tool" :: rest) -> + (match assoc_of_sexp ~source ~ctx (List rest) with + | Error _ as e -> e + | Ok fields -> + (match List.find_opt (fun (k, _) -> not (List.mem k allowed_keys)) fields with + | Some (k, _) -> err source ctx ("unknown field: " ^ k) + | None -> + let ctx = + match List.assoc_opt "name" fields with + | Some [ n ] -> "tool " ^ n + | _ -> ctx + in + (match one ~source ~ctx "name" fields, one ~source ~ctx "prog" fields with + | Ok (Some name), Ok (Some prog) when name <> "" && prog <> "" -> + (match one ~source ~ctx "row_re" fields with + | Ok (Some pattern) -> + (match compile_re ~source ~ctx pattern with + | Error _ as e -> e + | Ok row_re -> + (match compile_many ~source ~ctx (many "skip_res" fields) with + | Error _ as e -> e + | Ok skip_res -> + (match one ~source ~ctx "strip_version_prefix" fields with + | Error _ as e -> e + | Ok strip_opt -> + let spec = + { skip_prefixes = many "skip_prefixes" fields + ; skip_res + ; row_re + ; strip_version_prefix = Option.value strip_opt ~default:"" + } + in + let opt = function + | [] -> None + | ss -> Some ss + in + Ok + { name + ; prog + ; list_args = many "list" fields + ; install = opt (many "install" fields) + ; upgrade = opt (many "upgrade" fields) + ; parse = parse_rows spec name + }))) + | Ok None -> err source ctx "missing required field: row_re" + | Error _ as e -> e) + | Ok _, Ok _ -> err source ctx "missing required fields: name and prog" + | (Error _ as e), _ | _, (Error _ as e) -> e))) + | List _ -> err source ctx "expected (tool ...)" +;; + +(** Parse one whole file. The [(tools ...)] wrapper is required. *) +let load_string ~source (text : string) : (tool list, string) result = + let sxp = + try Ok (Sexplib.Sexp.of_string text) with + | e -> err source "file" ("parse error: " ^ Printexc.to_string e) + in + match sxp with + | Error _ as e -> e + | Ok (List (Atom "tools" :: rest)) -> + let rec go i acc = function + | [] -> Ok (List.rev acc) + | s :: tl -> + (match tool_of_sexp ~source ~index:i s with + | Error _ as e -> e + | Ok t -> go (i + 1) (t :: acc) tl) + in + go 1 [] rest + | Ok _ -> err source "file" "expected (tools (tool ...) ...)" +;; + +(** A missing file means no custom tools; a broken one is an error. *) +let load_file ~read path : (tool list, string) result = + match read path with + | None -> Ok [] + | Some text -> load_string ~source:path text +;; + +let lower s = String.lowercase_ascii s + +(** Load several files in order (cwd first, config second); the first + file wins per tool name. [reserved] names (built-ins) are rejected, + since shadowing a built-in would silently change its scan. *) +let load_many ~read ?(reserved : string list = []) (paths : string list) + : (tool list, string) result + = + let reserved = List.map lower reserved in + let rec go acc = function + | [] -> Ok (List.rev acc) + | p :: rest -> + (match load_file ~read p with + | Error _ as e -> e + | Ok tools -> + let rec add acc = function + | [] -> Ok acc + | t :: tl -> + let n = lower t.name in + if List.mem n reserved + then Error (p ^ ": tool " ^ t.name ^ " shadows a built-in") + else if List.exists (fun u -> lower u.name = n) acc + then add acc tl + else add (t :: acc) tl + in + (match add acc tools with + | Error _ as e -> e + | Ok acc -> go acc rest)) + in + go [] paths +;; + +(** Case-insensitive lookup. *) +let find (name : string) (tools : tool list) : tool option = + List.find_opt (fun t -> lower t.name = lower name) tools +;; + +(** Config-file slot: [$XDG_CONFIG_HOME/devkit], [$HOME/.config/devkit], + [%LOCALAPPDATA%/devkit] on Windows, else nothing. *) +let config_file () : string option = + match Sys.getenv_opt "XDG_CONFIG_HOME" with + | Some d when d <> "" -> + Some (Filename.concat (Filename.concat d "devkit") "tools.sexp") + | _ -> + (match Sys.getenv_opt "HOME" with + | Some h when h <> "" -> + Some + (Filename.concat + (Filename.concat (Filename.concat h ".config") "devkit") + "tools.sexp") + | _ -> + (match Sys.getenv_opt "LOCALAPPDATA" with + | Some l when l <> "" -> + Some (Filename.concat (Filename.concat l "devkit") "tools.sexp") + | _ -> None)) +;; + +(** Search order: [tools.sexp] next to [pkgs.txt], then the config file. *) +let default_paths () : string list = + match config_file () with + | None -> [ "tools.sexp" ] + | Some c -> [ "tools.sexp"; c ] +;; diff --git a/lib/plugin.mli b/lib/plugin.mli new file mode 100644 index 0000000..d594601 --- /dev/null +++ b/lib/plugin.mli @@ -0,0 +1,49 @@ +(** User-defined package-manager tools ([tools.sexp]). *) + +(** How to read [name]/[version] rows out of a tool's list output. *) +type row_spec = + { skip_prefixes : string list + ; skip_res : Re.re list + ; row_re : Re.re + ; strip_version_prefix : string + } + +(** A package-manager tool: scan program plus optional install/upgrade + templates. [parse] turns list output into apps tagged with [name]. *) +type tool = + { name : string + ; prog : string + ; list_args : string list + ; install : string list option + ; upgrade : string list option + ; parse : string -> Dashboard.app list + } + +val parse_rows : row_spec -> string -> string -> Dashboard.app list + +(** Expand [{key}] placeholders from [vars]; unknown or unclosed + placeholders are errors. *) +val expand : (string * string) list -> string list -> (string list, string) result + +val tool_of_sexp : source:string -> index:int -> Sexplib.Sexp.t -> (tool, string) result + +(** Parse one whole [(tools ...)] file. *) +val load_string : source:string -> string -> (tool list, string) result + +(** A missing file means no custom tools; a broken one is an error. + [read] is the file reader (injected for tests). *) +val load_file : read:(string -> string option) -> string -> (tool list, string) result + +(** Load several files in order; first file wins per tool name. Tools + named in [reserved] (built-ins) are rejected. *) +val load_many + : read:(string -> string option) + -> ?reserved:string list + -> string list + -> (tool list, string) result + +(** Case-insensitive lookup. *) +val find : string -> tool list -> tool option + +val config_file : unit -> string option +val default_paths : unit -> string list diff --git a/lib/proc.ml b/lib/proc.ml new file mode 100644 index 0000000..4150a44 --- /dev/null +++ b/lib/proc.ml @@ -0,0 +1,52 @@ +(** Process execution with an injectable runner. + + All inventory scanners take a [runner] so tests feed canned output + without spawning processes. There is no timeout on spawned commands. *) + +(** [runner prog args] runs [prog] with [args], returning stdout trimmed on + success, [None] when the program is missing or exits non-zero. *) +type runner = string -> string list -> string option + +(** Real runner on top of [Unix.open_process_args_in]. *) +let default_runner : runner = + fun prog args -> + try + let cmd = Array.of_list (prog :: args) in + let ic = Unix.open_process_args_in prog cmd in + let buf = Buffer.create 256 in + (try + while true do + Buffer.add_channel buf ic 4096 + done + with + | End_of_file -> ()); + let out = Buffer.contents buf in + match Unix.close_process_in ic with + | Unix.WEXITED 0 -> Some (String.trim out) + | _ -> None + with + | _ -> None +;; + +(** Memoized [winget list --verbose] fetcher with resetter. The + inventory scan and the update check share one [winget list] + invocation per 8s window, so refresh ticks never pop extra winget + windows. [resolve] is the winget executable located by the caller; + empty falls back to PATH lookup. *) +let winget_list (run : runner) : (string -> string option) * (unit -> unit) = + let cache : (string, string * float) Hashtbl.t = Hashtbl.create 4 in + let ttl = 8.0 in + let fetch resolved = + let now = Unix.gettimeofday () in + match Hashtbl.find_opt cache resolved with + | Some (out, at) when now -. at < ttl -> Some out + | _ -> + let prog = if resolved = "" then "winget" else resolved in + (match run prog [ "list"; "--accept-source-agreements"; "--verbose" ] with + | None -> None + | Some out -> + Hashtbl.replace cache resolved (out, now); + Some out) + in + fetch, fun () -> Hashtbl.clear cache +;; diff --git a/lib/proc.mli b/lib/proc.mli new file mode 100644 index 0000000..c34c1f6 --- /dev/null +++ b/lib/proc.mli @@ -0,0 +1,12 @@ +(** Process execution with an injectable runner. *) + +(** [runner prog args] runs [prog] with [args], returning stdout trimmed on + success, [None] when the program is missing or exits non-zero. *) +type runner = string -> string list -> string option + +(** Real runner on top of [Unix.open_process_args_in]. *) +val default_runner : runner + +(** Memoized [winget list --verbose] fetcher with resetter: one winget + invocation per 8s window per resolved path. *) +val winget_list : runner -> (string -> string option) * (unit -> unit) diff --git a/lib/strutil.ml b/lib/strutil.ml new file mode 100644 index 0000000..ac5668d --- /dev/null +++ b/lib/strutil.ml @@ -0,0 +1,27 @@ +(** Small shared string predicates. *) + +(** True when [sub] occurs in [s]. Empty [sub] matches. *) +let contains_substring (sub : string) (s : string) : bool = + let m = String.length sub + and n = String.length s in + if m = 0 + then true + else if m > n + then false + else ( + let found = ref false in + for i = 0 to n - m do + if String.sub s i m = sub then found := true + done; + !found) +;; + +(** True when [s] contains two consecutive spaces. *) +let contains_double_space (s : string) : bool = + let n = String.length s in + let found = ref false in + for i = 0 to n - 2 do + if s.[i] = ' ' && s.[i + 1] = ' ' then found := true + done; + !found +;; diff --git a/lib/strutil.mli b/lib/strutil.mli new file mode 100644 index 0000000..5d53bf6 --- /dev/null +++ b/lib/strutil.mli @@ -0,0 +1,7 @@ +(** Small shared string predicates. *) + +(** True when [sub] occurs in [s]. Empty [sub] matches. *) +val contains_substring : string -> string -> bool + +(** True when [s] contains two consecutive spaces. *) +val contains_double_space : string -> bool diff --git a/lib/winget_json.ml b/lib/winget_json.ml new file mode 100644 index 0000000..ad19b72 --- /dev/null +++ b/lib/winget_json.ml @@ -0,0 +1,59 @@ +(** winget import-compatible JSON export. + + Mirrors what [winget export -o] emits (schema + [aka.ms/winget-packages.schema.2.0.json]) so [devkit export] output can + be restored natively with [winget import -i]. Only winget-tracked apps + are included; npm/pipx/uv/cargo rows have no winget id and are + skipped. Versions are always the installed ones ([--include-versions] + behavior); [winget import --ignore-versions] floats them when wanted. + The timestamp is injected ([?now]) to keep this pure and testable. *) + +open Dashboard + +(** SourceDetails verbatim from a real [winget export] on Windows. *) +let source_details = + `Assoc + [ "Name", `String "winget" + ; "Identifier", `String "Microsoft.Winget.Source_8wekyb3d8bbwe" + ; "Argument", `String "https://cdn.winget.microsoft.com/cache" + ; "Type", `String "Microsoft.PreIndexed.Package" + ] +;; + +let iso8601_utc (t : float) : string = + let tm = Unix.gmtime t in + Printf.sprintf + "%04d-%02d-%02dT%02d:%02d:%02d.000-00:00" + (tm.Unix.tm_year + 1900) + (tm.Unix.tm_mon + 1) + tm.Unix.tm_mday + tm.Unix.tm_hour + tm.Unix.tm_min + tm.Unix.tm_sec +;; + +let to_json ?(now : float = Unix.gettimeofday ()) (apps : app list) : Yojson.Basic.t = + let pkgs = + List.filter_map + (fun (a : app) -> + if a.pm = "winget" && a.name <> "" + then ( + let fields = + ("PackageIdentifier", `String a.name) + :: (if a.version <> "" then [ "Version", `String a.version ] else []) + in + Some (`Assoc fields)) + else None) + apps + in + `Assoc + [ "$schema", `String "https://aka.ms/winget-packages.schema.2.0.json" + ; "CreationDate", `String (iso8601_utc now) + ; ( "Sources" + , `List [ `Assoc [ "SourceDetails", source_details; "Packages", `List pkgs ] ] ) + ] +;; + +let to_string ?now (apps : app list) : string = + Yojson.Basic.pretty_to_string (to_json ?now apps) ^ "\n" +;; diff --git a/lib/winget_json.mli b/lib/winget_json.mli new file mode 100644 index 0000000..1b04c9e --- /dev/null +++ b/lib/winget_json.mli @@ -0,0 +1,4 @@ +(** winget import-compatible JSON export. *) + +val to_json : ?now:float -> Dashboard.app list -> Yojson.Basic.t +val to_string : ?now:float -> Dashboard.app list -> string diff --git a/lib/winget_parse.ml b/lib/winget_parse.ml new file mode 100644 index 0000000..f1797a6 --- /dev/null +++ b/lib/winget_parse.ml @@ -0,0 +1,137 @@ +(** Parsing of [winget list --verbose] table output. + + Rows split on runs of 2+ spaces, which handles both the aligned + terminal output and the compact piped output devkit actually + captures. *) + +type info = + { id : string (** Original-case id; case-sensitive for [winget install --id]. *) + ; name : string + ; version : string + ; available : string + } + +module IdMap = Map.Make (String) + +let is_blank = function + | ' ' | '\t' | '\r' -> true + | _ -> false +;; + +(** Split a row on runs of 2+ blanks. Single blanks inside names + (e.g. ["7-Zip 26.00 (x64)"]) survive. *) +let split_cols (line : string) : string list = + let n = String.length line in + let cols = ref [] in + let cur = Buffer.create 32 in + let flush () = + let s = String.trim (Buffer.contents cur) in + Buffer.clear cur; + if s <> "" then cols := s :: !cols + in + let i = ref 0 in + while !i < n do + if is_blank line.[!i] + then ( + let j = ref !i in + while !j < n && is_blank line.[!j] do + incr j + done; + if !j - !i >= 2 then flush () else Buffer.add_char cur ' '; + i := !j) + else ( + Buffer.add_char cur line.[!i]; + incr i) + done; + flush (); + List.rev !cols +;; + +(** Third bytes (after E2 94) of the accepted box-drawing code points: + ─ │ ┬ ┴ ┼ ├ ┤ ┌ ┐ └ ┘. *) +let box_thirds = [ 0x80; 0x82; 0xAC; 0xB4; 0xBC; 0x9C; 0xA4; 0x8C; 0x90; 0x94; 0x98 ] + +(** Separator lines: dashes, blanks or box-drawing characters. *) +let is_winget_separator (line : string) : bool = + let n = String.length line in + if n = 0 + then false + else ( + let i = ref 0 in + let ok = ref true in + while !ok && !i < n do + let c = line.[!i] in + if c = '-' || is_blank c + then incr i + else if + Char.code c = 0xE2 + && !i + 2 <= n - 1 + && Char.code line.[!i + 1] = 0x94 + && List.mem (Char.code line.[!i + 2]) box_thirds + then i := !i + 3 + else ok := false + done; + !ok) +;; + +(** Version-ish token: contains an ASCII digit. "Unknown" and source names + ("winget"/"msstore") have none and are excluded. Go uses Unicode digits; + winget emits ASCII versions. *) +let looks_like_version (s : string) : bool = + let found = ref false in + String.iter (fun c -> if c >= '0' && c <= '9' then found := true) s; + !found +;; + +(** Id column by pattern: dotted, has a letter, no spaces/backslash/braces. + Go additionally requires no tabs; tabs cannot survive {!split_cols}. *) +let is_id_col (col : string) : bool = + String.contains col '.' + && (not (String.contains col '\\')) + && (not (String.contains col '{')) + && (not (String.contains col ' ')) + && + let has_letter = ref false in + String.iter + (fun c -> if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') then has_letter := true) + col; + !has_letter +;; + +let is_header cols = List.exists (fun c -> String.lowercase_ascii c = "id") cols + +(** Parse [winget list --verbose] output into a map keyed by lowercase id. *) +let parse_list_table (output : string) : info IdMap.t = + let rows = String.split_on_char '\n' output in + List.fold_left + (fun acc raw -> + let line = String.trim raw in + if line = "" || is_winget_separator line + then acc + else ( + let cols = split_cols line in + if List.length cols < 2 || is_header cols + then acc + else ( + let id_idx = List.find_index (fun c -> is_id_col c) cols in + match id_idx with + | None -> acc + | Some 0 -> acc (* need at least a Name before the Id *) + | Some k -> + let id = List.nth cols k in + let name = List.filteri (fun i _ -> i < k) cols |> String.concat " " in + let rest = List.filteri (fun i _ -> i > k) cols in + let version = + match rest with + | v :: _ -> v + | [] -> "" + in + let available = + match rest with + | _ :: a :: _ when looks_like_version a && a <> version -> a + | _ -> "" + in + IdMap.add (String.lowercase_ascii id) { id; name; version; available } acc))) + IdMap.empty + rows +;; diff --git a/lib/winget_parse.mli b/lib/winget_parse.mli new file mode 100644 index 0000000..19f92fa --- /dev/null +++ b/lib/winget_parse.mli @@ -0,0 +1,22 @@ +(** Parsing of [winget list --verbose] table output. *) + +type info = + { id : string (** Original-case id; case-sensitive for [winget install --id]. *) + ; name : string + ; version : string + ; available : string + } + +module IdMap : Map.S with type key = string + +(** Split a row on runs of 2+ blanks. Single blanks inside names survive. *) +val split_cols : string -> string list + +(** Separator lines: dashes, blanks or box-drawing characters. *) +val is_winget_separator : string -> bool + +(** Version-ish token: contains an ASCII digit. *) +val looks_like_version : string -> bool + +(** Parse [winget list --verbose] output into a map keyed by lowercase id. *) +val parse_list_table : string -> info IdMap.t diff --git a/lib/zipx.ml b/lib/zipx.ml new file mode 100644 index 0000000..da88229 --- /dev/null +++ b/lib/zipx.ml @@ -0,0 +1,250 @@ +(** Minimal ZIP reader: stored + deflated entries, central-directory driven. + + Naive extraction joins entry names onto the destination, a ZipSlip + where entries like [../../evil.exe] or [/abs/path] escape it. This + module sanitizes every entry name with {!safe_path} before any write, + and refuses to proceed on the first unsafe entry. + + Only what the bootstrap needs is implemented: local headers are located + through the central directory (so data-descriptor entries work), methods + are stored (0) and deflated (8, via [decompress]), encryption and exotic + methods are rejected. CRCs are not rechecked: inflate integrity plus + sizes suffice for a downloader that hash-verifies the archive itself. *) + +type entry = + { name : string + ; meth : int + ; comp_size : int + ; uncomp_size : int + ; local_off : int + } + +let u16 (b : bytes) off = + Char.code (Bytes.get b off) lor (Char.code (Bytes.get b (off + 1)) lsl 8) +;; + +let u32 (b : bytes) off = u16 b off lor (u16 b (off + 2) lsl 16) +let sig_local = 0x04034B50 +let sig_central = 0x02014B50 +let sig_eocd = 0x06054B50 + +(** Locate the end-of-central-directory record by scanning backwards. *) +let find_eocd (b : bytes) : (int, string) result = + let n = Bytes.length b in + if n < 22 + then Error "too small for EOCD" + else ( + let from = max 0 (n - 22 - 65536) in + let hit = ref None in + let i = ref (n - 22) in + while !hit = None && !i >= from do + if u32 b !i = sig_eocd then hit := Some !i; + decr i + done; + match !hit with + | None -> Error "EOCD signature not found" + | Some off -> Ok off) +;; + +(** Parse the central directory into entries. *) +let list_entries (b : bytes) : (entry list, string) result = + match find_eocd b with + | Error _ as e -> e + | Ok eocd -> + let count = u16 b (eocd + 10) in + let cd_off = u32 b (eocd + 16) in + let acc = ref [] in + let off = ref cd_off in + let ok = ref true in + let err = ref "" in + let n = Bytes.length b in + for _ = 1 to count do + if !ok + then ( + let o = !off in + if o + 46 > n || u32 b o <> sig_central + then ( + ok := false; + err := "bad central directory entry") + else ( + let flags = u16 b (o + 8) in + let meth = u16 b (o + 10) in + let comp = u32 b (o + 20) in + let uncomp = u32 b (o + 24) in + let nl = u16 b (o + 28) in + let xl = u16 b (o + 30) in + let cl = u16 b (o + 32) in + let lh = u32 b (o + 42) in + if o + 46 + nl + xl + cl > n + then ( + ok := false; + err := "central directory entry overruns archive") + else ( + let name = Bytes.sub_string b (o + 46) nl in + if flags land 0x1 <> 0 + then ( + ok := false; + err := "encrypted entry: " ^ name) + else ( + acc + := { name; meth; comp_size = comp; uncomp_size = uncomp; local_off = lh } + :: !acc; + off := o + 46 + nl + xl + cl)))) + done; + if !ok then Ok (List.rev !acc) else Error !err +;; + +(** Raw DEFLATE (no zlib wrapper) via [decompress]. *) +let inflate_raw (data : bytes) : (bytes, string) result = + let w = De.make_window ~bits:15 in + let i = De.bigstring_create De.io_buffer_size in + let o = De.bigstring_create De.io_buffer_size in + let pos = ref 0 in + let len = Bytes.length data in + let refill buf = + let n = min De.io_buffer_size (len - !pos) in + for k = 0 to n - 1 do + buf.{k} <- Bytes.get data (!pos + k) + done; + pos := !pos + n; + n + in + let out = Buffer.create 4096 in + let flush buf n = + for k = 0 to n - 1 do + Buffer.add_char out buf.{k} + done + in + match De.Higher.uncompress ~w ~refill ~flush i o with + | Ok () -> Ok (Buffer.to_bytes out) + | Error (`Msg msg) -> Error ("inflate: " ^ msg) +;; + +(** Entry payload from its local header. *) +let extract_entry (b : bytes) (e : entry) : (bytes, string) result = + let n = Bytes.length b in + let o = e.local_off in + if o + 30 > n || u32 b o <> sig_local + then Error "bad local header" + else ( + let nl = u16 b (o + 26) in + let xl = u16 b (o + 28) in + let start = o + 30 + nl + xl in + if start + e.comp_size > n + then Error "entry overruns archive" + else ( + let raw = Bytes.sub b start e.comp_size in + match e.meth with + | 0 -> Ok raw + | 8 -> inflate_raw raw + | m -> Error (Printf.sprintf "unsupported method %d: %s" m e.name))) +;; + +(** Split a zip path on both separators (archives use [/]; hostile ones + mix in [\\], which Windows treats as a separator too). *) +let split_seps (s : string) : string list = + let s = String.map (fun c -> if c = '\\' then '/' else c) s in + String.split_on_char '/' s +;; + +(** [safe_path ~dest name] resolves [name] inside [dest], returning [None] + for anything that escapes: absolute paths, drive letters ([C:…]), UNC + ([//…]), or [..] climbing past the root. Trailing separators mark + directories, reported via [is_dir]. *) +let safe_path ~dest (name : string) : (string * bool) option = + if name = "" + then None + else ( + let is_dir = + let n = String.length name in + name.[n - 1] = '/' || name.[n - 1] = '\\' + in + let parts = split_seps name in + let absolute = + match parts with + | "" :: _ -> true (* leading / or \\ *) + | first :: _ when String.length first >= 2 && first.[1] = ':' -> true + | _ -> false + in + if absolute + then None + else ( + let stack = ref [] in + let escaped = ref false in + List.iter + (fun p -> + if p = "" || p = "." + then () + else if p = ".." + then ( + match !stack with + | [] -> escaped := true + | _ :: rest -> stack := rest) + else stack := p :: !stack) + parts; + if !escaped + then None + else ( + let rel = List.rev !stack |> String.concat Filename.dir_sep in + if rel = "" + then None (* name was only dots/slashes *) + else Some (dest ^ Filename.dir_sep ^ rel, is_dir)))) +;; + +let rec mkdir_p (dir : string) : unit = + if dir = "" || dir = "." || dir = Filename.dir_sep || Sys.file_exists dir + then () + else ( + mkdir_p (Filename.dirname dir); + try Unix.mkdir dir 0o755 with + | Unix.Unix_error (Unix.EEXIST, _, _) -> ()) +;; + +(** Extract [zip_path] into [dest_dir]. Fails fast on the first unsafe + entry. Entries before the hostile one are already written; Go wrote + the whole archive, this stops at the first hostile name and reports it. *) +let extract ~(zip_path : string) ~(dest_dir : string) : (unit, string) result = + (try + let ic = open_in_bin zip_path in + let n = in_channel_length ic in + let b = Bytes.create n in + really_input ic b 0 n; + close_in ic; + Ok b + with + | Sys_error msg -> Error msg) + |> function + | Error _ as e -> e + | Ok b -> + (match list_entries b with + | Error _ as e -> e + | Ok entries -> + let rec go = function + | [] -> Ok () + | e :: rest -> + (match safe_path ~dest:dest_dir e.name with + | None -> Error ("unsafe zip entry (ZipSlip refused): " ^ e.name) + | Some (path, is_dir) -> + if is_dir + then ( + mkdir_p path; + go rest) + else + (match extract_entry b e with + | Error _ as err -> err + | Ok payload -> + (try + mkdir_p (Filename.dirname path); + let oc = open_out_bin path in + output_bytes oc payload; + close_out oc; + Ok () + with + | Sys_error msg -> Error msg)) + |> (function + | Error _ as err -> err + | Ok () -> go rest)) + in + mkdir_p dest_dir; + go entries) +;; diff --git a/lib/zipx.mli b/lib/zipx.mli new file mode 100644 index 0000000..f4d0e6a --- /dev/null +++ b/lib/zipx.mli @@ -0,0 +1,24 @@ +(** Minimal ZIP reader: stored + deflated entries, central-directory driven. *) + +type entry = + { name : string + ; meth : int + ; comp_size : int + ; uncomp_size : int + ; local_off : int + } + +(** Parse the central directory into entries. *) +val list_entries : bytes -> (entry list, string) result + +(** Entry payload from its local header. *) +val extract_entry : bytes -> entry -> (bytes, string) result + +(** [safe_path ~dest name] resolves [name] inside [dest], returning [None] + for anything that escapes. Trailing separators mark directories. *) +val safe_path : dest:string -> string -> (string * bool) option + +val mkdir_p : string -> unit + +(** Extract [zip_path] into [dest_dir]. Fails fast on the first unsafe entry. *) +val extract : zip_path:string -> dest_dir:string -> (unit, string) result diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..5121345 --- /dev/null +++ b/test/dune @@ -0,0 +1,49 @@ +(test + (name test_pkgfile) + (libraries devkit alcotest)) + +(test + (name test_winget) + (libraries devkit alcotest)) + +(test + (name test_dashboard) + (libraries devkit alcotest)) + +(test + (name test_inventory) + (libraries devkit alcotest)) + +(test + (name test_gh) + (libraries devkit alcotest)) + +(test + (name test_hash) + (libraries devkit alcotest unix)) + +(test + (name test_zipx) + (libraries devkit alcotest unix) + (deps (source_tree fixtures))) + +(test + (name test_bootstrap) + (libraries devkit alcotest unix) + (deps (source_tree fixtures))) + +(test + (name test_install) + (libraries devkit alcotest)) + +(test + (name test_app) + (libraries devkit alcotest str yojson)) + +(test + (name test_winget_json) + (libraries devkit alcotest yojson)) + +(test + (name test_plugin) + (libraries devkit alcotest re sexplib)) diff --git a/test/fixtures/bundle.zip b/test/fixtures/bundle.zip new file mode 100644 index 0000000000000000000000000000000000000000..3b7fb2b09dd9986c03a649e6f4e9fce0e75f93eb GIT binary patch literal 825 zcmWIWW@Zs#00HL|^Vsd$;ejkbHVAV7aY}x2v0h0<35X6rQEB|9RdGR8I~Ejp<`tJD=H#Rn>7`br7IT04ezo*7 z4;LRJ1578xMIN^{RWbv0fiN!+7o`^Gmlh?b7V8xhWdb(lA1|3TPV`P#Q+oKvVFBQ6|_L^gu^XbP&gY y0v*JHB|&su=m`*^OAE-vOpdT*0*Pq!m_g|F2il4rPmq{q1}4G{K!wFjAk_eyqNX_j literal 0 HcmV?d00001 diff --git a/test/fixtures/evil.zip b/test/fixtures/evil.zip new file mode 100644 index 0000000000000000000000000000000000000000..a65049d0fe0a18499bf6afa4efc170a45dc78390 GIT binary patch literal 311 zcmWIWW@Zs#00HL|^H}%0cPg2HY!GGx;{0sAl8Tc2>;M#1eH&h=f@DFM8;JGv^i#_+ zb3jT{i<1)zQc;yJ3!JRM3{(cf96+p}m{bf>3#0Usg78a^ma z$t=>(OD!%*O#x{*?X9cl>3h-l+<9%!v)YUdFuf3afLh>y3&={%Ehwqf1(^`w&B!Fe zjN3&pZ4Hbd7TkRZZP*=$(53@qqB<3!7rWyidIcE%I%WWw$WCQt1IaN1;c6f~0mNYd E04QWSga7~l literal 0 HcmV?d00001 diff --git a/test/fixtures/nox64.zip b/test/fixtures/nox64.zip new file mode 100644 index 0000000000000000000000000000000000000000..c10e7316a2f262077c61fed44f8de71966a5e95d GIT binary patch literal 374 zcmWIWW@Zs#00HL|^VnF9xz9cT*&r+g#080!Ir)hxx`{=(W+r;M#hDcWQ1u*O^>Q{p z`B;JKn1NUTh#d;y% lKsph`0XiP$9PA+kRsJ-4v1^|aKM&AGc literal 0 HcmV?d00001 diff --git a/test/test_app.ml b/test/test_app.ml new file mode 100644 index 0000000..70d1c38 --- /dev/null +++ b/test/test_app.ml @@ -0,0 +1,236 @@ +open Devkit + +let winget_table = + "Name Id Version Available Source\n\ + --------------------------------\n\ + Git Git.Git 2.47.1 2.48.0 winget\n\ + Brave Brave.Brave 1.80.122 winget\n" +;; + +let fake_bio ?(show_out = "", false) () : Bootstrap.io = + { getenv = (fun _ -> None) + ; is_file = (fun _ -> false) + ; spawn = (fun _ _ -> show_out) + ; cwd = (fun () -> Error "no cwd") + ; exe_dir = (fun () -> Error "no exe") + ; mkdir_p = (fun _ -> Error "ro") + ; cache_dir = (fun () -> ".") + ; latest_winget_cli = (fun () -> Error "offline") + ; download = (fun ~url:_ -> Error "offline") + ; unzip = (fun ~zip:_ ~dir:_ -> Error "ro") + } +;; + +(** In-memory filesystem. *) +let mem_fs (files : (string, string) Hashtbl.t) : App.fs = + { read_file = Hashtbl.find_opt files + ; append_file = + (fun path text -> + let cur = Option.value ~default:"" (Hashtbl.find_opt files path) in + Hashtbl.replace files path (cur ^ text); + Ok ()) + ; write_file = + (fun path text -> + Hashtbl.replace files path text; + Ok ()) + } +;; + +let scan_run prog _args = + match prog with + | "winget" -> Some winget_table + | _ -> None +;; + +let env files = { App.run = scan_run; fs = mem_fs files; bio = fake_bio () } + +let contains sub s = + try + ignore (Str.search_forward (Str.regexp_string sub) s 0); + true + with + | Not_found -> false +;; + +let load_missing () = + let s, w = App.load_manifest (mem_fs (Hashtbl.create 1)) "pkgs.txt" in + Alcotest.(check int) "no sections" 0 (List.length s); + Alcotest.(check string) "no winget path" "" w +;; + +let load_parses () = + let files = Hashtbl.create 1 in + Hashtbl.add files "pkgs.txt" "# winget: C:\\w\\winget.exe\n# tools\nwinget:Git.Git\n"; + let s, w = App.load_manifest (mem_fs files) "pkgs.txt" in + Alcotest.(check string) "winget path" "C:\\w\\winget.exe" w; + Alcotest.(check int) "one section" 1 (List.length s) +;; + +let append_groups () = + let files = Hashtbl.create 1 in + let items = + [ { Pkgfile.typ = Pkgfile.Winget + ; value = "Brave.Brave" + ; installed_version = "" + ; available_version = "" + ; status = Pkgfile.New + } + ; { Pkgfile.typ = Pkgfile.Winget + ; value = "Git.Git" + ; installed_version = "" + ; available_version = "" + ; status = Pkgfile.New + } + ] + in + Alcotest.(check (result unit string)) + "ok" + (Ok ()) + (App.append_selected (mem_fs files) "pkgs.txt" items); + Alcotest.(check string) + "grouped under header" + "\n# Newly detected\nwinget:Brave.Brave\nwinget:Git.Git\n" + (Hashtbl.find files "pkgs.txt") +;; + +let append_empty () = + let files = Hashtbl.create 1 in + Alcotest.(check (result unit string)) + "ok" + (Ok ()) + (App.append_selected (mem_fs files) "pkgs.txt" []); + Alcotest.(check bool) "no write" false (Hashtbl.mem files "pkgs.txt") +;; + +let add () = + let files = Hashtbl.create 1 in + Hashtbl.add files "pkgs.txt" "# tools\nwinget:Git.Git\n"; + let msgs = App.run_add (env files) [ "Git.Git"; "Nope.Nope"; "Brave.Brave" ] in + Alcotest.(check (list string)) + "messages" + [ " skip (already in manifest): Git.Git" + ; " skip (not installed): Nope.Nope" + ; " appended 1 app(s) to pkgs.txt" + ] + msgs; + Alcotest.(check bool) + "brave persisted" + true + (contains "winget:Brave.Brave" (Hashtbl.find files "pkgs.txt")) +;; + +let add_nothing () = + let files = Hashtbl.create 1 in + let msgs = App.run_add (env files) [ "Nope.Nope" ] in + Alcotest.(check (list string)) + "nothing" + [ " skip (not installed): Nope.Nope"; " nothing to append" ] + msgs +;; + +let export () = + let files = Hashtbl.create 1 in + let msgs = App.run_export (env files) "out.txt" in + Alcotest.(check (list string)) + "messages" + [ "wrote out.txt (2 apps)"; "wrote out.json (2 winget apps, winget import -i ready)" ] + msgs; + Alcotest.(check string) + "content" + "# Generated by devkit export\n\n# winget\nwinget:Brave.Brave\nwinget:Git.Git\n" + (Hashtbl.find files "out.txt"); + let j = Yojson.Basic.from_string (Hashtbl.find files "out.json") in + let pkgs = + match j with + | `Assoc kvs -> + (match List.assoc "Sources" kvs with + | `List [ `Assoc src ] -> + (match List.assoc "Packages" src with + | `List l -> l + | _ -> []) + | _ -> []) + | _ -> [] + in + Alcotest.(check int) "json packages" 2 (List.length pkgs) +;; + +let export_empty () = + let files = Hashtbl.create 1 in + let e = { (env files) with run = (fun _ _ -> None) } in + Alcotest.(check (list string)) + "empty" + [ " no installed software found" ] + (App.run_export e "out.txt") +;; + +let export_no_winget () = + let files = Hashtbl.create 1 in + let e = + { (env files) with + run = (fun prog _ -> if prog = "npm" then Some "x@1.0.0\n" else None) + } + in + let msgs = App.run_export e "out.txt" in + Alcotest.(check bool) + "skip message" + true + (List.mem " no winget apps, json skipped" msgs); + Alcotest.(check bool) "no json file" false (Hashtbl.mem files "out.json") +;; + +let new_items () = + let mk status = + { Pkgfile.typ = Pkgfile.Winget + ; value = "x" + ; installed_version = "" + ; available_version = "" + ; status + } + in + let secs = + [ { Pkgfile.name = "Newly detected"; items = [ mk Pkgfile.New ] } + ; { Pkgfile.name = "Pending updates"; items = [ mk Pkgfile.New ] } + ] + in + Alcotest.(check int) "newly only" 1 (List.length (App.new_items secs)); + Alcotest.(check int) "with pending" 2 (List.length (App.new_items ~extra:true secs)) +;; + +let show () = + let bio = fake_bio ~show_out:("Version: 9.9\n", true) () in + Alcotest.(check string) "version" "9.9" (App.winget_show bio "w" "Some.Id"); + let bad = fake_bio () in + Alcotest.(check string) "failure" "" (App.winget_show bad "w" "Some.Id"); + Alcotest.(check string) "no winget" "" (App.winget_show bad "" "Some.Id") +;; + +let default () = + let files = Hashtbl.create 1 in + Hashtbl.add files "pkgs.txt" "# tools\nwinget:Git.Git\n"; + let s = App.default_view ~tools:[] (env files) in + Alcotest.(check bool) "mentions app" true (contains "Git.Git" s) +;; + +let () = + Alcotest.run + "app" + [ ( "manifest" + , [ Alcotest.test_case "missing" `Quick load_missing + ; Alcotest.test_case "parses" `Quick load_parses + ] ) + ; ( "append" + , [ Alcotest.test_case "groups" `Quick append_groups + ; Alcotest.test_case "empty" `Quick append_empty + ; Alcotest.test_case "new_items" `Quick new_items + ] ) + ; ( "commands" + , [ Alcotest.test_case "add" `Quick add + ; Alcotest.test_case "add_nothing" `Quick add_nothing + ; Alcotest.test_case "export" `Quick export + ; Alcotest.test_case "export_empty" `Quick export_empty + ; Alcotest.test_case "export_no_winget" `Quick export_no_winget + ; Alcotest.test_case "show" `Quick show + ; Alcotest.test_case "default" `Quick default + ] ) + ] +;; diff --git a/test/test_bootstrap.ml b/test/test_bootstrap.ml new file mode 100644 index 0000000..00e8780 --- /dev/null +++ b/test/test_bootstrap.ml @@ -0,0 +1,466 @@ +(** Tests for {!Devkit.Bootstrap}: portable search, PATH lookup, probes, + cert sniffing, bundle picking, size formatting, resolution order, + download flow (against [test/fixtures/] zips). *) +open Devkit + +let base_io + ?(getenv = fun _ -> None) + ?(is_file = fun _ -> false) + ?(spawn = fun _ _ -> "", false) + ?(cwd = Ok "/nowhere") + ?(exe = Ok "/nowhere/exe") + ?(cache = "/cache") + ?(latest = Error "no net") + ?(download = fun ~url:_ -> Error "no net") + ?(unzip = fun ~zip:_ ~dir:_ -> Error "no unzip") + () + : Bootstrap.io + = + { Bootstrap.getenv + ; is_file + ; spawn + ; cwd = (fun () -> cwd) + ; exe_dir = (fun () -> exe) + ; mkdir_p = (fun _ -> Ok ()) + ; cache_dir = (fun () -> cache) + ; latest_winget_cli = (fun () -> latest) + ; download + ; unzip + } +;; + +(* --- find_portable --- *) + +let test_portable_hit () = + let is_file = fun p -> p = "/a/winget.exe" in + Alcotest.(check string) "hit" "/a/winget.exe" (Bootstrap.find_portable ~is_file "/a") +;; + +let test_portable_prefers_winget_exe () = + let is_file = fun p -> p = "/a/winget.exe" || p = "/a/AppInstaller.exe" in + Alcotest.(check string) "order" "/a/winget.exe" (Bootstrap.find_portable ~is_file "/a") +;; + +let test_portable_subfolder () = + let is_file = fun p -> p = "/a/build/winget/AppInstaller.exe" in + Alcotest.(check string) + "subfolder" + "/a/build/winget/AppInstaller.exe" + (Bootstrap.find_portable ~is_file "/a") +;; + +let test_portable_walks_up () = + let is_file = fun p -> p = "/a/winget/winget.exe" in + Alcotest.(check string) + "walk-up" + "/a/winget/winget.exe" + (Bootstrap.find_portable ~is_file "/a/b/c") +;; + +let test_portable_stops_at_4 () = + let is_file = fun p -> p = "/a/winget.exe" in + Alcotest.(check string) + "beyond 4 levels" + "" + (Bootstrap.find_portable ~is_file "/a/b/c/d/e") +;; + +(* --- find_on_path --- *) + +let test_on_path () = + let getenv = function + | "PATH" -> Some "/x;/y:/z" + | _ -> None + in + let is_file = fun p -> p = "/y/winget" in + Alcotest.(check string) + "both separators" + "/y/winget" + (Bootstrap.find_on_path ~getenv ~is_file "winget") +;; + +let test_on_path_miss () = + Alcotest.(check string) + "miss" + "" + (Bootstrap.find_on_path ~getenv:(fun _ -> None) ~is_file:(fun _ -> false) "winget") +;; + +(* --- winget_runs --- *) + +let test_runs_ok () = + Alcotest.(check bool) + "exit 0" + true + (Bootstrap.winget_runs ~spawn:(fun _ _ -> "1.2.3", true) "/w/winget.exe") +;; + +let test_runs_output_despite_exit () = + Alcotest.(check bool) + "stderr version accepted" + true + (Bootstrap.winget_runs ~spawn:(fun _ _ -> "v1", false) "/w/winget.exe") +;; + +let test_runs_silent_fail () = + Alcotest.(check bool) + "silent fail" + false + (Bootstrap.winget_runs ~spawn:(fun _ _ -> "", false) "/w/winget.exe") +;; + +let test_runs_empty_no_spawn () = + let called = ref false in + let spawn _ _ = + called := true; + "", false + in + Alcotest.(check bool) "empty false" false (Bootstrap.winget_runs ~spawn ""); + Alcotest.(check bool) "no spawn" false !called +;; + +(* --- resolve_via_cmd --- *) + +let test_via_cmd () = + let spawn prog args = + match prog, args with + | "cmd", _ -> "C:\\junk\\other.exe\r\nC:\\tools\\winget.exe\r\n", true + | p, [ "--version" ] when p = "C:\\tools\\winget.exe" -> "1.0", true + | _ -> "", false + in + Alcotest.(check string) + "alias resolved" + "C:\\tools\\winget.exe" + (Bootstrap.resolve_via_cmd ~spawn) +;; + +let test_via_cmd_fail () = + Alcotest.(check string) + "where fails" + "" + (Bootstrap.resolve_via_cmd ~spawn:(fun _ _ -> "", false)) +;; + +(* --- is_cert_error --- *) + +let test_cert () = + List.iter + (fun msg -> Alcotest.(check bool) ("cert: " ^ msg) true (Bootstrap.is_cert_error msg)) + [ "x509: certificate signed by unknown authority" + ; "FAILED 80072f0d InternetOpenUrl" + ; "CERT_E_UNTRUSTEDROOT" + ]; + List.iter + (fun msg -> + Alcotest.(check bool) ("not cert: " ^ msg) false (Bootstrap.is_cert_error msg)) + [ "exit status 1"; ""; "connection refused" ]; + Alcotest.(check bool) + "advice mentions proxy CA" + true + (Strutil.contains_substring "Trusted Root" Bootstrap.cert_advice) +;; + +(* --- find_msixbundle --- *) + +let mkrel tag names = + { Gh.tag_name = tag + ; assets = + List.map + (fun n -> { Gh.name = n; browser_download_url = "https://x/" ^ n; size = 1L }) + names + } +;; + +let test_msixbundle_first () = + let rel = mkrel "v1" [ "notes.txt"; "WinGet.MSIXBUNDLE"; "other.msixbundle" ] in + match Bootstrap.find_msixbundle rel with + | None -> Alcotest.fail "expected hit" + | Some a -> Alcotest.(check string) "first wins" "WinGet.MSIXBUNDLE" a.Gh.name +;; + +let test_msixbundle_none () = + Alcotest.(check bool) + "none" + true + (Bootstrap.find_msixbundle (mkrel "v1" [ "a.zip" ]) = None) +;; + +(* --- format_size --- *) + +let test_sizes () = + let cases = + [ 0L, "0 B" + ; 999L, "999 B" + ; 1_024L, "1.0 KB" + ; 1_536L, "1.5 KB" + ; 1_048_576L, "1.0 MB" + ; 1_073_741_824L, "1.0 GB" + ] + in + List.iter + (fun (n, want) -> + Alcotest.(check string) ("size " ^ want) want (Bootstrap.format_size n)) + cases +;; + +(* --- resolve order --- *) + +let test_resolve_cwd_wins_no_spawn () = + let spawns = ref 0 in + let io = + base_io + ~is_file:(fun p -> p = "/proj/winget.exe") + ~spawn:(fun _ _ -> + incr spawns; + "", false) + ~cwd:(Ok "/proj/sub") + () + in + Alcotest.(check string) "cwd portable" "/proj/winget.exe" (Bootstrap.resolve io); + Alcotest.(check int) "no probes" 0 !spawns +;; + +let test_resolve_path_fallback () = + let io = + base_io + ~getenv:(function + | "PATH" -> Some "/bin" + | _ -> None) + ~is_file:(fun p -> p = "/bin/winget") + ~cwd:(Ok "/proj") + ~exe:(Ok "/opt/app") + () + in + Alcotest.(check string) "PATH hit" "/bin/winget" (Bootstrap.resolve io) +;; + +let test_resolve_miss () = + Alcotest.(check string) "miss" "" (Bootstrap.resolve (base_io ())) +;; + +(* --- ensure_full --- *) + +let fresh_cache () = Bootstrap.make_path_cache () + +let test_ensure_override_blind () = + let get, _ = fresh_cache () in + let io = base_io ~is_file:(fun _ -> true) () in + match + Bootstrap.ensure_full ~override_path:"C:\\custom\\winget.exe" ~resolve_path:get io + with + | Error e -> Alcotest.fail e + | Ok p -> Alcotest.(check string) "override verbatim" "C:\\custom\\winget.exe" p +;; + +let test_ensure_resolved () = + let get, _ = fresh_cache () in + let io = base_io ~is_file:(fun p -> p = "/p/winget.exe") ~cwd:(Ok "/p") () in + match Bootstrap.ensure_full ~override_path:"" ~resolve_path:get io with + | Error e -> Alcotest.fail e + | Ok p -> Alcotest.(check string) "resolved" "/p/winget.exe" p +;; + +let test_ensure_download_cert_advice () = + let get, _ = fresh_cache () in + let io = base_io ~latest:(Error "x509: certificate signed by unknown authority") () in + match Bootstrap.ensure_full ~override_path:"" ~resolve_path:get io with + | Ok _ -> Alcotest.fail "expected download error" + | Error e -> + Alcotest.(check bool) + "cert advice appended" + true + (Strutil.contains_substring "Trusted Root" e) +;; + +(* --- download_winget against fixtures --- *) + +let copy_to_temp src name = + let ic = open_in_bin src in + let n = in_channel_length ic in + let b = Bytes.create n in + really_input ic b 0 n; + close_in ic; + let dir = Filename.temp_dir "devkit-dl-" "" in + let dst = Filename.concat dir name in + let oc = open_out_bin dst in + output_bytes oc b; + close_out oc; + dst +;; + +let read_file path = + let ic = open_in_bin path in + let n = in_channel_length ic in + let s = really_input_string ic n in + close_in ic; + s +;; + +let test_download_happy () = + let cache = Filename.temp_dir "devkit-cache-" "" in + let copied = ref "" in + let io = + base_io + ~is_file:Sys.file_exists + ~cache + ~latest:(Ok (mkrel "v9.9" [ "bundle.msixbundle" ])) + ~download:(fun ~url:_ -> + let dst = copy_to_temp "fixtures/bundle.zip" "dl.msixbundle" in + copied := dst; + Ok dst) + ~unzip:(fun ~zip ~dir -> Zipx.extract ~zip_path:zip ~dest_dir:dir) + () + in + (match Bootstrap.download_winget io with + | Error e -> Alcotest.fail ("download: " ^ e) + | Ok exe -> + Alcotest.(check string) "cache exe" (Filename.concat cache "AppInstaller.exe") exe; + Alcotest.(check string) "first msix wins" "FROM-FIRST" (read_file exe)); + (* Temp download cleaned up, cache kept. *) + Alcotest.(check bool) "temp removed" false (Sys.file_exists !copied) +;; + +let test_download_no_bundle () = + let io = base_io ~latest:(Ok (mkrel "v9.9" [ "a.zip" ])) () in + match Bootstrap.download_winget io with + | Ok _ -> Alcotest.fail "expected no-bundle error" + | Error e -> + Alcotest.(check bool) + "message names tag" + true + (Strutil.contains_substring "v9.9" e && Strutil.contains_substring ".msixbundle" e) +;; + +let test_download_no_x64 () = + let cache = Filename.temp_dir "devkit-cache-" "" in + let io = + base_io + ~is_file:Sys.file_exists + ~cache + ~latest:(Ok (mkrel "v9.9" [ "b.msixbundle" ])) + ~download:(fun ~url:_ -> Ok (copy_to_temp "fixtures/nox64.zip" "dl.msixbundle")) + ~unzip:(fun ~zip ~dir -> Zipx.extract ~zip_path:zip ~dest_dir:dir) + () + in + match Bootstrap.download_winget io with + | Ok _ -> Alcotest.fail "expected no-x64 error" + | Error e -> + Alcotest.(check bool) + "wrapped" + true + (Strutil.contains_substring "extract: no x64 .msix" e) +;; + +let test_download_unzip_fails () = + let cache = Filename.temp_dir "devkit-cache-" "" in + let io = + base_io + ~cache + ~latest:(Ok (mkrel "v9.9" [ "b.msixbundle" ])) + ~download:(fun ~url:_ -> Ok (copy_to_temp "fixtures/bundle.zip" "dl.msixbundle")) + ~unzip:(fun ~zip:_ ~dir:_ -> Error "boom") + () + in + match Bootstrap.download_winget io with + | Ok _ -> Alcotest.fail "expected unzip error" + | Error e -> Alcotest.(check string) "wrapped" "extract: boom" e +;; + +let test_download_missing_exe () = + let cache = Filename.temp_dir "devkit-cache-" "" in + let io = + base_io + ~is_file:Sys.file_exists + ~cache + ~latest:(Ok (mkrel "v9.9" [ "b.msixbundle" ])) + ~download:(fun ~url:_ -> Ok (copy_to_temp "fixtures/bundle.zip" "dl.msixbundle")) + ~unzip:(fun ~zip:_ ~dir:_ -> Ok ()) + () + in + match Bootstrap.download_winget io with + | Ok _ -> Alcotest.fail "expected missing-exe error" + | Error e -> + Alcotest.(check string) + "missing-exe message" + "winget.exe not found after extraction" + e +;; + +let test_cache_memoizes () = + let get, reset = fresh_cache () in + let spawns = ref 0 in + let io = + base_io + ~spawn:(fun _ _ -> + incr spawns; + "", false) + ~getenv:(function + | "PATH" -> Some "/bin" + | _ -> None) + ~is_file:(fun p -> p = "/bin/winget") + ~cwd:(Ok "/proj") + ~exe:(Ok "/opt/app") + () + in + ignore (get io); + ignore (get io); + Alcotest.(check int) "probed once" 0 !spawns; + (* PATH lookup is pure (no spawn). The memo test that matters: a second + call returns the cached value without re-resolving, even after the + filesystem changes. *) + let io2 = { io with Bootstrap.is_file = (fun _ -> false) } in + Alcotest.(check string) "memoized" "/bin/winget" (get io2); + reset (); + Alcotest.(check string) "reset clears" "" (get io2) +;; + +let () = + Alcotest.run + "bootstrap" + [ ( "find_portable" + , [ Alcotest.test_case "hit" `Quick test_portable_hit + ; Alcotest.test_case "prefers winget.exe" `Quick test_portable_prefers_winget_exe + ; Alcotest.test_case "subfolder" `Quick test_portable_subfolder + ; Alcotest.test_case "walks up" `Quick test_portable_walks_up + ; Alcotest.test_case "stops at 4" `Quick test_portable_stops_at_4 + ] ) + ; ( "find_on_path" + , [ Alcotest.test_case "both separators" `Quick test_on_path + ; Alcotest.test_case "miss" `Quick test_on_path_miss + ] ) + ; ( "winget_runs" + , [ Alcotest.test_case "exit 0" `Quick test_runs_ok + ; Alcotest.test_case "output despite exit" `Quick test_runs_output_despite_exit + ; Alcotest.test_case "silent fail" `Quick test_runs_silent_fail + ; Alcotest.test_case "empty no spawn" `Quick test_runs_empty_no_spawn + ] ) + ; ( "via_cmd" + , [ Alcotest.test_case "alias resolved" `Quick test_via_cmd + ; Alcotest.test_case "where fails" `Quick test_via_cmd_fail + ] ) + ; "cert", [ Alcotest.test_case "markers + advice" `Quick test_cert ] + ; ( "msixbundle" + , [ Alcotest.test_case "first wins" `Quick test_msixbundle_first + ; Alcotest.test_case "none" `Quick test_msixbundle_none + ] ) + ; "format_size", [ Alcotest.test_case "boundaries" `Quick test_sizes ] + ; ( "resolve" + , [ Alcotest.test_case "cwd wins, no spawn" `Quick test_resolve_cwd_wins_no_spawn + ; Alcotest.test_case "PATH fallback" `Quick test_resolve_path_fallback + ; Alcotest.test_case "miss" `Quick test_resolve_miss + ] ) + ; ( "ensure" + , [ Alcotest.test_case "override blind" `Quick test_ensure_override_blind + ; Alcotest.test_case "resolved" `Quick test_ensure_resolved + ; Alcotest.test_case "cert advice" `Quick test_ensure_download_cert_advice + ] ) + ; ( "download" + , [ Alcotest.test_case "happy path" `Quick test_download_happy + ; Alcotest.test_case "no bundle" `Quick test_download_no_bundle + ; Alcotest.test_case "no x64 msix" `Quick test_download_no_x64 + ; Alcotest.test_case "unzip fails" `Quick test_download_unzip_fails + ; Alcotest.test_case "missing exe" `Quick test_download_missing_exe + ] ) + ; "cache", [ Alcotest.test_case "memoizes + resets" `Quick test_cache_memoizes ] + ] +;; diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml new file mode 100644 index 0000000..d81cd61 --- /dev/null +++ b/test/test_dashboard.ml @@ -0,0 +1,149 @@ +(** Tests for {!Dashboard}: section merge and plain-text render. *) + +open Devkit +open Pkgfile + +let item typ value = make_item typ value + +let winget_info rows = + List.fold_left + (fun acc (id, name, version, available) -> + Winget_parse.IdMap.add + (String.lowercase_ascii id) + Winget_parse.{ id; name; version; available } + acc) + Winget_parse.IdMap.empty + rows +;; + +let merge_basic () = + let manifest = + [ { name = "Runtimes" + ; items = + [ item Winget "Git.Git"; item Winget "Missing.App"; item GitHub "owner/tool" ] + } + ] + in + let apps = [ Dashboard.{ name = "Git.Git"; version = "2.47.1"; pm = "winget" } ] in + let info = + winget_info [ "Git.Git", "Git", "2.47.1", "2.48.0"; "Other.App", "Other", "1.0", "" ] + in + let sections = Dashboard.build_sections apps manifest (Some info) in + Alcotest.(check int) "three sections" 3 (List.length sections); + let pending = List.nth sections 0 in + Alcotest.(check string) "pending first" "Pending updates" pending.name; + Alcotest.(check int) "one update" 1 (List.length pending.items); + let git = List.nth pending.items 0 in + Alcotest.(check string) "git value" "Git.Git" git.value; + Alcotest.(check string) "installed" "2.47.1" git.installed_version; + Alcotest.(check string) "available" "2.48.0" git.available_version; + (match git.status with + | NeedsUpdate -> () + | _ -> Alcotest.fail "git should need update"); + let detected = List.nth sections 1 in + Alcotest.(check string) "newly second" "Newly detected" detected.name; + Alcotest.(check int) "one new" 1 (List.length detected.items); + (match (List.nth detected.items 0).status with + | New -> () + | _ -> Alcotest.fail "other should be New"); + let rest = List.nth sections 2 in + Alcotest.(check string) "manifest last" "Runtimes" rest.name; + Alcotest.(check int) "two left" 2 (List.length rest.items); + (match (List.nth rest.items 0).status with + | NotFound -> () + | _ -> Alcotest.fail "missing should be NotFound"); + match (List.nth rest.items 1).status with + | Manual -> () + | _ -> Alcotest.fail "github should be Manual" +;; + +let winget_artifact_dropped () = + let manifest = [ { name = "winget"; items = [ item Winget "Foo.Bar" ] } ] in + let sections = Dashboard.build_sections [] manifest None in + Alcotest.(check int) "dropped" 0 (List.length sections) +;; + +let show_fallback () = + (* show only fires for NotFound items (scan miss), so it enriches the + displayed available version without promoting to Pending updates, + exactly like the Go show-results loop. *) + let manifest = [ { name = "Runtimes"; items = [ item Winget "Git.Git" ] } ] in + let show = function + | "Git.Git" -> Some "2.48.0" + | _ -> None + in + let sections = Dashboard.build_sections ~show [] manifest None in + Alcotest.(check int) "no pending" 1 (List.length sections); + let sec = List.nth sections 0 in + Alcotest.(check string) "manifest kept" "Runtimes" sec.name; + let it = List.nth sec.items 0 in + Alcotest.(check string) "available enriched" "2.48.0" it.available_version; + match it.status with + | NotFound -> () + | _ -> Alcotest.fail "stays NotFound" +;; + +let render_fixture () = + let sections = + [ { name = "Pending updates" + ; items = + [ { (item Winget "Git.Git") with + installed_version = "2.47.1" + ; available_version = "2.48.0" + ; status = NeedsUpdate + } + ] + } + ; { name = "Newly detected" + ; items = [ { (item Winget "Other.App") with status = New } ] + } + ; { name = "Runtimes" + ; items = + [ { (item Winget "Missing.App") with status = NotFound } + ; { (item GitHub "owner/tool") with status = Manual } + ] + } + ; { name = "Empty"; items = [] } + ] + in + let expected = + "DEVKIT\n" + ^ "! update + not installed ~ manual\n" + ^ "\n" + ^ "PENDING UPDATES\n" + ^ " [!] Git.Git 2.47.1 -> 2.48.0\n" + ^ "\n" + ^ "RUNTIMES\n" + ^ " [+] Missing.App\n" + ^ " [~] owner/tool\n" + ^ "\n" + in + Alcotest.(check string) "exact render" expected (Dashboard.render sections) +;; + +let render_versions () = + Alcotest.(check string) + "installed only" + " 1.2.3" + (Dashboard.format_ver { (item Winget "x") with installed_version = "1.2.3" }); + Alcotest.(check string) + "available only" + " 2.0" + (Dashboard.format_ver { (item Winget "x") with available_version = "2.0" }); + Alcotest.(check string) "neither" "" (Dashboard.format_ver (item Winget "x")) +;; + +let () = + Alcotest.run + "dashboard" + [ ( "merge" + , [ Alcotest.test_case "basic" `Quick merge_basic + ; Alcotest.test_case "winget artifact dropped" `Quick winget_artifact_dropped + ; Alcotest.test_case "show fallback" `Quick show_fallback + ] ) + ; ( "render" + , [ Alcotest.test_case "exact fixture" `Quick render_fixture + ; Alcotest.test_case "version suffixes" `Quick render_versions + ] ) + ] +;; diff --git a/test/test_gh.ml b/test/test_gh.ml new file mode 100644 index 0000000..4b72eac --- /dev/null +++ b/test/test_gh.ml @@ -0,0 +1,76 @@ +(** Tests for {!Devkit.Gh}: JSON parsing, arch matching. *) +open Devkit + +let release_json = + {|{ + "tag_name": "v2.1.0", + "assets": [ + {"name": "tool-linux.tar.gz", "browser_download_url": "https://x/lin", "size": 10}, + {"name": "Tool-win-x64.exe", "browser_download_url": "https://x/win", "size": 20}, + {"name": "tool.msi", "browser_download_url": "https://x/msi"} + ] + }|} +;; + +let test_parse () = + match Gh.parse_release release_json with + | Error e -> Alcotest.fail ("parse: " ^ e) + | Ok rel -> + Alcotest.(check string) "tag" "v2.1.0" rel.Gh.tag_name; + Alcotest.(check int) "assets" 3 (List.length rel.Gh.assets); + let msi = List.nth rel.Gh.assets 2 in + Alcotest.(check string) "msi url" "https://x/msi" msi.Gh.browser_download_url; + Alcotest.(check int64) "missing size defaults 0" 0L msi.Gh.size +;; + +let test_parse_bad () = + match Gh.parse_release "{oops" with + | Ok _ -> Alcotest.fail "expected decode error" + | Error e -> + Alcotest.(check bool) "decode prefix" true (Strutil.contains_substring "decode" e) +;; + +let asset name = { Gh.name; browser_download_url = "https://x/" ^ name; size = 1L } + +let test_prefers_arch_win () = + let assets = [ asset "tool-linux-x64.tar.gz"; asset "Tool-win-x64.exe" ] in + match Gh.match_by_arch assets with + | None -> Alcotest.fail "expected a hit" + | Some a -> Alcotest.(check string) "arch windows exe" "Tool-win-x64.exe" a.Gh.name +;; + +let test_falls_back_plain_exe () = + let assets = [ asset "tool-linux.tar.gz"; asset "setup.exe" ] in + match Gh.match_by_arch assets with + | None -> Alcotest.fail "expected fallback hit" + | Some a -> Alcotest.(check string) "fallback exe" "setup.exe" a.Gh.name +;; + +let test_case_insensitive () = + match Gh.match_by_arch [ asset "APP-WIN-AMD64.MSI" ] with + | None -> Alcotest.fail "expected hit" + | Some a -> Alcotest.(check string) "name" "APP-WIN-AMD64.MSI" a.Gh.name +;; + +let test_no_windows () = + Alcotest.(check bool) + "no windows asset" + true + (Gh.match_by_arch [ asset "tool-linux.tar.gz"; asset "tool-mac.dmg" ] = None) +;; + +let () = + Alcotest.run + "gh" + [ ( "parse" + , [ Alcotest.test_case "release json" `Quick test_parse + ; Alcotest.test_case "bad json errors" `Quick test_parse_bad + ] ) + ; ( "match_by_arch" + , [ Alcotest.test_case "prefers arch windows exe" `Quick test_prefers_arch_win + ; Alcotest.test_case "falls back to plain exe" `Quick test_falls_back_plain_exe + ; Alcotest.test_case "case insensitive" `Quick test_case_insensitive + ; Alcotest.test_case "no windows asset" `Quick test_no_windows + ] ) + ] +;; diff --git a/test/test_hash.ml b/test/test_hash.ml new file mode 100644 index 0000000..7ca2c18 --- /dev/null +++ b/test/test_hash.ml @@ -0,0 +1,150 @@ +(** Tests for {!Devkit.Hash}: known vector, expectation handling, download + naming (query-string strip). *) +open Devkit + +let with_temp_file contents f = + let path = Filename.temp_file "devkit-hash-" ".bin" in + let oc = open_out_bin path in + output_string oc contents; + close_out oc; + let r = f path in + (try Sys.remove path with + | _ -> ()); + r +;; + +let test_sha256_abc () = + with_temp_file "abc" (fun path -> + match Hash.sha256_file path with + | Error e -> Alcotest.fail e + | Ok got -> + Alcotest.(check string) + "sha256(abc)" + "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" + got) +;; + +let test_verify_ok_case_insensitive () = + with_temp_file "abc" (fun path -> + Alcotest.(check bool) + "upper hex verifies" + true + (Hash.verify_file + (Hash.Hex "BA7816BF8F01CFEA414140DE5DAE2223B00361A396177A9CB410FF61F20015AD") + path + = Ok ())) +;; + +let test_verify_mismatch () = + with_temp_file "abc" (fun path -> + match Hash.verify_file (Hash.Hex (String.make 64 '0')) path with + | Ok () -> Alcotest.fail "expected mismatch" + | Error e -> + Alcotest.(check bool) + "mismatch message" + true + (Strutil.contains_substring "hash mismatch" e)) +;; + +let test_empty_hex_refused () = + with_temp_file "abc" (fun path -> + match Hash.verify_file (Hash.Hex "") path with + | Ok () -> Alcotest.fail "empty hash must never verify" + | Error _ -> ()) +;; + +let test_no_expected_passes_without_fs () = + Alcotest.(check bool) + "No_expected passes" + true + (Hash.verify_file Hash.No_expected "/nonexistent/file" = Ok ()) +;; + +let fake_fetch body seen : Fetch.fetch = + fun ?(timeout_s = 0) url headers -> + ignore timeout_s; + seen := (url, headers) :: !seen; + Ok body +;; + +let test_download_strips_query () = + let seen = ref [] in + match + Hash.download_and_verify + (fake_fetch "payload" seen) + Hash.No_expected + "https://example.com/dir/setup.exe?dl=1" + with + | Error e -> Alcotest.fail e + | Ok path -> + Alcotest.(check string) "query stripped" "setup.exe" (Filename.basename path); + let ic = open_in_bin path in + let got = really_input_string ic (in_channel_length ic) in + close_in ic; + Alcotest.(check string) "body" "payload" got; + let dir = Filename.dirname path in + (try Sys.remove path with + | _ -> ()); + (try Unix.rmdir dir with + | _ -> ()) +;; + +let test_download_empty_tail () = + let seen = ref [] in + match + Hash.download_and_verify (fake_fetch "p" seen) Hash.No_expected "https://example.com/" + with + | Error e -> Alcotest.fail e + | Ok path -> + Alcotest.(check string) "empty tail" "download" (Filename.basename path); + let dir = Filename.dirname path in + (try Sys.remove path with + | _ -> ()); + (try Unix.rmdir dir with + | _ -> ()) +;; + +let test_download_records_url () = + let seen = ref [] in + match + Hash.download_and_verify + (fake_fetch "p" seen) + Hash.No_expected + "https://example.com/a.bin" + with + | Error e -> Alcotest.fail e + | Ok path -> + Alcotest.(check string) + "fetched url" + "https://example.com/a.bin" + (fst (List.hd !seen)); + let dir = Filename.dirname path in + (try Sys.remove path with + | _ -> ()); + (try Unix.rmdir dir with + | _ -> ()) +;; + +let () = + Alcotest.run + "hash" + [ ( "sha256" + , [ Alcotest.test_case "known vector" `Quick test_sha256_abc + ; Alcotest.test_case + "case-insensitive verify" + `Quick + test_verify_ok_case_insensitive + ; Alcotest.test_case "mismatch errors" `Quick test_verify_mismatch + ; Alcotest.test_case "empty hex refused" `Quick test_empty_hex_refused + ; Alcotest.test_case + "No_expected passes" + `Quick + test_no_expected_passes_without_fs + ] ) + ; ( "download" + , [ Alcotest.test_case "strips query string" `Quick test_download_strips_query + ; Alcotest.test_case "empty tail name" `Quick test_download_empty_tail + ; Alcotest.test_case "fetches url" `Quick test_download_records_url + ] ) + ] +;; diff --git a/test/test_install.ml b/test/test_install.ml new file mode 100644 index 0000000..613312e --- /dev/null +++ b/test/test_install.ml @@ -0,0 +1,363 @@ +(** Tests for {!Devkit.Install}: arg capture, already-installed readings, + github dispatch, installer ext routing, browser selection. *) +open Devkit + +let base_deps + ?(winget = fun () -> "C:\\w\\winget.exe") + ?(spawn = fun _ _ -> "", true) + ?(browser = fun _ -> Ok ()) + ?(latest = fun _ -> Error "no net") + ?(download = fun ~url:_ -> Error "no net") + ?(installer = fun _ -> Ok ()) + ?(tools = []) + () + : Install.deps + = + { Install.winget + ; spawn + ; open_browser = browser + ; latest_release = latest + ; download + ; run_installer = installer + ; tools + } +;; + +let test_status_strings () = + let cases = + [ Install.Installed, "installed" + ; Install.Updated, "updated" + ; Install.Opened, "opened" + ; Install.Skipped "x", "skip" + ; Install.Failed "x", "error" + ] + in + List.iter + (fun (s, want) -> Alcotest.(check string) want want (Install.status_to_string s)) + cases +;; + +let test_winget_install_args () = + let seen = ref ("", []) in + let d = + base_deps + ~spawn:(fun prog args -> + seen := prog, args; + "", true) + () + in + let r = Install.install d "winget" "Foo.Bar" false in + Alcotest.(check string) "prog" "C:\\w\\winget.exe" (fst !seen); + Alcotest.(check (list string)) + "args" + [ "install" + ; "--id" + ; "Foo.Bar" + ; "-e" + ; "--accept-package-agreements" + ; "--accept-source-agreements" + ; "--silent" + ] + (snd !seen); + Alcotest.(check string) "value" "Foo.Bar" r.Install.value; + Alcotest.(check bool) "installed" true (r.Install.status = Install.Installed) +;; + +let test_winget_upgrade_args () = + let seen = ref [] in + let d = + base_deps + ~spawn:(fun _ args -> + seen := args; + "", true) + () + in + let r = Install.install d "winget" "Foo.Bar" true in + Alcotest.(check (list string)) + "upgrade args" + [ "upgrade" + ; "--id" + ; "Foo.Bar" + ; "--accept-package-agreements" + ; "--accept-source-agreements" + ] + !seen; + Alcotest.(check bool) "updated" true (r.Install.status = Install.Updated) +;; + +let test_winget_unavailable () = + let d = base_deps ~winget:(fun () -> "") () in + let r = Install.install d "winget" "Foo.Bar" false in + Alcotest.(check bool) + "unavailable" + true + (r.Install.status = Install.Failed "winget unavailable") +;; + +let test_winget_already_installed () = + let d = + base_deps ~spawn:(fun _ _ -> "Found an existing package already installed", false) () + in + let r = Install.install d "winget" "Foo.Bar" false in + Alcotest.(check bool) "installed" true (r.Install.status = Install.Installed) +;; + +let test_winget_no_newer_update () = + let d = + base_deps ~spawn:(fun _ _ -> "No newer package versions are available", false) () + in + let r = Install.install d "winget" "Foo.Bar" true in + Alcotest.(check bool) "updated" true (r.Install.status = Install.Updated) +;; + +let test_winget_real_error () = + let d = base_deps ~spawn:(fun _ _ -> "Access denied", false) () in + let r = Install.install d "winget" "Foo.Bar" false in + match r.Install.status with + | Install.Failed msg -> + Alcotest.(check bool) + "mentions output" + true + (Strutil.contains_substring "Access denied" msg) + | _ -> Alcotest.fail "expected failure" +;; + +let win_asset = + { Gh.name = "Tool-win-x64.exe"; browser_download_url = "https://x/tool.exe"; size = 1L } +;; + +let win_release = { Gh.tag_name = "v1"; assets = win_asset :: [] } + +let test_github_happy () = + let got_url = ref "" in + let got_path = ref "" in + let d = + base_deps + ~latest:(fun repo -> + Alcotest.(check string) "repo" "owner/tool" repo; + Ok win_release) + ~download:(fun ~url -> + got_url := url; + Ok "/tmp/tool.exe") + ~installer:(fun path -> + got_path := path; + Ok ()) + () + in + let r = Install.install d "github" "owner/tool" false in + Alcotest.(check string) "asset url" "https://x/tool.exe" !got_url; + Alcotest.(check string) "installer path" "/tmp/tool.exe" !got_path; + Alcotest.(check bool) "installed" true (r.Install.status = Install.Installed) +;; + +let test_github_no_asset_opens_page () = + let opened = ref "" in + let d = + base_deps + ~latest:(fun _ -> Ok { Gh.tag_name = "v1"; assets = [] }) + ~browser:(fun url -> + opened := url; + Ok ()) + () + in + let r = Install.install d "github" "owner/tool" false in + Alcotest.(check string) + "releases page" + "https://github.com/owner/tool/releases/latest" + !opened; + Alcotest.(check bool) "opened" true (r.Install.status = Install.Opened) +;; + +let test_github_api_error () = + let d = base_deps ~latest:(fun _ -> Error "HTTP 404") () in + let r = Install.install d "github" "owner/tool" false in + Alcotest.(check bool) "failed" true (r.Install.status = Install.Failed "HTTP 404") +;; + +let test_url_opens () = + let d = base_deps ~browser:(fun _ -> Ok ()) () in + let r = Install.install d "url" "https://example.com" false in + Alcotest.(check bool) "opened" true (r.Install.status = Install.Opened) +;; + +let test_unknown_kind_skips () = + let d = base_deps () in + let r = Install.install d "apt" "foo" false in + match r.Install.status with + | Install.Skipped msg -> + Alcotest.(check bool) "names kind" true (Strutil.contains_substring "apt" msg) + | _ -> Alcotest.fail "expected skip" +;; + +let mytool = + { Plugin.name = "mytool" + ; prog = "mytool" + ; list_args = [ "list" ] + ; install = Some [ "mytool"; "add"; "{id}" ] + ; upgrade = Some [ "mytool"; "bump"; "{id}" ] + ; parse = (fun _ -> []) + } +;; + +let test_plugin_install_happy () = + let seen = ref ("", []) in + let d = + base_deps + ~tools:[ mytool ] + ~spawn:(fun prog args -> + seen := prog, args; + "", true) + () + in + let r = Install.install d "mytool" "some-pkg" false in + Alcotest.(check string) "prog" "mytool" (fst !seen); + Alcotest.(check (list string)) "args" [ "add"; "some-pkg" ] (snd !seen); + Alcotest.(check bool) "installed" true (r.Install.status = Install.Installed) +;; + +let test_plugin_upgrade_happy () = + let seen = ref ("", []) in + let d = + base_deps + ~tools:[ mytool ] + ~spawn:(fun prog args -> + seen := prog, args; + "", true) + () + in + let r = Install.install d "MYTOOL" "some-pkg" true in + Alcotest.(check string) "prog" "mytool" (fst !seen); + Alcotest.(check (list string)) "args" [ "bump"; "some-pkg" ] (snd !seen); + Alcotest.(check bool) "updated" true (r.Install.status = Install.Updated) +;; + +let test_plugin_missing_template () = + let bare = { mytool with install = None; upgrade = None } in + let d = base_deps ~tools:[ bare ] () in + let r = Install.install d "mytool" "some-pkg" false in + match r.Install.status with + | Install.Failed msg -> + Alcotest.(check bool) + "names template" + true + (Strutil.contains_substring "no install template" msg) + | _ -> Alcotest.fail "expected failure" +;; + +let test_plugin_spawn_fail () = + let d = base_deps ~tools:[ mytool ] ~spawn:(fun _ _ -> "denied", false) () in + let r = Install.install d "mytool" "some-pkg" false in + match r.Install.status with + | Install.Failed msg -> + Alcotest.(check bool) "keeps output" true (Strutil.contains_substring "denied" msg) + | _ -> Alcotest.fail "expected failure" +;; + +let test_run_installer_msi () = + let seen = ref ("", []) in + let spawn prog args = + seen := prog, args; + "", true + in + Alcotest.(check bool) "msi ok" true (Install.run_installer spawn "C:\\s.MSI" = Ok ()); + Alcotest.(check string) "msiexec" "msiexec" (fst !seen); + Alcotest.(check (list string)) + "msi args" + [ "/i"; "C:\\s.MSI"; "/quiet"; "/norestart" ] + (snd !seen) +;; + +let test_run_installer_exe () = + let seen = ref ("", []) in + let spawn prog args = + seen := prog, args; + "", true + in + Alcotest.(check bool) + "exe ok" + true + (Install.run_installer spawn "/tmp/setup.exe" = Ok ()); + Alcotest.(check string) "self" "/tmp/setup.exe" (fst !seen); + Alcotest.(check (list string)) "switches" [ "/S"; "/silent"; "/verysilent" ] (snd !seen) +;; + +let test_run_installer_unsupported () = + match Install.run_installer (fun _ _ -> "", true) "/tmp/app.zip" with + | Ok () -> Alcotest.fail "expected refusal" + | Error e -> + Alcotest.(check bool) "names ext" true (Strutil.contains_substring ".zip" e) +;; + +let test_run_installer_failure () = + match Install.run_installer (fun _ _ -> "denied", false) "/tmp/s.exe" with + | Ok () -> Alcotest.fail "expected failure" + | Error e -> + Alcotest.(check bool) "output kept" true (Strutil.contains_substring "denied" e) +;; + +let test_browser_linux () = + let seen = ref ("", []) in + let spawn prog args = + if prog = "uname" + then "Linux", true + else ( + seen := prog, args; + "", true) + in + Alcotest.(check bool) "ok" true (Install.real_open_browser spawn "https://x" = Ok ()); + Alcotest.(check string) "xdg-open" "xdg-open" (fst !seen) +;; + +let test_browser_darwin () = + let seen = ref "" in + let spawn prog args = + if prog = "uname" + then "Darwin", true + else ( + seen := prog; + ignore args; + "", true) + in + ignore (Install.real_open_browser spawn "https://x"); + Alcotest.(check string) "open" "open" !seen +;; + +let () = + Alcotest.run + "install" + [ "status", [ Alcotest.test_case "strings" `Quick test_status_strings ] + ; ( "winget" + , [ Alcotest.test_case "install args" `Quick test_winget_install_args + ; Alcotest.test_case "upgrade args" `Quick test_winget_upgrade_args + ; Alcotest.test_case "unavailable" `Quick test_winget_unavailable + ; Alcotest.test_case "already installed" `Quick test_winget_already_installed + ; Alcotest.test_case "no newer on update" `Quick test_winget_no_newer_update + ; Alcotest.test_case "real error" `Quick test_winget_real_error + ] ) + ; ( "github" + , [ Alcotest.test_case "happy path" `Quick test_github_happy + ; Alcotest.test_case "no asset opens page" `Quick test_github_no_asset_opens_page + ; Alcotest.test_case "api error" `Quick test_github_api_error + ] ) + ; ( "dispatch" + , [ Alcotest.test_case "url opens" `Quick test_url_opens + ; Alcotest.test_case "unknown kind skips" `Quick test_unknown_kind_skips + ] ) + ; ( "plugin" + , [ Alcotest.test_case "install happy" `Quick test_plugin_install_happy + ; Alcotest.test_case "upgrade happy" `Quick test_plugin_upgrade_happy + ; Alcotest.test_case "missing template" `Quick test_plugin_missing_template + ; Alcotest.test_case "spawn fail" `Quick test_plugin_spawn_fail + ] ) + ; ( "run_installer" + , [ Alcotest.test_case "msi" `Quick test_run_installer_msi + ; Alcotest.test_case "exe" `Quick test_run_installer_exe + ; Alcotest.test_case "unsupported" `Quick test_run_installer_unsupported + ; Alcotest.test_case "failure" `Quick test_run_installer_failure + ] ) + ; ( "browser" + , [ Alcotest.test_case "linux" `Quick test_browser_linux + ; Alcotest.test_case "darwin" `Quick test_browser_darwin + ] ) + ] +;; diff --git a/test/test_inventory.ml b/test/test_inventory.ml new file mode 100644 index 0000000..25be828 --- /dev/null +++ b/test/test_inventory.ml @@ -0,0 +1,139 @@ +(** Tests for {!Inventory} and {!Proc}: per-PM parsers, full scan wiring, + winget memoization. *) + +open Devkit + +let apps_t = + Alcotest.testable + (fun ppf (a : Dashboard.app) -> Format.fprintf ppf "%s %s %s" a.pm a.name a.version) + ( = ) +;; + +let check_apps = Alcotest.(check (list apps_t)) + +let npm () = + check_apps + "npm rows" + [ Dashboard.{ name = "npm"; version = "10.9.0"; pm = "npm" } + ; Dashboard.{ name = "typescript"; version = "5.4.5"; pm = "npm" } + ; Dashboard.{ name = "@scope/pkg"; version = "1.2.3"; pm = "npm" } + ] + (Inventory.parse_npm + "/usr/lib/node_modules\n\ + ├── npm@10.9.0\n\ + └── typescript@5.4.5\n\ + ├── @scope/pkg@1.2.3\n") +;; + +let pipx () = + check_apps + "pipx rows" + [ Dashboard.{ name = "attrs"; version = "25.3.0"; pm = "pipx" } + ; Dashboard.{ name = "black"; version = "24.10.0"; pm = "pipx" } + ] + (Inventory.parse_pipx "attrs 25.3.0, injected: flake8\nblack 24.10.0\n") +;; + +let uv () = + check_apps + "uv rows" + [ Dashboard.{ name = "ruff"; version = "0.16.8"; pm = "uv" } + ; Dashboard.{ name = "py-spy"; version = "0.4.2"; pm = "uv" } + ] + (Inventory.parse_uv "ruff v0.16.8\n- ruff\npy-spy v0.4.2\n- py-spy\n") +;; + +let uv_skips () = + check_apps + "uv shims and warnings skipped" + [ Dashboard.{ name = "ruff"; version = "0.16.8"; pm = "uv" } ] + (Inventory.parse_uv "ruff v0.16.8\n- ruff\nFailed to parse entry for bandit\n") +;; + +let uv_empty () = check_apps "uv empty" [] (Inventory.parse_uv "") + +let cargo () = + check_apps + "cargo rows" + [ Dashboard.{ name = "ripgrep"; version = "14.1.0"; pm = "cargo" } + ; Dashboard.{ name = "fd-find"; version = "10.2.0"; pm = "cargo" } + ] + (Inventory.parse_cargo "ripgrep v14.1.0:\n rg\nfd-find v10.2.0:\n fd\n") +;; + +let winget_table = + "Name Id Version Available Source\n\ + --------------------------------\n\ + Git Git.Git 2.47.1 2.48.0 winget\n\ + Brave Brave.Brave 1.80.122 winget\n" +;; + +let winget () = + check_apps + "winget rows sorted by id" + [ Dashboard.{ name = "Brave.Brave"; version = "1.80.122"; pm = "winget" } + ; Dashboard.{ name = "Git.Git"; version = "2.47.1"; pm = "winget" } + ] + (Inventory.parse_winget winget_table) +;; + +let scan () = + let run prog _args = + match prog with + | "npm" -> None (* missing binary → skipped *) + | "pipx" -> Some "black 24.10.0\n" + | "uv" -> Some "ruff v0.16.8\n- ruff\n" + | "cargo" -> Some "rg v14.1.0:\n" + | _ -> None + in + let apps = Inventory.scan_all run ~winget:(fun () -> Some winget_table) ~extra:[] in + check_apps + "scan order and tags" + [ Dashboard.{ name = "Brave.Brave"; version = "1.80.122"; pm = "winget" } + ; Dashboard.{ name = "Git.Git"; version = "2.47.1"; pm = "winget" } + ; Dashboard.{ name = "black"; version = "24.10.0"; pm = "pipx" } + ; Dashboard.{ name = "ruff"; version = "0.16.8"; pm = "uv" } + ; Dashboard.{ name = "rg"; version = "14.1.0"; pm = "cargo" } + ] + apps +;; + +let memo () = + let calls = ref 0 in + let run _prog _args = + incr calls; + Some "out" + in + let fetch, reset = Proc.winget_list run in + Alcotest.(check (option string)) "first" (Some "out") (fetch ""); + Alcotest.(check (option string)) "memoized" (Some "out") (fetch ""); + Alcotest.(check int) "one spawn" 1 !calls; + reset (); + Alcotest.(check (option string)) "after reset" (Some "out") (fetch ""); + Alcotest.(check int) "two spawns" 2 !calls +;; + +let memo_failure () = + let fetch, _ = Proc.winget_list (fun _ _ -> None) in + Alcotest.(check (option string)) "missing winget" None (fetch "") +;; + +let () = + Alcotest.run + "inventory" + [ ( "parsers" + , [ Alcotest.test_case "npm" `Quick npm + ; Alcotest.test_case "pipx" `Quick pipx + ; Alcotest.test_case "uv" `Quick uv + ; Alcotest.test_case "uv skips" `Quick uv_skips + ; Alcotest.test_case "uv empty" `Quick uv_empty + ; Alcotest.test_case "cargo" `Quick cargo + ; Alcotest.test_case "winget" `Quick winget + ] ) + ; ( "scan" + , [ Alcotest.test_case "scan_all" `Quick scan + ; Alcotest.test_case "winget memo" `Quick memo + ; Alcotest.test_case "winget missing" `Quick memo_failure + ] ) + ] +;; diff --git a/test/test_pkgfile.ml b/test/test_pkgfile.ml new file mode 100644 index 0000000..a765d27 --- /dev/null +++ b/test/test_pkgfile.ml @@ -0,0 +1,116 @@ +(** Tests for {!Pkgfile}: manifest parsing. *) + +open Devkit.Pkgfile + +let status_t = + Alcotest.testable + (fun ppf -> function + | Installed -> Format.pp_print_string ppf "Installed" + | NeedsUpdate -> Format.pp_print_string ppf "NeedsUpdate" + | NotFound -> Format.pp_print_string ppf "NotFound" + | New -> Format.pp_print_string ppf "New" + | Manual -> Format.pp_print_string ppf "Manual") + ( = ) +;; + +let type_t = + Alcotest.testable + (fun ppf -> function + | Winget -> Format.pp_print_string ppf "Winget" + | GitHub -> Format.pp_print_string ppf "GitHub" + | Url -> Format.pp_print_string ppf "Url") + ( = ) +;; + +let sections () = + let r = + parse + "# Runtimes\n\ + winget:Microsoft.DotNet.SDK.9\n\n\ + github:owner/repo\n\ + # Setup\n\ + url:https://example.com/x.exe\n" + in + Alcotest.(check string) "winget path empty" "" r.winget_path; + Alcotest.(check int) "two sections" 2 (List.length r.sections); + let runtimes = List.nth r.sections 0 in + Alcotest.(check string) "first section" "Runtimes" runtimes.name; + Alcotest.(check int) "runtimes items" 2 (List.length runtimes.items); + Alcotest.(check type_t) "winget type" Winget (List.nth runtimes.items 0).typ; + Alcotest.(check string) + "winget value" + "Microsoft.DotNet.SDK.9" + (List.nth runtimes.items 0).value; + Alcotest.(check type_t) "github type" GitHub (List.nth runtimes.items 1).typ; + let setup = List.nth r.sections 1 in + Alcotest.(check string) "second section" "Setup" setup.name; + Alcotest.(check type_t) "url type" Url (List.nth setup.items 0).typ +;; + +let directive () = + let r = parse "# winget: C:\\tools\\winget.exe\n# Runtimes\nwinget:Foo.Bar\n" in + Alcotest.(check string) "winget path" "C:\\tools\\winget.exe" r.winget_path; + Alcotest.(check int) "directive is not a section" 1 (List.length r.sections) +;; + +let directive_case_insensitive () = + let r = parse "# Winget: /usr/bin/winget\nwinget:Foo.Bar\n" in + Alcotest.(check string) "path" "/usr/bin/winget" r.winget_path; + Alcotest.(check string) "implicit General" "General" (List.nth r.sections 0).name +;; + +let bare_winget_header_is_section () = + (* "# winget" without a path becomes a section named "winget", later + dropped by the dashboard merge. *) + let r = parse "# winget\nwinget:Foo.Bar\n" in + Alcotest.(check string) "no path" "" r.winget_path; + Alcotest.(check string) "section winget" "winget" (List.nth r.sections 0).name +;; + +let general_fallback () = + let r = parse "winget:Foo.Bar\n" in + Alcotest.(check int) "one section" 1 (List.length r.sections); + Alcotest.(check string) "General" "General" (List.nth r.sections 0).name +;; + +let skipped_lines () = + let r = + parse "# Sec\nno-colon-here\nunknown:val\nwinget:\n \nwinget: \nwinget:Real.Id\n" + in + let sec = List.nth r.sections 0 in + Alcotest.(check int) "only the valid item" 1 (List.length sec.items); + Alcotest.(check string) "value" "Real.Id" (List.nth sec.items 0).value +;; + +let empty_comment_no_section () = + let r = parse "#\n# \nwinget:Foo.Bar\n" in + Alcotest.(check string) "General" "General" (List.nth r.sections 0).name +;; + +let fresh_item_status () = + (* Fresh items carry NotFound until the merge assigns. *) + let r = parse "winget:Foo.Bar\n" in + Alcotest.(check status_t) + "zero status" + NotFound + (List.nth (List.nth r.sections 0).items 0).status +;; + +let () = + Alcotest.run + "pkgfile" + [ ( "parse" + , [ Alcotest.test_case "sections and items" `Quick sections + ; Alcotest.test_case "winget directive" `Quick directive + ; Alcotest.test_case + "directive case-insensitive" + `Quick + directive_case_insensitive + ; Alcotest.test_case "bare winget header" `Quick bare_winget_header_is_section + ; Alcotest.test_case "General fallback" `Quick general_fallback + ; Alcotest.test_case "skipped lines" `Quick skipped_lines + ; Alcotest.test_case "empty comments" `Quick empty_comment_no_section + ; Alcotest.test_case "fresh item status" `Quick fresh_item_status + ] ) + ] +;; diff --git a/test/test_plugin.ml b/test/test_plugin.ml new file mode 100644 index 0000000..d4f97e6 --- /dev/null +++ b/test/test_plugin.ml @@ -0,0 +1,239 @@ +(** Tests for {!Devkit.Plugin}: row parsing, template expansion, s-expr + loading, multi-file merge, lookup, and {!Devkit.Inventory.scan_tool}. *) +open Devkit + +let app_triple = Alcotest.triple Alcotest.string Alcotest.string Alcotest.string + +let proj (apps : Dashboard.app list) : (string * string * string) list = + List.map + (fun (a : Dashboard.app) -> a.Dashboard.name, a.Dashboard.version, a.Dashboard.pm) + apps +;; + +let spec = + { Plugin.skip_prefixes = [ "- " ] + ; skip_res = [ Re.compile (Re.Pcre.re "^WARN") ] + ; row_re = Re.compile (Re.Pcre.re "^(\\S+)\\s+v?([0-9][^ ]*)") + ; strip_version_prefix = "v" + } +;; + +let rows () = + let apps = + Plugin.parse_rows + spec + "my" + "ruff v0.16.8\n- ruff\n\nWARN noisy\nblack 24.10.0\ngarbage line\n" + in + Alcotest.(check (list app_triple)) + "skips + strips" + [ "ruff", "0.16.8", "my"; "black", "24.10.0", "my" ] + (proj apps) +;; + +let unversioned () = + let opt = + { spec with Plugin.row_re = Re.compile (Re.Pcre.re "^(\\S+)(?:\\s+([0-9][^ ]*))?") } + in + Alcotest.(check (list app_triple)) + "missing group 2" + [ "noversion", "", "my" ] + (proj (Plugin.parse_rows opt "my" "noversion\n")) +;; + +let expand_ok () = + Alcotest.(check (result (list string) string)) + "subst" + (Ok [ "mytool"; "install"; "Foo.Bar" ]) + (Plugin.expand [ "id", "Foo.Bar" ] [ "mytool"; "install"; "{id}" ]) +;; + +let expand_plain () = + Alcotest.(check (result (list string) string)) + "no braces" + (Ok [ "a"; "b" ]) + (Plugin.expand [] [ "a"; "b" ]) +;; + +let expand_unknown () = + match Plugin.expand [ "id", "x" ] [ "{ver}" ] with + | Ok _ -> Alcotest.fail "expected unknown-placeholder error" + | Error _ -> () +;; + +let expand_unclosed () = + match Plugin.expand [] [ "foo{id" ] with + | Ok _ -> Alcotest.fail "expected unclosed-brace error" + | Error _ -> () +;; + +let basic_file = + "(tools (tool (name mytool) (prog mytool) (list --list --short) (skip_prefixes (\"- \ + \")) (skip_res (\"^WARN\")) (row_re \"^(\\\\S+)\\\\s+v?([0-9][^ ]*)\") \ + (strip_version_prefix v) (install (mytool install {id})) (upgrade (mytool upgrade \ + {id}))))" +;; + +let load_basic () = + match Plugin.load_string ~source:"t" basic_file with + | Error e -> Alcotest.fail e + | Ok [ t ] -> + Alcotest.(check string) "name" "mytool" t.Plugin.name; + Alcotest.(check string) "prog" "mytool" t.Plugin.prog; + Alcotest.(check (list string)) "list" [ "--list"; "--short" ] t.Plugin.list_args; + Alcotest.(check (option (list string))) + "install" + (Some [ "mytool"; "install"; "{id}" ]) + t.Plugin.install; + Alcotest.(check (option (list string))) + "upgrade" + (Some [ "mytool"; "upgrade"; "{id}" ]) + t.Plugin.upgrade; + Alcotest.(check (list app_triple)) + "parse" + [ "mytool", "1.2", "mytool" ] + (proj (t.Plugin.parse "mytool v1.2\n")) + | Ok _ -> Alcotest.fail "expected exactly one tool" +;; + +let load_minimal () = + match + Plugin.load_string ~source:"t" "(tools (tool (name n) (prog p) (row_re \"x\")))" + with + | Error e -> Alcotest.fail e + | Ok [ t ] -> + Alcotest.(check (list string)) "no list" [] t.Plugin.list_args; + Alcotest.(check (option (list string))) "no install" None t.Plugin.install; + Alcotest.(check (option (list string))) "no upgrade" None t.Plugin.upgrade + | Ok _ -> Alcotest.fail "expected exactly one tool" +;; + +let load_errors () = + let bad = + [ "(tool (name n))", "wrapper" + ; "(tools (tool (prog p) (row_re \"x\")))", "name" + ; "(tools (tool (name n) (prog p)))", "row_re" + ; "(tools (tool (name n) (prog p) (row_re \"x\") (bogus 1)))", "unknown field" + ; "(tools (tool (name n) (prog p) (row_re \"(\")))", "bad regex" + ; "(tools (tool (name n) (prog p) (row_re \"x\" \"y\")))", "single value" + ; "(oops", "parse error" + ] + in + List.iter + (fun (text, what) -> + match Plugin.load_string ~source:"t" text with + | Ok _ -> Alcotest.fail ("expected error: " ^ what) + | Error _ -> ()) + bad +;; + +let load_two () = + match + Plugin.load_string + ~source:"t" + "(tools (tool (name a) (prog a) (row_re \"x\")) (tool (name b) (prog b) (row_re \ + \"y\")))" + with + | Error e -> Alcotest.fail e + | Ok ts -> + Alcotest.(check (list string)) + "order" + [ "a"; "b" ] + (List.map (fun t -> t.Plugin.name) ts) +;; + +let file_absent () = + let names r = List.map (fun t -> t.Plugin.name) r in + Alcotest.(check (result (list string) string)) + "absent" + (Ok []) + (Result.map names (Plugin.load_file ~read:(fun _ -> None) "nope")) +;; + +let file_broken () = + match Plugin.load_file ~read:(fun _ -> Some "(oops") "bad.sexp" with + | Ok _ -> Alcotest.fail "expected error" + | Error _ -> () +;; + +let one_tool name = + "(tools (tool (name " ^ name ^ ") (prog " ^ name ^ ") (row_re \"x\")))" +;; + +let merge_first_wins () = + let read = function + | "a.sexp" -> Some (one_tool "aa") + | "b.sexp" -> + Some + "(tools (tool (name aa) (prog OTHER) (row_re \"x\")) (tool (name bb) (prog bb) \ + (row_re \"x\")))" + | _ -> None + in + match Plugin.load_many ~read [ "a.sexp"; "b.sexp"; "missing.sexp" ] with + | Error e -> Alcotest.fail e + | Ok ts -> + Alcotest.(check (list (pair string string))) + "first wins, order kept" + [ "aa", "aa"; "bb", "bb" ] + (List.map (fun t -> t.Plugin.name, t.Plugin.prog) ts) +;; + +let merge_reserved () = + let read _ = Some (one_tool "npm") in + match Plugin.load_many ~read ~reserved:[ "npm"; "winget" ] [ "a.sexp" ] with + | Ok _ -> Alcotest.fail "expected reserved-name error" + | Error _ -> () +;; + +let find_case () = + match Plugin.load_string ~source:"t" (one_tool "MyTool") with + | Error e -> Alcotest.fail e + | Ok ts -> + Alcotest.(check bool) "case-insensitive" true (Plugin.find "mytool" ts <> None); + Alcotest.(check bool) "missing" true (Plugin.find "zz" ts = None) +;; + +let scan_tool () = + match Plugin.load_string ~source:"t" basic_file with + | Error e -> Alcotest.fail e + | Ok [ t ] -> + Alcotest.(check (list app_triple)) + "runs list args" + [ "mytool", "1.2", "mytool" ] + (proj (Inventory.scan_tool (fun _ _ -> Some "mytool v1.2\n") t)); + Alcotest.(check (list app_triple)) + "missing binary skipped" + [] + (proj (Inventory.scan_tool (fun _ _ -> None) t)) + | Ok _ -> Alcotest.fail "expected exactly one tool" +;; + +let () = + Alcotest.run + "plugin" + [ ( "rows" + , [ Alcotest.test_case "skips" `Quick rows + ; Alcotest.test_case "unversioned" `Quick unversioned + ] ) + ; ( "expand" + , [ Alcotest.test_case "subst" `Quick expand_ok + ; Alcotest.test_case "plain" `Quick expand_plain + ; Alcotest.test_case "unknown" `Quick expand_unknown + ; Alcotest.test_case "unclosed" `Quick expand_unclosed + ] ) + ; ( "load" + , [ Alcotest.test_case "basic" `Quick load_basic + ; Alcotest.test_case "minimal" `Quick load_minimal + ; Alcotest.test_case "errors" `Quick load_errors + ; Alcotest.test_case "two tools" `Quick load_two + ] ) + ; ( "files" + , [ Alcotest.test_case "absent" `Quick file_absent + ; Alcotest.test_case "broken" `Quick file_broken + ; Alcotest.test_case "first wins" `Quick merge_first_wins + ; Alcotest.test_case "reserved" `Quick merge_reserved + ; Alcotest.test_case "find" `Quick find_case + ; Alcotest.test_case "scan_tool" `Quick scan_tool + ] ) + ] +;; diff --git a/test/test_winget.ml b/test/test_winget.ml new file mode 100644 index 0000000..0e9be03 --- /dev/null +++ b/test/test_winget.ml @@ -0,0 +1,109 @@ +(** Tests for {!Winget_parse}: winget list table parsing. *) + +open Devkit.Winget_parse + +let aligned_output = + "Name Id \ + Version Available Source\n" + ^ "--------------------------------------------------------------------------------------------------\n" + ^ "7-Zip 24.09 (x64) 7zip.7zip \ + 24.09 25.00 winget\n" + ^ "Brave Brave.Brave \ + 1.80.122 winget\n" + ^ "Microsoft Visual C++ 2015-2022 Redistributable (x64) - 14.44.35211 \ + Microsoft.VCRedist.2015+.x64 14.44.35211 Unknown winget\n" +;; + +let piped_output = + "Brave Brave.Brave 1.80.122 winget\n" ^ "Git Git.Git 2.47.1 2.48.0 winget\n" +;; + +let lookup m id = IdMap.find_opt (String.lowercase_ascii id) m + +let aligned () = + let m = parse_list_table aligned_output in + Alcotest.(check int) "three rows" 3 (IdMap.cardinal m); + (match lookup m "7zip.7zip" with + | None -> Alcotest.fail "7zip missing" + | Some inf -> + Alcotest.(check string) "name with spaces" "7-Zip 24.09 (x64)" inf.name; + Alcotest.(check string) "version" "24.09" inf.version; + Alcotest.(check string) "available" "25.00" inf.available; + Alcotest.(check string) "id case kept" "7zip.7zip" inf.id); + (match lookup m "Brave.Brave" with + | None -> Alcotest.fail "brave missing" + | Some inf -> + Alcotest.(check string) "no available" "" inf.available; + Alcotest.(check string) "version" "1.80.122" inf.version); + match lookup m "Microsoft.VCRedist.2015+.x64" with + | None -> Alcotest.fail "vcredist missing" + | Some inf -> + (* "Unknown" has no digit → not an available version. *) + Alcotest.(check string) "unknown ignored" "" inf.available; + Alcotest.(check string) + "long name" + "Microsoft Visual C++ 2015-2022 Redistributable (x64) - 14.44.35211" + inf.name +;; + +let piped () = + let m = parse_list_table piped_output in + Alcotest.(check int) "two rows" 2 (IdMap.cardinal m); + match lookup m "git.git" with + | None -> Alcotest.fail "git missing" + | Some inf -> Alcotest.(check string) "available" "2.48.0" inf.available +;; + +let header_and_separator_skipped () = + let m = parse_list_table "Nombre Id Versión\n───┼───┼──\nFoo.Bar 1.0 winget\n" in + (* "Foo.Bar 1.0 winget": single-space split → one column → skipped. *) + Alcotest.(check int) "nothing parsed" 0 (IdMap.cardinal m) +;; + +let same_version_no_update () = + let m = parse_list_table "Git Git.Git 2.48.0 2.48.0 winget\n" in + match lookup m "git.git" with + | None -> Alcotest.fail "git missing" + | Some inf -> Alcotest.(check string) "equal ignored" "" inf.available +;; + +let separator () = + Alcotest.(check bool) "dashes" true (is_winget_separator "------ ----"); + Alcotest.(check bool) "box drawing" true (is_winget_separator "─────┼─────┼────"); + Alcotest.(check bool) "empty false" false (is_winget_separator ""); + Alcotest.(check bool) "name false" false (is_winget_separator "Brave 1.0"); + Alcotest.(check bool) "version row false" false (is_winget_separator "Git.Git 2.47.1") +;; + +let versions () = + Alcotest.(check bool) "digits" true (looks_like_version "2.48.0"); + Alcotest.(check bool) "unknown" false (looks_like_version "Unknown"); + Alcotest.(check bool) "source" false (looks_like_version "winget") +;; + +let cols () = + Alcotest.(check (list string)) + "single spaces survive" + [ "7-Zip 24.09 (x64)"; "7zip.7zip"; "24.09" ] + (split_cols "7-Zip 24.09 (x64) 7zip.7zip 24.09") +;; + +let () = + Alcotest.run + "winget_parse" + [ ( "list table" + , [ Alcotest.test_case "aligned output" `Quick aligned + ; Alcotest.test_case "piped output" `Quick piped + ; Alcotest.test_case + "header/separator skipped" + `Quick + header_and_separator_skipped + ; Alcotest.test_case "equal version" `Quick same_version_no_update + ] ) + ; ( "helpers" + , [ Alcotest.test_case "separator" `Quick separator + ; Alcotest.test_case "versions" `Quick versions + ; Alcotest.test_case "columns" `Quick cols + ] ) + ] +;; diff --git a/test/test_winget_json.ml b/test/test_winget_json.ml new file mode 100644 index 0000000..961d757 --- /dev/null +++ b/test/test_winget_json.ml @@ -0,0 +1,89 @@ +open Devkit + +let apps = + [ Dashboard.{ name = "Git.Git"; version = "2.47.1"; pm = "winget" } + ; Dashboard.{ name = "Brave.Brave"; version = ""; pm = "winget" } + ; Dashboard.{ name = "ruff"; version = "0.16.8"; pm = "uv" } + ] +;; + +let json () = Winget_json.to_json ~now:0.0 apps + +let member name = function + | `Assoc kvs -> List.assoc_opt name kvs + | _ -> None +;; + +let shape () = + let j = json () in + Alcotest.(check (option string)) + "$schema" + (Some "https://aka.ms/winget-packages.schema.2.0.json") + (match member "$schema" j with + | Some (`String s) -> Some s + | _ -> None); + Alcotest.(check (option string)) + "creation date" + (Some "1970-01-01T00:00:00.000-00:00") + (match member "CreationDate" j with + | Some (`String s) -> Some s + | _ -> None); + let src = + match member "Sources" j with + | Some (`List [ s ]) -> s + | _ -> `Assoc [] + in + let det = + match member "SourceDetails" src with + | Some d -> d + | None -> `Assoc [] + in + Alcotest.(check (option string)) + "source name" + (Some "winget") + (match member "Name" det with + | Some (`String s) -> Some s + | _ -> None); + let pkgs = + match member "Packages" src with + | Some (`List l) -> l + | _ -> [] + in + Alcotest.(check int) "winget only" 2 (List.length pkgs); + let ids = + List.filter_map + (fun p -> + match member "PackageIdentifier" p with + | Some (`String s) -> Some s + | _ -> None) + pkgs + in + Alcotest.(check (list string)) "ids" [ "Git.Git"; "Brave.Brave" ] ids; + let vers = + List.filter_map + (fun p -> + match member "Version" p with + | Some (`String s) -> Some s + | _ -> None) + pkgs + in + Alcotest.(check (list string)) "empty version omitted" [ "2.47.1" ] vers +;; + +let string_ends_newline () = + let s = Winget_json.to_string ~now:0.0 apps in + Alcotest.(check bool) + "trailing newline" + true + (String.length s > 0 && s.[String.length s - 1] = '\n') +;; + +let () = + Alcotest.run + "winget_json" + [ ( "export" + , [ Alcotest.test_case "schema shape" `Quick shape + ; Alcotest.test_case "string" `Quick string_ends_newline + ] ) + ] +;; diff --git a/test/test_zipx.ml b/test/test_zipx.ml new file mode 100644 index 0000000..efcb4f4 --- /dev/null +++ b/test/test_zipx.ml @@ -0,0 +1,114 @@ +(** Tests for {!Devkit.Zipx}: good archive round-trip (stored + deflated + + dirs), ZipSlip refusal, [safe_path] units. Fixtures live in + [test/fixtures/], generated by the python3 snippet in the Phase 3 plan + (to regenerate, see AGENTS.md). *) +open Devkit + +let with_temp_dir f = + let dir = Filename.temp_dir "devkit-zipx-" "" in + let r = f dir in + let rec rm p = + if Sys.is_directory p + then ( + Array.iter (fun e -> rm (Filename.concat p e)) (Sys.readdir p); + Unix.rmdir p) + else Sys.remove p + in + (try rm dir with + | _ -> ()); + r +;; + +let read_file path = + let ic = open_in_bin path in + let n = in_channel_length ic in + let s = really_input_string ic n in + close_in ic; + s +;; + +let test_good_zip () = + with_temp_dir (fun dest -> + (match Zipx.extract ~zip_path:"fixtures/good.zip" ~dest_dir:dest with + | Error e -> Alcotest.fail ("extract: " ^ e) + | Ok () -> ()); + Alcotest.(check string) + "stored" + "hello" + (read_file (Filename.concat dest "hello.txt")); + Alcotest.(check string) + "deflated nested" + "nested-content" + (read_file (Filename.concat (Filename.concat dest "dir") "nested.txt")); + Alcotest.(check bool) + "empty dir" + true + (Sys.file_exists (Filename.concat dest "empty-dir") + && Sys.is_directory (Filename.concat dest "empty-dir"))) +;; + +let test_evil_zip () = + with_temp_dir (fun dest -> + (match Zipx.extract ~zip_path:"fixtures/evil.zip" ~dest_dir:dest with + | Ok () -> Alcotest.fail "expected ZipSlip refusal" + | Error e -> + Alcotest.(check bool) + "ZipSlip message" + true + (Strutil.contains_substring "ZipSlip" e)); + (* Entries before the hostile one are already written (documented); + nothing escapes the destination. *) + Alcotest.(check string) + "prior entry kept" + "ok" + (read_file (Filename.concat dest "ok.txt")); + Alcotest.(check bool) + "no escape" + false + (Sys.file_exists (Filename.concat (Filename.dirname dest) "evil.txt"))) +;; + +let test_garbage () = + with_temp_dir (fun dest -> + match Zipx.extract ~zip_path:"fixtures/does-not-exist.zip" ~dest_dir:dest with + | Ok () -> Alcotest.fail "expected missing-file error" + | Error _ -> ()); + match Zipx.list_entries (Bytes.of_string "not a zip at all, far too short!!") with + | Ok _ -> Alcotest.fail "expected EOCD error" + | Error _ -> () +;; + +let check_safe name expected = + match Zipx.safe_path ~dest:"/dest" name with + | None -> Alcotest.(check bool) name true (expected = None) + | Some (p, is_dir) -> + (match expected with + | None -> Alcotest.fail ("expected refusal: " ^ name) + | Some (ep, edir) -> + Alcotest.(check string) (name ^ " path") ep p; + Alcotest.(check bool) (name ^ " is_dir") edir is_dir) +;; + +let test_safe_paths () = + check_safe "/abs.txt" None; + check_safe "../evil.txt" None; + check_safe "a/../../escape.txt" None; + check_safe {|C:\win.txt|} None; + check_safe {|..\evil.txt|} None; + check_safe "" None; + check_safe "ok.txt" (Some ("/dest" ^ Filename.dir_sep ^ "ok.txt", false)); + check_safe "dir/" (Some ("/dest" ^ Filename.dir_sep ^ "dir", true)); + check_safe + "a/./b.txt" + (Some ("/dest" ^ Filename.dir_sep ^ "a" ^ Filename.dir_sep ^ "b.txt", false)) +;; + +let () = + Alcotest.run + "zipx" + [ "extract", [ Alcotest.test_case "good zip" `Quick test_good_zip ] + ; "zipslip", [ Alcotest.test_case "evil zip refused" `Quick test_evil_zip ] + ; "robustness", [ Alcotest.test_case "garbage rejected" `Quick test_garbage ] + ; "safe_path", [ Alcotest.test_case "units" `Quick test_safe_paths ] + ] +;; From 426d32c623d825164b04a330b5855c52004be225 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 01:14:45 +0000 Subject: [PATCH 02/34] Add interactive notty TUI Pure state machine in lib/tui plus a keyboard-only notty frontend; default command uses it on a tty, plain text when piped. --- bin/dune | 3 +- bin/main.ml | 23 +++--- bin/tui_front.ml | 107 ++++++++++++++++++++++++++ lib/app.ml | 118 ++++++++++++++++------------- lib/app.mli | 6 +- lib/dashboard.ml | 4 +- lib/dashboard.mli | 8 +- lib/tui.ml | 188 ++++++++++++++++++++++++++++++++++++++++++++++ lib/tui.mli | 47 ++++++++++++ test/dune | 6 +- test/test_tui.ml | 135 +++++++++++++++++++++++++++++++++ 11 files changed, 571 insertions(+), 74 deletions(-) create mode 100644 bin/tui_front.ml create mode 100644 lib/tui.ml create mode 100644 lib/tui.mli create mode 100644 test/test_tui.ml diff --git a/bin/dune b/bin/dune index d6467d1..69a97d4 100644 --- a/bin/dune +++ b/bin/dune @@ -1,4 +1,5 @@ (executable (public_name devkit) (name main) - (libraries devkit cmdliner unix)) + (modules main tui_front) + (libraries devkit cmdliner unix notty.unix)) diff --git a/bin/main.ml b/bin/main.ml index 1a26392..9299644 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,8 +1,8 @@ (** devkit CLI. Commands: default (dashboard), import, add, append [--new], export - [-o]. The default view prints the plain-text dashboard; the - interactive TUI arrives in Phase 5. *) + [-o]. The default command opens the interactive TUI on a terminal and + prints the plain-text dashboard when piped. *) open Devkit @@ -64,7 +64,11 @@ let default_term = Cmdliner.Term.( const (fun () -> let tools = load_tools () in - print_string (App.default_view ~tools (make_env ()))) + let env = make_env () in + (* Piped output stays plain text; a terminal gets the TUI. *) + if Unix.isatty Unix.stdout + then Tui_front.run ~tools env + else print_string (App.default_view ~tools env)) $ const ()) ;; @@ -72,7 +76,7 @@ let default_info = Cmdliner.Cmd.info "devkit" ~doc: - "Scan your PC for installed software and manage packages. With pkgs.txt: shows \ + "Scan your PC for installed software and manage packages. With devkit.toml: shows \ status. Without: shows everything installed." ;; @@ -94,15 +98,14 @@ let add_cmd = let ids = Cmdliner.Arg.(non_empty & pos_all string [] & info [] ~docv:"ID") in let run ids = print_lines (App.run_add ~tools:(load_tools ()) (make_env ()) ids) in Cmdliner.Cmd.v - (Cmdliner.Cmd.info "add" ~doc:"Append specific installed apps to pkgs.txt") + (Cmdliner.Cmd.info "add" ~doc:"Append specific installed apps to devkit.toml") Cmdliner.Term.(const run $ ids) ;; let append_cmd = let ids = Cmdliner.Arg.(value & pos_all string [] & info [] ~docv:"ID") in let is_new = - Cmdliner.Arg.( - value & flag & info [ "new" ] ~doc:"append all newly-detected apps (no TUI yet)") + Cmdliner.Arg.(value & flag & info [ "new" ] ~doc:"append all newly-detected apps") in let run ids is_new = let tools = load_tools () in @@ -114,7 +117,7 @@ let append_cmd = Cmdliner.Cmd.v (Cmdliner.Cmd.info "append" - ~doc:"Append newly-detected apps (or given ids) to pkgs.txt") + ~doc:"Append newly-detected apps (or given ids) to devkit.toml") Cmdliner.Term.(const run $ ids $ is_new) ;; @@ -122,7 +125,7 @@ let export_cmd = let output = Cmdliner.Arg.( value - & opt string "pkgs.txt" + & opt string Manifest.filename & info [ "o"; "output" ] ~docv:"FILE" ~doc:"output file path") in let run output = @@ -131,7 +134,7 @@ let export_cmd = Cmdliner.Cmd.v (Cmdliner.Cmd.info "export" - ~doc:"Scan PC and write all installed software to pkgs.txt") + ~doc:"Scan PC and write all installed software to devkit.toml") Cmdliner.Term.(const run $ output) ;; diff --git a/bin/tui_front.ml b/bin/tui_front.ml new file mode 100644 index 0000000..d2b2e24 --- /dev/null +++ b/bin/tui_front.ml @@ -0,0 +1,107 @@ +(** Notty frontend for the dashboard state machine. + + Draws {!Devkit.Tui.frame} lines, feeds key events in, runs installs on + Enter. On exit the plain-text dashboard plus the install log go to + stdout, so redirected output stays usable. *) + +open Devkit +open Notty +open Notty_unix + +let kind_of : Manifest.item_type -> string = function + | Manifest.Winget -> "winget" + | Manifest.GitHub -> "github" + | Manifest.Url -> "url" + | Manifest.Pm s -> s +;; + +let draw (st : Tui.state) : image = + let lines = Tui.frame st in + let img_of_line i line = + let attr = + if i = 0 + then A.(st bold) + else if String.length line >= 2 && String.sub line 0 2 = "> " + then A.(st reverse) + else A.empty + in + I.string attr line + in + I.vcat (List.mapi img_of_line lines) +;; + +type ev = + [ Notty.Unescape.event + | `Resize of int * int + | `End + ] + +let quit_key : ev -> bool = function + | `End -> true + | `Key (`Escape, _) -> true + | `Key (`ASCII 'q', _) | `Key (`ASCII 'Q', _) -> true + | `Key (_, mods) -> List.mem `Ctrl mods + | _ -> false +;; + +let nav : ev -> Tui.action option = function + | `Key (`Arrow `Up, _) | `Key (`ASCII 'k', _) -> Some Tui.Up + | `Key (`Arrow `Down, _) | `Key (`ASCII 'j', _) -> Some Tui.Down + | `Key (`Page `Up, _) -> Some Tui.Page_up + | `Key (`Page `Down, _) -> Some Tui.Page_down + | `Key (`Home, _) -> Some Tui.Home + | `Key (`End, _) -> Some Tui.End + | _ -> None +;; + +let press_enter (deps : Install.deps) (st : Tui.state) : Tui.state = + match Tui.enter_action st with + | Tui.Do_nothing -> st + | Tui.Do_install item -> + let update = item.Manifest.status = Manifest.NeedsUpdate in + let o = Install.install deps (kind_of item.Manifest.typ) item.Manifest.value update in + Tui.apply_outcome st item.Manifest.value o + | Tui.Do_open url -> + (match deps.Install.open_browser url with + | Ok () -> + let o = { Install.value = url; status = Install.Opened } in + Tui.apply_outcome st url o + | Error e -> + let o = { Install.value = url; status = Install.Failed e } in + Tui.apply_outcome st url o) +;; + +let viewport (w : int) (h : int) : int * int = max 1 w, max 1 (h - 3) + +let run ~(tools : Plugin.tool list) (env : App.env) : unit = + let sections, winget_path = App.load_manifest env.App.fs Manifest.filename in + let s = App.scan env ~override_path:winget_path ~extra:tools in + let show id = + match App.winget_show env.App.bio s.App.winget id with + | "" -> None + | v -> Some v + in + let dash = Dashboard.build_sections ~show s.App.apps sections s.App.info in + let fetch = Fetch.curl_fetch Proc.default_runner in + let deps = Install.real_deps fetch ~winget_override:winget_path () in + let term = Term.create () in + let w, h = Term.size term in + let vw, vh = viewport w h in + let rec loop (st : Tui.state) : Tui.state = + Term.image term (draw st); + match Term.event term with + | ev when quit_key ev -> st + | `Key (`Enter, _) -> loop (press_enter deps st) + | `Resize (w, h) -> + let vw, vh = viewport w h in + loop (Tui.resize st ~height:vh ~width:vw) + | ev -> + (match nav ev with + | Some a -> loop (Tui.step st a) + | None -> loop st) + in + let final = loop (Tui.make dash ~height:vh ~width:vw) in + Term.release term; + print_string (Dashboard.render dash); + List.iter print_endline final.Tui.log +;; diff --git a/lib/app.ml b/lib/app.ml index 53e71a7..656e5d1 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -10,13 +10,12 @@ - No silent manifest rewrite: it would destroy user edits, so it stays out. - No dead append helper: only wired commands ship. - - [--new] appends every newly-detected app; TUI selection lands in - Phase 5. + - [--new] appends every newly-detected app. - [winget show] enrichment runs sequentially; parallelize when it measurably hurts. - pm order: [winget; npm; pipx; uv; cargo]. *) -open Pkgfile +open Manifest open Dashboard let pm_order = [ "winget"; "npm"; "pipx"; "uv"; "cargo" ] @@ -35,13 +34,12 @@ type env = let lower s = String.lowercase_ascii s -(** [parsePkgFile]: missing/unparseable file yields empty sections, as Go - ignores both errors. *) +(** Missing/unparseable file yields empty sections. *) let load_manifest (fs : fs) (path : string) : section list * string = match fs.read_file path with | None -> [], "" | Some text -> - let r = Pkgfile.parse text in + let r = Manifest.parse text in r.sections, r.winget_path ;; @@ -132,10 +130,10 @@ let to_dashboard_apps (apps : app list) : Dashboard.app list = apps ;; -(** Default view: scan, enrich, merge with pkgs.txt, render plain text. - Returns the rendered dashboard (the TUI takes over in Phase 5). *) +(** Default view: scan, enrich, merge with the manifest, render plain + text. Returns the rendered dashboard (the TUI takes over on a tty). *) let default_view (e : env) ~(tools : Plugin.tool list) : string = - let sections, winget_path = load_manifest e.fs "pkgs.txt" in + let sections, winget_path = load_manifest e.fs Manifest.filename in let s = scan e ~override_path:winget_path ~extra:tools in let show id = let v = winget_show e.bio s.winget id in @@ -151,7 +149,7 @@ let import_view (e : env) ?(tools : Plugin.tool list = []) (path : string) match e.fs.read_file path with | None -> Error ("open: " ^ path) | Some text -> - let r = Pkgfile.parse text in + let r = Manifest.parse text in let s = scan e ~override_path:r.winget_path ~extra:tools in let show id = let v = winget_show e.bio s.winget id in @@ -160,29 +158,25 @@ let import_view (e : env) ?(tools : Plugin.tool list = []) (path : string) Ok (render (build_sections ~show (to_dashboard_apps s.apps) r.sections s.info)) ;; -let type_string = function - | Winget -> "winget" - | GitHub -> "github" - | Url -> "url" -;; - -(** [appendSelected]: persists items under a "# Newly detected" section, +(** [appendSelected]: persists items under a "Newly detected" section, grouped in pm order. Existing entries are never touched. *) let append_selected (fs : fs) (path : string) (items : item list) : (unit, string) result = if items = [] then Ok () else ( - let buf = Buffer.create 256 in - Buffer.add_string buf "\n# Newly detected\n"; - List.iter - (fun pm -> - List.iter - (fun it -> - if type_string it.typ = pm - then Buffer.add_string buf (Printf.sprintf "%s:%s\n" pm it.value)) - items) - pm_order; - fs.append_file path (Buffer.contents buf)) + let ordered = + List.concat_map + (fun pm -> List.filter (fun it -> Manifest.type_string it.typ = pm) items) + pm_order + in + let text = + "\n" + ^ Manifest.to_string + { sections = [ { name = "Newly detected"; items = ordered } ] + ; winget_path = "" + } + in + fs.append_file path text) ;; let is_new_section (sec : section) : bool = @@ -213,7 +207,7 @@ let run_add (e : env) ?(tools : Plugin.tool list = []) (ids : string list) : str if a.pm = "winget" && a.name <> "" then Hashtbl.replace installed (lower a.name) true) s.apps; - let sections, _ = load_manifest e.fs "pkgs.txt" in + let sections, _ = load_manifest e.fs Manifest.filename in let known = Hashtbl.create 64 in List.iter (fun (sec : section) -> @@ -249,10 +243,14 @@ let run_add (e : env) ?(tools : Plugin.tool list = []) (ids : string list) : str (match List.rev !to_append with | [] -> emit " nothing to append" | items -> - (match append_selected e.fs "pkgs.txt" items with + (match append_selected e.fs Manifest.filename items with | Error e -> emit (" error: " ^ e) | Ok () -> - emit (Printf.sprintf " appended %d app(s) to pkgs.txt" (List.length items)))); + emit + (Printf.sprintf + " appended %d app(s) to %s" + (List.length items) + Manifest.filename))); List.rev !msgs ;; @@ -265,38 +263,45 @@ let run_append (e : env) ?(tools : Plugin.tool list = []) (ids : string list) then run_add e ~tools ids else ( let s = scan e ~override_path:"" ~extra:tools in - let sections, _ = load_manifest e.fs "pkgs.txt" in + let sections, _ = load_manifest e.fs Manifest.filename in let dash = build_sections (to_dashboard_apps s.apps) sections s.info in let items = new_items ~extra:true dash in if items = [] then [ " nothing new to append" ] else ( - match append_selected e.fs "pkgs.txt" items with + match append_selected e.fs Manifest.filename items with | Error e -> [ " error: " ^ e ] - | Ok () -> [ Printf.sprintf " appended %d app(s) to pkgs.txt" (List.length items) ])) + | Ok () -> + [ Printf.sprintf + " appended %d app(s) to %s" + (List.length items) + Manifest.filename + ])) ;; (** [runAppendNew] (--new): newly-detected apps only (no pending updates). *) let run_append_new (e : env) ~(tools : Plugin.tool list) : string list = let s = scan e ~override_path:"" ~extra:tools in - let sections, _ = load_manifest e.fs "pkgs.txt" in + let sections, _ = load_manifest e.fs Manifest.filename in let dash = build_sections (to_dashboard_apps s.apps) sections s.info in let items = new_items dash in if items = [] then [ " no newly detected apps" ] else ( - match append_selected e.fs "pkgs.txt" items with + match append_selected e.fs Manifest.filename items with | Error e -> [ " error: " ^ e ] - | Ok () -> [ Printf.sprintf " appended %d app(s) to pkgs.txt" (List.length items) ]) + | Ok () -> + [ Printf.sprintf " appended %d app(s) to %s" (List.length items) Manifest.filename + ]) ;; (** [runExport]: scan → write manifest grouped in pm order, plus a [winget import]-compatible JSON next to it (same basename, [.json] extension). Only winget-tracked apps land in the JSON; the rest live - in the pkgs file alone. *) + in the manifest alone. *) let json_sibling (output : string) : string = - if Filename.check_suffix output ".txt" - then Filename.chop_suffix output ".txt" ^ ".json" + if Filename.check_suffix output ".toml" + then Filename.chop_suffix output ".toml" ^ ".json" else output ^ ".json" ;; @@ -314,19 +319,26 @@ let run_export (e : env) ?(tools : Plugin.tool list = []) (output : string) : st if s.apps = [] then [ " no installed software found" ] else ( - let buf = Buffer.create 512 in - Buffer.add_string buf "# Generated by devkit export\n"; - List.iter - (fun pm -> - let apps = List.filter (fun (a : app) -> a.pm = pm) s.apps in - if apps <> [] - then ( - Buffer.add_string buf (Printf.sprintf "\n# %s\n" pm); - List.iter - (fun (a : app) -> Buffer.add_string buf (Printf.sprintf "%s:%s\n" pm a.name)) - apps)) - (order_for tools); - match e.fs.write_file output (Buffer.contents buf) with + let sections = + List.filter_map + (fun pm -> + let apps = List.filter (fun (a : app) -> a.pm = pm) s.apps in + match apps with + | [] -> None + | _ -> + Some + { name = pm + ; items = + List.map + (fun (a : app) -> + { (make_item (Manifest.item_type_of_string a.pm) a.name) with + installed_version = a.version + }) + apps + }) + (order_for tools) + in + match e.fs.write_file output (Manifest.to_string { sections; winget_path = "" }) with | Error e -> [ " error: " ^ e ] | Ok () -> let json_path = json_sibling output in diff --git a/lib/app.mli b/lib/app.mli index c952525..ee89d16 100644 --- a/lib/app.mli +++ b/lib/app.mli @@ -21,14 +21,14 @@ type scan = } (** Missing/unparseable file yields empty sections. *) -val load_manifest : fs -> string -> Pkgfile.section list * string +val load_manifest : fs -> string -> Manifest.section list * string val winget_show : Bootstrap.io -> string -> string -> string val scan : env -> override_path:string -> extra:Plugin.tool list -> scan val default_view : env -> tools:Plugin.tool list -> string val import_view : env -> ?tools:Plugin.tool list -> string -> (string, string) result -val append_selected : fs -> string -> Pkgfile.item list -> (unit, string) result -val new_items : ?extra:bool -> Pkgfile.section list -> Pkgfile.item list +val append_selected : fs -> string -> Manifest.item list -> (unit, string) result +val new_items : ?extra:bool -> Manifest.section list -> Manifest.item list val run_add : env -> ?tools:Plugin.tool list -> string list -> string list val run_append : env -> ?tools:Plugin.tool list -> string list -> string list val run_append_new : env -> tools:Plugin.tool list -> string list diff --git a/lib/dashboard.ml b/lib/dashboard.ml index 2128ff4..f197342 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -4,7 +4,7 @@ here it is an injectable [?show] function ([None] by default) so the merge stays pure and testable. *) -open Pkgfile +open Manifest type app = { name : string @@ -82,7 +82,7 @@ let build_sections } else { it with status = Installed } | None -> { it with status = NotFound }) - | GitHub | Url -> { it with status = Manual } + | GitHub | Url | Pm _ -> { it with status = Manual } in let it = if it.status <> Installed && it.status <> NeedsUpdate diff --git a/lib/dashboard.mli b/lib/dashboard.mli index d943b59..c7999f5 100644 --- a/lib/dashboard.mli +++ b/lib/dashboard.mli @@ -6,7 +6,7 @@ type app = ; pm : string } -val format_ver : Pkgfile.item -> string +val format_ver : Manifest.item -> string (** Merge the machine scan with manifest sections into dashboard sections: "Pending updates", "Newly detected", then the manifest sections minus @@ -15,9 +15,9 @@ val format_ver : Pkgfile.item -> string val build_sections : ?show:(string -> string option) -> app list - -> Pkgfile.section list + -> Manifest.section list -> Winget_parse.info Winget_parse.IdMap.t option - -> Pkgfile.section list + -> Manifest.section list (** Plain-text dashboard. Empty sections and "Newly detected" are skipped. *) -val render : Pkgfile.section list -> string +val render : Manifest.section list -> string diff --git a/lib/tui.ml b/lib/tui.ml new file mode 100644 index 0000000..d8d8b94 --- /dev/null +++ b/lib/tui.ml @@ -0,0 +1,188 @@ +(** Interactive dashboard state machine. + + Pure navigation, selection and frame rendering over dashboard sections. + The notty frontend in [bin/] draws the frame and feeds key actions in; + tests drive [step] and [frame] without a terminal. Row selection + mirrors [Dashboard.render]: empty sections and "Newly detected" are + skipped. *) + +open Manifest + +type entry = + { section : string + ; item : item + } + +(** Flatten sections to selectable rows, skipping empties and Newly + detected (same rule as the plain renderer). *) +let build_entries (sections : section list) : entry list = + List.concat_map + (fun (sec : section) -> + if sec.items = [] || String.lowercase_ascii sec.name = "newly detected" + then [] + else List.map (fun item -> { section = sec.name; item }) sec.items) + sections +;; + +type state = + { entries : entry list + ; cursor : int + ; offset : int + ; height : int + ; width : int + ; message : string option + ; log : string list + } + +let make (sections : section list) ~(height : int) ~(width : int) : state = + { entries = build_entries sections + ; cursor = 0 + ; offset = 0 + ; height = max 1 height + ; width = max 1 width + ; message = None + ; log = [] + } +;; + +let max_cursor (s : state) : int = max 0 (List.length s.entries - 1) + +(** Keep cursor in range and the viewport pinned to it. *) +let clamp (s : state) : state = + let cursor = min (max 0 s.cursor) (max_cursor s) in + let offset = + if cursor < s.offset + then cursor + else if cursor >= s.offset + s.height + then cursor - s.height + 1 + else s.offset + in + { s with cursor; offset } +;; + +let resize (s : state) ~(height : int) ~(width : int) : state = + clamp { s with height = max 1 height; width = max 1 width } +;; + +type action = + | Up + | Down + | Page_up + | Page_down + | Home + | End + | Quit + +let step (s : state) (a : action) : state = + let cursor = + match a with + | Up -> s.cursor - 1 + | Down -> s.cursor + 1 + | Page_up -> s.cursor - s.height + | Page_down -> s.cursor + s.height + | Home -> 0 + | End -> max_cursor s + | Quit -> s.cursor + in + clamp { s with cursor; message = None } +;; + +let selected (s : state) : entry option = List.nth_opt s.entries s.cursor + +(** What Enter does on the cursor row: installable statuses run the + installer, Manual rows open the URL, anything else is a no-op. *) +type enter = + | Do_install of item + | Do_open of string + | Do_nothing + +let enter_action (s : state) : enter = + match selected s with + | None -> Do_nothing + | Some e -> + (match e.item.status with + | NeedsUpdate | NotFound -> Do_install e.item + | Manual -> Do_open e.item.value + | Installed | New -> Do_nothing) +;; + +let symbol : status -> string = function + | Installed -> "ok" + | NeedsUpdate -> "update" + | NotFound -> "new" + | New -> "?" + | Manual -> "manual" +;; + +let row_text (e : entry) : string = + Printf.sprintf + "%s %s %s" + (symbol e.item.status) + e.item.value + (Dashboard.format_ver e.item) +;; + +let visible (s : state) : entry list = + let rec drop n l = + if n <= 0 + then l + else ( + match l with + | [] -> [] + | _ :: t -> drop (n - 1) t) + in + let rec take n l = + if n <= 0 + then [] + else ( + match l with + | [] -> [] + | h :: t -> h :: take (n - 1) t) + in + take s.height (drop s.offset s.entries) +;; + +(** Text frame: header, legend, visible rows (cursor marked), message, + footer. The notty frontend draws one line per string. *) +let frame (s : state) : string list = + let header = "devkit — enter installs/updates, q quits" in + let legend = "ok installed · update pending · new missing · manual link" in + let rows = + List.mapi + (fun i e -> + let mark = if s.offset + i = s.cursor then "> " else " " in + mark ^ row_text e) + (visible s) + in + let footer = + match s.message with + | Some m -> m + | None -> + Printf.sprintf + "%d/%d" + (min (s.cursor + 1) (List.length s.entries)) + (List.length s.entries) + in + (header :: legend :: rows) @ [ footer ] +;; + +(** Record an install outcome: refresh the row status, append the log. *) +let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = + let status = + match o.Install.status with + | Install.Installed | Install.Updated -> Installed + | Install.Opened -> Manual + | Install.Skipped _ | Install.Failed _ -> + (match selected s with + | Some e when e.item.value = value -> e.item.status + | _ -> NotFound) + in + let entries = + List.map + (fun e -> + if e.item.value = value then { e with item = { e.item with status } } else e) + s.entries + in + let line = Printf.sprintf "%s: %s" value (Install.status_to_string o.Install.status) in + clamp { s with entries; message = Some line; log = s.log @ [ line ] } +;; diff --git a/lib/tui.mli b/lib/tui.mli new file mode 100644 index 0000000..096f25c --- /dev/null +++ b/lib/tui.mli @@ -0,0 +1,47 @@ +(** Interactive dashboard state machine (pure navigation + frame). *) + +open Manifest + +type entry = + { section : string + ; item : item + } + +val build_entries : section list -> entry list + +type state = + { entries : entry list + ; cursor : int + ; offset : int + ; height : int + ; width : int + ; message : string option + ; log : string list + } + +val make : section list -> height:int -> width:int -> state +val clamp : state -> state +val resize : state -> height:int -> width:int -> state + +type action = + | Up + | Down + | Page_up + | Page_down + | Home + | End + | Quit + +val step : state -> action -> state +val selected : state -> entry option + +type enter = + | Do_install of item + | Do_open of string + | Do_nothing + +val enter_action : state -> enter +val row_text : entry -> string +val visible : state -> entry list +val frame : state -> string list +val apply_outcome : state -> string -> Install.outcome -> state diff --git a/test/dune b/test/dune index 5121345..df6ba36 100644 --- a/test/dune +++ b/test/dune @@ -1,5 +1,5 @@ (test - (name test_pkgfile) + (name test_manifest) (libraries devkit alcotest)) (test @@ -47,3 +47,7 @@ (test (name test_plugin) (libraries devkit alcotest re sexplib)) + +(test + (name test_tui) + (libraries devkit alcotest)) diff --git a/test/test_tui.ml b/test/test_tui.ml new file mode 100644 index 0000000..9067e9b --- /dev/null +++ b/test/test_tui.ml @@ -0,0 +1,135 @@ +open Devkit + +let item status value = + { Manifest.typ = Manifest.Winget + ; value + ; installed_version = "1.0" + ; available_version = "" + ; status + } +;; + +let sections () = + [ { Manifest.name = "tools" + ; items = [ item Manifest.Installed "a"; item Manifest.NeedsUpdate "b" ] + } + ; { Manifest.name = "Newly detected"; items = [ item Manifest.New "c" ] } + ; { Manifest.name = "empty"; items = [] } + ; { Manifest.name = "more"; items = [ item Manifest.Manual "https://x" ] } + ] +;; + +let build_skips () = + let e = Tui.build_entries (sections ()) in + Alcotest.(check (list string)) + "values" + [ "a"; "b"; "https://x" ] + (List.map (fun x -> x.Tui.item.Manifest.value) e) +;; + +let nav_clamp () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let s = Tui.step s Tui.Up in + Alcotest.(check int) "stays at 0" 0 s.Tui.cursor; + let s = Tui.step s Tui.End in + Alcotest.(check int) "end" 2 s.Tui.cursor; + let s = Tui.step s Tui.Down in + Alcotest.(check int) "stays at end" 2 s.Tui.cursor; + let s = Tui.step s Tui.Home in + Alcotest.(check int) "home" 0 s.Tui.cursor +;; + +let paging () = + let s = Tui.make (sections ()) ~height:2 ~width:80 in + let s = Tui.step s Tui.Page_down in + Alcotest.(check int) "cursor" 2 s.Tui.cursor; + Alcotest.(check int) "offset follows" 1 s.Tui.offset; + Alcotest.(check int) "visible" 2 (List.length (Tui.visible s)) +;; + +let enter_mapping () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + (match Tui.enter_action s with + | Tui.Do_nothing -> () + | _ -> Alcotest.fail "installed is noop"); + let s = Tui.step s Tui.Down in + (match Tui.enter_action s with + | Tui.Do_install it -> Alcotest.(check string) "value" "b" it.Manifest.value + | _ -> Alcotest.fail "needsupdate installs"); + let s = Tui.step s Tui.Down in + match Tui.enter_action s with + | Tui.Do_open u -> Alcotest.(check string) "url" "https://x" u + | _ -> Alcotest.fail "manual opens" +;; + +let enter_notfound () = + let s = + Tui.make + [ { Manifest.name = "t"; items = [ item Manifest.NotFound "n" ] } ] + ~height:10 + ~width:80 + in + match Tui.enter_action s with + | Tui.Do_install _ -> () + | _ -> Alcotest.fail "notfound installs" +;; + +let apply_success () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let s = Tui.step s Tui.Down in + let o = { Install.value = "b"; status = Install.Updated } in + let s = Tui.apply_outcome s "b" o in + (match Tui.selected s with + | Some e -> + Alcotest.(check bool) + "now installed" + true + (e.Tui.item.Manifest.status = Manifest.Installed) + | None -> Alcotest.fail "no selection"); + Alcotest.(check int) "one log line" 1 (List.length s.Tui.log) +;; + +let apply_failure_keeps () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let s = Tui.step s Tui.Down in + let o = { Install.value = "b"; status = Install.Failed "denied" } in + let s = Tui.apply_outcome s "b" o in + match Tui.selected s with + | Some e -> + Alcotest.(check bool) + "status kept" + true + (e.Tui.item.Manifest.status = Manifest.NeedsUpdate) + | None -> Alcotest.fail "no selection" +;; + +let frame_shape () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let f = Tui.frame s in + Alcotest.(check int) "header+legend+3rows+footer" 6 (List.length f); + Alcotest.(check bool) + "cursor marked" + true + (let row = List.nth f 2 in + String.length row >= 2 && String.sub row 0 2 = "> ") +;; + +let () = + Alcotest.run + "tui" + [ "entries", [ Alcotest.test_case "skips" `Quick build_skips ] + ; ( "nav" + , [ Alcotest.test_case "clamp" `Quick nav_clamp + ; Alcotest.test_case "paging" `Quick paging + ] ) + ; ( "enter" + , [ Alcotest.test_case "mapping" `Quick enter_mapping + ; Alcotest.test_case "notfound" `Quick enter_notfound + ] ) + ; ( "outcome" + , [ Alcotest.test_case "success" `Quick apply_success + ; Alcotest.test_case "failure keeps" `Quick apply_failure_keeps + ] ) + ; "frame", [ Alcotest.test_case "shape" `Quick frame_shape ] + ] +;; From 950f493fb6a44749352f4d99428cc1ff825b1353 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 01:14:49 +0000 Subject: [PATCH 03/34] Replace pkgs.txt with devkit.toml manifest TOML schema with per-package pm/id/version fields and a Pm fallback type so every manager round-trips. Drops pkgfile and all pkgs.txt references; adds CI workflow and notty patch. --- .github/workflows/ci.yml | 51 +++++++++++ README.md | 10 +- ci/notty-ocaml55.patch | 28 ++++++ devkit.opam | 4 +- dune-project | 6 +- lib/dune | 4 +- lib/manifest.ml | 147 ++++++++++++++++++++++++++++++ lib/{pkgfile.mli => manifest.mli} | 9 +- lib/pkgfile.ml | 105 --------------------- lib/plugin.ml | 4 +- test/test_app.ml | 88 ++++++++++++------ test/test_dashboard.ml | 2 +- test/test_manifest.ml | 84 +++++++++++++++++ test/test_pkgfile.ml | 116 ----------------------- 14 files changed, 394 insertions(+), 264 deletions(-) create mode 100644 .github/workflows/ci.yml create mode 100644 ci/notty-ocaml55.patch create mode 100644 lib/manifest.ml rename lib/{pkgfile.mli => manifest.mli} (62%) delete mode 100644 lib/pkgfile.ml create mode 100644 test/test_manifest.ml delete mode 100644 test/test_pkgfile.ml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..a7b394f --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,51 @@ +name: CI + +on: + push: + pull_request: + +jobs: + build: + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest, windows-latest] + runs-on: ${{ matrix.os }} + steps: + - uses: actions/checkout@v4 + + - uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: 5.5 + dune-cache: true + + # Release notty caps ocaml < 5.4; master builds on 5.5 with one + # extra record field (ci/notty-ocaml55.patch). + - name: Pin patched notty + run: | + git clone --depth 50 https://github.com/pqwy/notty.git notty-upstream + git -C notty-upstream apply ci/notty-ocaml55.patch + opam pin add notty ./notty-upstream -yn + + - name: Install dependencies + run: opam install . --deps-only --with-test -y + + - name: Build + run: opam exec -- dune build + + - name: Test + run: opam exec -- dune runtest --force + + fmt: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: 5.5 + + - name: Check formatting + run: | + opam install ocamlformat.0.29.0 -y + opam exec -- sh -c 'ocamlformat --check $(find lib test bin -name "*.ml" -o -name "*.mli")' diff --git a/README.md b/README.md index d068fae..04af0ec 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # devkit Scan your PC for installed software across package managers, merge the -result with a `pkgs.txt` manifest, and export a restore-ready snapshot. +result with a `devkit.toml` manifest, and export a restore-ready snapshot. ## Build @@ -24,19 +24,19 @@ generated (see AGENTS.md for the regen dance). Every `lib/*.ml` has a ```sh devkit # dashboard: manifest status, or full scan devkit import FILE # preview a manifest against this machine -devkit add ID... # append installed apps to pkgs.txt +devkit add ID... # append installed apps to devkit.toml devkit append [--new] # append newly-detected apps (or given ids) -devkit export [-o FILE] # write pkgs.txt + winget import-ready JSON +devkit export [-o FILE] # write devkit.toml + winget import-ready JSON ``` -`export` writes two files: the plain manifest (`pkgs.txt`) and a +`export` writes two files: the TOML manifest (`devkit.toml`) and a `winget import -i`-compatible JSON sibling (schema 2.0.0, installed versions pinned; skipped when no winget apps are installed). ## Custom package managers (`tools.sexp`) Built-ins: winget, npm, pipx, uv, cargo. Anything else goes in an -s-expression file — `tools.sexp` next to `pkgs.txt` first, then +s-expression file — `tools.sexp` next to `devkit.toml` first, then `~/.config/devkit/tools.sexp` (`%LOCALAPPDATA%\devkit\tools.sexp` on Windows). First file wins per tool name; built-in names are reserved. diff --git a/ci/notty-ocaml55.patch b/ci/notty-ocaml55.patch new file mode 100644 index 0000000..ad43bc8 --- /dev/null +++ b/ci/notty-ocaml55.patch @@ -0,0 +1,28 @@ +# notty on OCaml >= 5.4: Format.formatter_out_functions gained an +# out_width field and upstream master does not set it yet. Apply after +# cloning pqwy/notty master: +# +# git clone https://github.com/pqwy/notty.git +# git -C notty apply /path/to/ci/notty-ocaml55.patch +# opam pin add notty ./notty -yn +# +# The implementation counts UTF-8 leading bytes in the slice, which is +# the scalar-value count Format documents as the reasonable default. +diff --git a/src/notty.ml b/src/notty.ml +index 7385083..1ea50e5 100644 +--- a/src/notty.ml ++++ b/src/notty.ml +@@ -390,6 +390,13 @@ module I = struct + img := !img <-> !line; line := void 0 1) + ; out_string = (fun s i n -> + line := !line <|> string (top_a attr) String.(sub0cp s i n)) ++ (* Width of the substring as scalar count (Format.out_width, OCaml >= 5.4). *) ++ ; out_width = (fun s ~pos ~len -> ++ let n = ref 0 in ++ for i = pos to pos + len - 1 do ++ if Char.code s.[i] land 0xC0 <> 0x80 then incr n ++ done; ++ !n) + (* Not entirely clear; either or both could be void: *) + ; out_spaces = (fun w -> line := !line <|> char (top_a attr) ' ' w 1) + ; out_indent = (fun w -> line := !line <|> char (top_a attr) ' ' w 1) diff --git a/devkit.opam b/devkit.opam index 7243dec..ded1f7c 100644 --- a/devkit.opam +++ b/devkit.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Cross package-manager inventory dashboard" description: - "Scan your PC for installed software across package managers, merge the result with a pkgs.txt manifest, and export a restore-ready snapshot." + "Scan your PC for installed software across package managers, merge the result with a devkit.toml manifest, and export a restore-ready snapshot." maintainer: ["devkit contributors"] authors: ["devkit contributors"] license: "MIT" @@ -17,6 +17,8 @@ depends: [ "decompress" {>= "1.5"} "sexplib" {>= "0.17"} "re" {>= "1.11"} + "toml" {>= "7.0"} + "notty" {>= "0.2.3"} "alcotest" {>= "1.7" & with-test} "odoc" {with-doc} ] diff --git a/dune-project b/dune-project index d861074..e17d0b4 100644 --- a/dune-project +++ b/dune-project @@ -12,7 +12,7 @@ (package (name devkit) (synopsis "Cross package-manager inventory dashboard") - (description "Scan your PC for installed software across package managers, merge the result with a pkgs.txt manifest, and export a restore-ready snapshot.") + (description "Scan your PC for installed software across package managers, merge the result with a devkit.toml manifest, and export a restore-ready snapshot.") (depends (ocaml (>= 5.2)) (dune (>= 3.24)) @@ -21,5 +21,7 @@ (digestif (>= 1.2)) (decompress (>= 1.5)) (sexplib (>= 0.17)) - (re (>= 1.11)) + (re (>= 1.11)) + (toml (>= 7.0)) + (notty (>= 0.2.3)) (alcotest (and (>= 1.7) :with-test)))) diff --git a/lib/dune b/lib/dune index 9058a9b..36d7d64 100644 --- a/lib/dune +++ b/lib/dune @@ -1,4 +1,4 @@ (library (name devkit) - (libraries unix yojson digestif.c decompress.de sexplib re) - (modules pkgfile winget_parse dashboard proc inventory strutil fetch hash gh zipx bootstrap install app winget_json plugin)) + (libraries unix yojson digestif.c decompress.de sexplib re toml) + (modules manifest winget_parse dashboard proc inventory strutil fetch hash gh zipx bootstrap install app winget_json plugin tui)) diff --git a/lib/manifest.ml b/lib/manifest.ml new file mode 100644 index 0000000..526c706 --- /dev/null +++ b/lib/manifest.ml @@ -0,0 +1,147 @@ +(** Manifest (devkit.toml) parsing and rendering. + + The manifest is TOML: an optional top-level [winget_path] plus a + [[section]] array, each section holding a [name] and a [package] + array of [{ pm, id }] tables with optional version fields. Parsing + is total: malformed TOML yields an empty result, unknown package + managers and items without an id are skipped. Statuses are never + persisted; they are assigned at runtime by the merge step. *) + +let filename = "devkit.toml" + +type item_type = + | Winget + | GitHub + | Url + | Pm of string + +type status = + | Installed + | NeedsUpdate + | NotFound + | New + | Manual + +type item = + { typ : item_type + ; value : string + ; installed_version : string + ; available_version : string + ; status : status + } + +type section = + { name : string + ; items : item list + } + +type parse_result = + { sections : section list + ; winget_path : string + } + +let make_item typ value = + { typ + ; value + ; installed_version = "" + ; available_version = "" + ; (* Fresh items carry [NotFound]; statuses are assigned later by the + merge step. *) + status = NotFound + } +;; + +let type_string = function + | Winget -> "winget" + | GitHub -> "github" + | Url -> "url" + | Pm s -> s +;; + +let item_type_of_string s = + match String.lowercase_ascii s with + | "winget" -> Winget + | "github" -> GitHub + | "url" -> Url + | _ -> Pm s +;; + +open Toml.Lenses + +let get_str tbl k = + match get tbl (key k |-- string) with + | Some s -> s + | None -> "" +;; + +(** [parse text] parses a devkit.toml manifest. *) +let parse (text : string) : parse_result = + match Toml.Parser.from_string text with + | `Error _ -> { sections = []; winget_path = "" } + | `Ok tbl -> + let winget_path = get_str tbl "winget_path" in + let sections = + match get tbl (key "section" |-- array |-- tables) with + | None -> [] + | Some secs -> + List.filter_map + (fun sec -> + let name = get_str sec "name" in + if name = "" + then None + else ( + let items = + match get sec (key "package" |-- array |-- tables) with + | None -> [] + | Some pkgs -> + List.filter_map + (fun pkg -> + match + get pkg (key "pm" |-- string), get pkg (key "id" |-- string) + with + | Some pm, Some id when id <> "" -> + let typ = item_type_of_string pm in + Some + { (make_item typ id) with + installed_version = get_str pkg "installed_version" + ; available_version = get_str pkg "available_version" + } + | _ -> None) + pkgs + in + Some { name; items })) + secs + in + { sections; winget_path } +;; + +let str k v = Toml.Min.key k, Toml.Types.TString v + +(** [to_string r] renders a manifest back to TOML. *) +let to_string (r : parse_result) : string = + let pkg it = + Toml.Min.of_key_values + ([ str "pm" (type_string it.typ); str "id" it.value ] + @ (if it.installed_version <> "" + then [ str "installed_version" it.installed_version ] + else []) + @ + if it.available_version <> "" + then [ str "available_version" it.available_version ] + else []) + in + let sec (s : section) = + Toml.Min.of_key_values + [ str "name" s.name + ; ( Toml.Min.key "package" + , Toml.Types.TArray (Toml.Types.NodeTable (List.map pkg s.items)) ) + ] + in + let top = + (if r.winget_path <> "" then [ str "winget_path" r.winget_path ] else []) + @ [ ( Toml.Min.key "section" + , Toml.Types.TArray (Toml.Types.NodeTable (List.map sec r.sections)) ) + ] + in + Toml.Printer.string_of_table (Toml.Min.of_key_values top) +;; diff --git a/lib/pkgfile.mli b/lib/manifest.mli similarity index 62% rename from lib/pkgfile.mli rename to lib/manifest.mli index b100877..760bddb 100644 --- a/lib/pkgfile.mli +++ b/lib/manifest.mli @@ -1,9 +1,13 @@ -(** Manifest (pkgs.txt) parsing. *) +(** Manifest (devkit.toml) parsing and rendering. *) + +(** The manifest file name, resolved from the working directory. *) +val filename : string type item_type = | Winget | GitHub | Url + | Pm of string type status = | Installed @@ -31,4 +35,7 @@ type parse_result = } val make_item : item_type -> string -> item +val type_string : item_type -> string +val item_type_of_string : string -> item_type val parse : string -> parse_result +val to_string : parse_result -> string diff --git a/lib/pkgfile.ml b/lib/pkgfile.ml deleted file mode 100644 index e790203..0000000 --- a/lib/pkgfile.ml +++ /dev/null @@ -1,105 +0,0 @@ -(** Manifest (pkgs.txt) parsing. - - The manifest is a sequence of [# Section] headers, [type:value] items - and an optional [# winget: ] directive. Parsing is total and - pure: unknown lines are skipped. *) - -type item_type = - | Winget - | GitHub - | Url - -type status = - | Installed - | NeedsUpdate - | NotFound - | New - | Manual - -type item = - { typ : item_type - ; value : string - ; installed_version : string - ; available_version : string - ; status : status - } - -type section = - { name : string - ; items : item list - } - -type parse_result = - { sections : section list - ; winget_path : string - } - -let make_item typ value = - { typ - ; value - ; installed_version = "" - ; available_version = "" - ; (* Fresh items carry [NotFound]; statuses are assigned later by the - merge step. *) - status = NotFound - } -;; - -let starts_with ~prefix s = - let n = String.length prefix in - String.length s >= n && String.sub s 0 n = prefix -;; - -(** [parse text] parses a pkgs.txt manifest. *) -let parse (text : string) : parse_result = - let sections = ref [] in - let winget_path = ref "" in - let push_item it = - match List.rev !sections with - | [] -> sections := [ { name = "General"; items = [ it ] } ] - | last :: rest -> - sections := List.rev ({ last with items = last.items @ [ it ] } :: rest) - in - let lines = String.split_on_char '\n' text in - List.iter - (fun raw -> - let line = String.trim raw in - if line = "" - then () - else if starts_with ~prefix:"#" line - then ( - let rest = String.trim (String.sub line 1 (String.length line - 1)) in - if starts_with ~prefix:"winget:" (String.lowercase_ascii rest) - then ( - let p = String.trim (String.sub rest 7 (String.length rest - 7)) in - if p <> "" - then winget_path := p - (* NOTE: a [# winget:]-with-empty-path falls through to become a - section, exactly like the Go original. *) - else sections := !sections @ [ { name = rest; items = [] } ]) - else if rest <> "" - then sections := !sections @ [ { name = rest; items = [] } ]) - else ( - match String.index_opt line ':' with - | None -> () - | Some colon -> - let prefix = String.lowercase_ascii (String.trim (String.sub line 0 colon)) in - let value = - String.trim (String.sub line (colon + 1) (String.length line - colon - 1)) - in - if value = "" - then () - else ( - let typ = - match prefix with - | "winget" -> Some Winget - | "github" -> Some GitHub - | "url" -> Some Url - | _ -> None - in - match typ with - | None -> () - | Some typ -> push_item (make_item typ value)))) - lines; - { sections = !sections; winget_path = !winget_path } -;; diff --git a/lib/plugin.ml b/lib/plugin.ml index 5eef560..abd753c 100644 --- a/lib/plugin.ml +++ b/lib/plugin.ml @@ -3,7 +3,7 @@ A tool is a named program devkit can scan (like the built-in npm, pipx, uv and cargo support) plus optional install/upgrade command templates. Tools live in s-expression files: [tools.sexp] next to - [pkgs.txt] first, then the user config dir: the first file wins per + devkit.toml first, then the user config dir: the first file wins per tool name, and a custom tool may not shadow a built-in name. File format: @@ -352,7 +352,7 @@ let config_file () : string option = | _ -> None)) ;; -(** Search order: [tools.sexp] next to [pkgs.txt], then the config file. *) +(** Search order: [tools.sexp] next to devkit.toml, then the config file. *) let default_paths () : string list = match config_file () with | None -> [ "tools.sexp" ] diff --git a/test/test_app.ml b/test/test_app.ml index 70d1c38..498fcfc 100644 --- a/test/test_app.ml +++ b/test/test_app.ml @@ -53,15 +53,23 @@ let contains sub s = ;; let load_missing () = - let s, w = App.load_manifest (mem_fs (Hashtbl.create 1)) "pkgs.txt" in + let s, w = App.load_manifest (mem_fs (Hashtbl.create 1)) Manifest.filename in Alcotest.(check int) "no sections" 0 (List.length s); Alcotest.(check string) "no winget path" "" w ;; let load_parses () = let files = Hashtbl.create 1 in - Hashtbl.add files "pkgs.txt" "# winget: C:\\w\\winget.exe\n# tools\nwinget:Git.Git\n"; - let s, w = App.load_manifest (mem_fs files) "pkgs.txt" in + Hashtbl.add + files + Manifest.filename + "winget_path = \"C:\\\\w\\\\winget.exe\"\n\n\ + [[section]]\n\ + name = \"tools\"\n\n\ + [[section.package]]\n\ + pm = \"winget\"\n\ + id = \"Git.Git\"\n"; + let s, w = App.load_manifest (mem_fs files) Manifest.filename in Alcotest.(check string) "winget path" "C:\\w\\winget.exe" w; Alcotest.(check int) "one section" 1 (List.length s) ;; @@ -69,28 +77,30 @@ let load_parses () = let append_groups () = let files = Hashtbl.create 1 in let items = - [ { Pkgfile.typ = Pkgfile.Winget + [ { Manifest.typ = Manifest.Winget ; value = "Brave.Brave" ; installed_version = "" ; available_version = "" - ; status = Pkgfile.New + ; status = Manifest.New } - ; { Pkgfile.typ = Pkgfile.Winget + ; { Manifest.typ = Manifest.Winget ; value = "Git.Git" ; installed_version = "" ; available_version = "" - ; status = Pkgfile.New + ; status = Manifest.New } ] in Alcotest.(check (result unit string)) "ok" (Ok ()) - (App.append_selected (mem_fs files) "pkgs.txt" items); - Alcotest.(check string) - "grouped under header" - "\n# Newly detected\nwinget:Brave.Brave\nwinget:Git.Git\n" - (Hashtbl.find files "pkgs.txt") + (App.append_selected (mem_fs files) Manifest.filename items); + let written = Hashtbl.find files Manifest.filename in + Alcotest.(check bool) "section header" true (contains "Newly detected" written); + Alcotest.(check bool) + "both ids" + true + (contains "Brave.Brave" written && contains "Git.Git" written) ;; let append_empty () = @@ -98,25 +108,32 @@ let append_empty () = Alcotest.(check (result unit string)) "ok" (Ok ()) - (App.append_selected (mem_fs files) "pkgs.txt" []); - Alcotest.(check bool) "no write" false (Hashtbl.mem files "pkgs.txt") + (App.append_selected (mem_fs files) Manifest.filename []); + Alcotest.(check bool) "no write" false (Hashtbl.mem files Manifest.filename) ;; let add () = let files = Hashtbl.create 1 in - Hashtbl.add files "pkgs.txt" "# tools\nwinget:Git.Git\n"; + Hashtbl.add + files + Manifest.filename + "[[section]]\n\ + name = \"tools\"\n\n\ + [[section.package]]\n\ + pm = \"winget\"\n\ + id = \"Git.Git\"\n"; let msgs = App.run_add (env files) [ "Git.Git"; "Nope.Nope"; "Brave.Brave" ] in Alcotest.(check (list string)) "messages" [ " skip (already in manifest): Git.Git" ; " skip (not installed): Nope.Nope" - ; " appended 1 app(s) to pkgs.txt" + ; " appended 1 app(s) to " ^ Manifest.filename ] msgs; Alcotest.(check bool) "brave persisted" true - (contains "winget:Brave.Brave" (Hashtbl.find files "pkgs.txt")) + (contains "Brave.Brave" (Hashtbl.find files Manifest.filename)) ;; let add_nothing () = @@ -130,15 +147,21 @@ let add_nothing () = let export () = let files = Hashtbl.create 1 in - let msgs = App.run_export (env files) "out.txt" in + let msgs = App.run_export (env files) "out.toml" in Alcotest.(check (list string)) "messages" - [ "wrote out.txt (2 apps)"; "wrote out.json (2 winget apps, winget import -i ready)" ] + [ "wrote out.toml (2 apps)" + ; "wrote out.json (2 winget apps, winget import -i ready)" + ] msgs; - Alcotest.(check string) - "content" - "# Generated by devkit export\n\n# winget\nwinget:Brave.Brave\nwinget:Git.Git\n" - (Hashtbl.find files "out.txt"); + let r = Devkit.Manifest.parse (Hashtbl.find files "out.toml") in + let ids = + List.concat_map + (fun (sec : Devkit.Manifest.section) -> + List.map (fun i -> i.Devkit.Manifest.value) sec.items) + r.sections + in + Alcotest.(check (list string)) "exported ids" [ "Brave.Brave"; "Git.Git" ] ids; let j = Yojson.Basic.from_string (Hashtbl.find files "out.json") in let pkgs = match j with @@ -160,7 +183,7 @@ let export_empty () = Alcotest.(check (list string)) "empty" [ " no installed software found" ] - (App.run_export e "out.txt") + (App.run_export e "out.toml") ;; let export_no_winget () = @@ -170,7 +193,7 @@ let export_no_winget () = run = (fun prog _ -> if prog = "npm" then Some "x@1.0.0\n" else None) } in - let msgs = App.run_export e "out.txt" in + let msgs = App.run_export e "out.toml" in Alcotest.(check bool) "skip message" true @@ -180,7 +203,7 @@ let export_no_winget () = let new_items () = let mk status = - { Pkgfile.typ = Pkgfile.Winget + { Manifest.typ = Manifest.Winget ; value = "x" ; installed_version = "" ; available_version = "" @@ -188,8 +211,8 @@ let new_items () = } in let secs = - [ { Pkgfile.name = "Newly detected"; items = [ mk Pkgfile.New ] } - ; { Pkgfile.name = "Pending updates"; items = [ mk Pkgfile.New ] } + [ { Manifest.name = "Newly detected"; items = [ mk Manifest.New ] } + ; { Manifest.name = "Pending updates"; items = [ mk Manifest.New ] } ] in Alcotest.(check int) "newly only" 1 (List.length (App.new_items secs)); @@ -206,7 +229,14 @@ let show () = let default () = let files = Hashtbl.create 1 in - Hashtbl.add files "pkgs.txt" "# tools\nwinget:Git.Git\n"; + Hashtbl.add + files + Manifest.filename + "[[section]]\n\ + name = \"tools\"\n\n\ + [[section.package]]\n\ + pm = \"winget\"\n\ + id = \"Git.Git\"\n"; let s = App.default_view ~tools:[] (env files) in Alcotest.(check bool) "mentions app" true (contains "Git.Git" s) ;; diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml index d81cd61..f2d26a6 100644 --- a/test/test_dashboard.ml +++ b/test/test_dashboard.ml @@ -1,7 +1,7 @@ (** Tests for {!Dashboard}: section merge and plain-text render. *) open Devkit -open Pkgfile +open Manifest let item typ value = make_item typ value diff --git a/test/test_manifest.ml b/test/test_manifest.ml new file mode 100644 index 0000000..563206e --- /dev/null +++ b/test/test_manifest.ml @@ -0,0 +1,84 @@ +(** Tests for {!Manifest}: devkit.toml parsing and rendering. *) + +open Devkit.Manifest + +let basic = + "winget_path = \"C:\\\\tools\\\\winget.exe\"\n\n\ + [[section]]\n\ + name = \"tools\"\n\n\ + [[section.package]]\n\ + pm = \"winget\"\n\ + id = \"Git.Git\"\n\n\ + [[section.package]]\n\ + pm = \"npm\"\n\ + id = \"pyright\"\n\ + installed_version = \"1.2.3\"\n" +;; + +let parses () = + let r = parse basic in + Alcotest.(check string) "winget path" "C:\\tools\\winget.exe" r.winget_path; + match r.sections with + | [ sec ] -> + Alcotest.(check string) "section name" "tools" sec.name; + (match sec.items with + | [ git; npm ] -> + Alcotest.(check string) "first id" "Git.Git" git.value; + Alcotest.(check bool) "first typ" true (git.typ = Winget); + Alcotest.(check string) "second id" "pyright" npm.value; + Alcotest.(check string) "second pm" "npm" (type_string npm.typ); + Alcotest.(check string) "second version" "1.2.3" npm.installed_version + | _ -> Alcotest.fail "expected two items") + | _ -> Alcotest.fail "expected one section" +;; + +let skips () = + let r = + parse + "[[section]]\n\ + name = \"\"\n\n\ + [[section]]\n\ + name = \"t\"\n\n\ + [[section.package]]\n\ + pm = \"winget\"\n\ + id = \"\"\n\n\ + [[section.package]]\n\ + pm = \"github\"\n\ + id = \"owner/repo\"\n" + in + match r.sections with + | [ sec ] -> + (match sec.items with + | [ it ] -> + Alcotest.(check bool) "github typ" true (it.typ = GitHub); + Alcotest.(check string) "id" "owner/repo" it.value + | _ -> Alcotest.fail "expected one item") + | _ -> Alcotest.fail "expected one section" +;; + +let malformed () = + let r = parse "[[section\nname = " in + Alcotest.(check int) "no sections" 0 (List.length r.sections); + Alcotest.(check string) "no winget path" "" r.winget_path +;; + +let round_trip () = + let r = parse basic in + let r2 = parse (to_string r) in + Alcotest.(check string) "winget path" r.winget_path r2.winget_path; + Alcotest.(check int) "sections" (List.length r.sections) (List.length r2.sections); + let ids secs = List.concat_map (fun s -> List.map (fun i -> i.value) s.items) secs in + Alcotest.(check (list string)) "ids" (ids r.sections) (ids r2.sections) +;; + +let () = + Alcotest.run + "manifest" + [ ( "parse" + , [ Alcotest.test_case "basic" `Quick parses + ; Alcotest.test_case "skips" `Quick skips + ; Alcotest.test_case "malformed" `Quick malformed + ] ) + ; "render", [ Alcotest.test_case "round_trip" `Quick round_trip ] + ] +;; diff --git a/test/test_pkgfile.ml b/test/test_pkgfile.ml deleted file mode 100644 index a765d27..0000000 --- a/test/test_pkgfile.ml +++ /dev/null @@ -1,116 +0,0 @@ -(** Tests for {!Pkgfile}: manifest parsing. *) - -open Devkit.Pkgfile - -let status_t = - Alcotest.testable - (fun ppf -> function - | Installed -> Format.pp_print_string ppf "Installed" - | NeedsUpdate -> Format.pp_print_string ppf "NeedsUpdate" - | NotFound -> Format.pp_print_string ppf "NotFound" - | New -> Format.pp_print_string ppf "New" - | Manual -> Format.pp_print_string ppf "Manual") - ( = ) -;; - -let type_t = - Alcotest.testable - (fun ppf -> function - | Winget -> Format.pp_print_string ppf "Winget" - | GitHub -> Format.pp_print_string ppf "GitHub" - | Url -> Format.pp_print_string ppf "Url") - ( = ) -;; - -let sections () = - let r = - parse - "# Runtimes\n\ - winget:Microsoft.DotNet.SDK.9\n\n\ - github:owner/repo\n\ - # Setup\n\ - url:https://example.com/x.exe\n" - in - Alcotest.(check string) "winget path empty" "" r.winget_path; - Alcotest.(check int) "two sections" 2 (List.length r.sections); - let runtimes = List.nth r.sections 0 in - Alcotest.(check string) "first section" "Runtimes" runtimes.name; - Alcotest.(check int) "runtimes items" 2 (List.length runtimes.items); - Alcotest.(check type_t) "winget type" Winget (List.nth runtimes.items 0).typ; - Alcotest.(check string) - "winget value" - "Microsoft.DotNet.SDK.9" - (List.nth runtimes.items 0).value; - Alcotest.(check type_t) "github type" GitHub (List.nth runtimes.items 1).typ; - let setup = List.nth r.sections 1 in - Alcotest.(check string) "second section" "Setup" setup.name; - Alcotest.(check type_t) "url type" Url (List.nth setup.items 0).typ -;; - -let directive () = - let r = parse "# winget: C:\\tools\\winget.exe\n# Runtimes\nwinget:Foo.Bar\n" in - Alcotest.(check string) "winget path" "C:\\tools\\winget.exe" r.winget_path; - Alcotest.(check int) "directive is not a section" 1 (List.length r.sections) -;; - -let directive_case_insensitive () = - let r = parse "# Winget: /usr/bin/winget\nwinget:Foo.Bar\n" in - Alcotest.(check string) "path" "/usr/bin/winget" r.winget_path; - Alcotest.(check string) "implicit General" "General" (List.nth r.sections 0).name -;; - -let bare_winget_header_is_section () = - (* "# winget" without a path becomes a section named "winget", later - dropped by the dashboard merge. *) - let r = parse "# winget\nwinget:Foo.Bar\n" in - Alcotest.(check string) "no path" "" r.winget_path; - Alcotest.(check string) "section winget" "winget" (List.nth r.sections 0).name -;; - -let general_fallback () = - let r = parse "winget:Foo.Bar\n" in - Alcotest.(check int) "one section" 1 (List.length r.sections); - Alcotest.(check string) "General" "General" (List.nth r.sections 0).name -;; - -let skipped_lines () = - let r = - parse "# Sec\nno-colon-here\nunknown:val\nwinget:\n \nwinget: \nwinget:Real.Id\n" - in - let sec = List.nth r.sections 0 in - Alcotest.(check int) "only the valid item" 1 (List.length sec.items); - Alcotest.(check string) "value" "Real.Id" (List.nth sec.items 0).value -;; - -let empty_comment_no_section () = - let r = parse "#\n# \nwinget:Foo.Bar\n" in - Alcotest.(check string) "General" "General" (List.nth r.sections 0).name -;; - -let fresh_item_status () = - (* Fresh items carry NotFound until the merge assigns. *) - let r = parse "winget:Foo.Bar\n" in - Alcotest.(check status_t) - "zero status" - NotFound - (List.nth (List.nth r.sections 0).items 0).status -;; - -let () = - Alcotest.run - "pkgfile" - [ ( "parse" - , [ Alcotest.test_case "sections and items" `Quick sections - ; Alcotest.test_case "winget directive" `Quick directive - ; Alcotest.test_case - "directive case-insensitive" - `Quick - directive_case_insensitive - ; Alcotest.test_case "bare winget header" `Quick bare_winget_header_is_section - ; Alcotest.test_case "General fallback" `Quick general_fallback - ; Alcotest.test_case "skipped lines" `Quick skipped_lines - ; Alcotest.test_case "empty comments" `Quick empty_comment_no_section - ; Alcotest.test_case "fresh item status" `Quick fresh_item_status - ] ) - ] -;; From e303fdbb142bfbb405b3761c02d9eaf21a8747f5 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 14:10:47 +0000 Subject: [PATCH 04/34] Upload windows exe as CI artifact So the Windows test box can grab a ready binary from the Actions run instead of building locally. --- .github/workflows/ci.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a7b394f..c1b892c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -36,6 +36,13 @@ jobs: - name: Test run: opam exec -- dune runtest --force + - name: Upload windows exe + if: matrix.os == 'windows-latest' + uses: actions/upload-artifact@v4 + with: + name: devkit-windows + path: _build/default/bin/main.exe + fmt: runs-on: ubuntu-latest steps: From 9e4afbfddc452fd029d3e8778122eb3c69f6c03f Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 14:25:00 +0000 Subject: [PATCH 05/34] Color TUI rows by status, scroll list with the mouse Rows render green/yellow/red/cyan by install status via Tui.color_of; wheel events step three rows through new Scroll_up/Scroll_down actions. Mouse reporting was already on. --- bin/tui_front.ml | 35 +++++++++++++++++++++++++---------- lib/tui.ml | 20 ++++++++++++++++++++ lib/tui.mli | 14 ++++++++++++++ test/test_tui.ml | 24 +++++++++++++++++++++++- 4 files changed, 82 insertions(+), 11 deletions(-) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index d2b2e24..76dcd36 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -15,19 +15,32 @@ let kind_of : Manifest.item_type -> string = function | Manifest.Pm s -> s ;; +let color_attr : Tui.color -> attr = function + | Tui.Plain -> A.empty + | Tui.Green -> A.(fg green) + | Tui.Yellow -> A.(fg yellow) + | Tui.Red -> A.(fg red) + | Tui.Cyan -> A.(fg cyan) +;; + let draw (st : Tui.state) : image = - let lines = Tui.frame st in + let rows = Tui.visible st in let img_of_line i line = - let attr = - if i = 0 - then A.(st bold) - else if String.length line >= 2 && String.sub line 0 2 = "> " - then A.(st reverse) - else A.empty - in - I.string attr line + if i = 0 + then I.string A.(st bold) line + else if i = 1 + then I.string A.empty line + else ( + match List.nth_opt rows (i - 2) with + | None -> I.string A.empty line + | Some e -> + let attr = color_attr (Tui.color_of e.Tui.item.Manifest.status) in + let attr = + if st.Tui.offset + i - 2 = st.Tui.cursor then A.(attr ++ st reverse) else attr + in + I.string attr line) in - I.vcat (List.mapi img_of_line lines) + I.vcat (List.mapi img_of_line (Tui.frame st)) ;; type ev = @@ -51,6 +64,8 @@ let nav : ev -> Tui.action option = function | `Key (`Page `Down, _) -> Some Tui.Page_down | `Key (`Home, _) -> Some Tui.Home | `Key (`End, _) -> Some Tui.End + | `Mouse (`Press (`Scroll `Up), _, _) -> Some Tui.Scroll_up + | `Mouse (`Press (`Scroll `Down), _, _) -> Some Tui.Scroll_down | _ -> None ;; diff --git a/lib/tui.ml b/lib/tui.ml index d8d8b94..6c793bd 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -69,6 +69,8 @@ type action = | Down | Page_up | Page_down + | Scroll_up + | Scroll_down | Home | End | Quit @@ -80,6 +82,8 @@ let step (s : state) (a : action) : state = | Down -> s.cursor + 1 | Page_up -> s.cursor - s.height | Page_down -> s.cursor + s.height + | Scroll_up -> s.cursor - 3 + | Scroll_down -> s.cursor + 3 | Home -> 0 | End -> max_cursor s | Quit -> s.cursor @@ -106,6 +110,22 @@ let enter_action (s : state) : enter = | Installed | New -> Do_nothing) ;; +(** Row color by install status; the frontend maps this to terminal colors. *) +type color = + | Plain + | Green + | Yellow + | Red + | Cyan + +let color_of : status -> color = function + | Installed -> Green + | NeedsUpdate -> Yellow + | NotFound -> Red + | New -> Cyan + | Manual -> Plain +;; + let symbol : status -> string = function | Installed -> "ok" | NeedsUpdate -> "update" diff --git a/lib/tui.mli b/lib/tui.mli index 096f25c..3c452cf 100644 --- a/lib/tui.mli +++ b/lib/tui.mli @@ -28,6 +28,8 @@ type action = | Down | Page_up | Page_down + | Scroll_up + | Scroll_down | Home | End | Quit @@ -35,6 +37,18 @@ type action = val step : state -> action -> state val selected : state -> entry option +(** Row color by status, for the frontend to map to terminal colors: + green = installed, yellow = needs update, red = missing, + cyan = newly detected, plain = manual links. *) +type color = + | Plain + | Green + | Yellow + | Red + | Cyan + +val color_of : status -> color + type enter = | Do_install of item | Do_open of string diff --git a/test/test_tui.ml b/test/test_tui.ml index 9067e9b..3339022 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -114,6 +114,24 @@ let frame_shape () = String.length row >= 2 && String.sub row 0 2 = "> ") ;; +let colors () = + let open Devkit.Tui in + let open Devkit.Manifest in + Alcotest.(check bool) "installed green" true (color_of Installed = Green); + Alcotest.(check bool) "update yellow" true (color_of NeedsUpdate = Yellow); + Alcotest.(check bool) "missing red" true (color_of NotFound = Red); + Alcotest.(check bool) "new cyan" true (color_of New = Cyan); + Alcotest.(check bool) "manual plain" true (color_of Manual = Plain) +;; + +let scroll () = + let s = Devkit.Tui.make (sections ()) ~height:2 ~width:80 in + let s = Devkit.Tui.step s Devkit.Tui.Scroll_down in + Alcotest.(check int) "scroll moves 3" 2 s.Devkit.Tui.cursor; + let s = Devkit.Tui.step s Devkit.Tui.Scroll_up in + Alcotest.(check int) "scroll back clamps" 0 s.Devkit.Tui.cursor +;; + let () = Alcotest.run "tui" @@ -121,6 +139,7 @@ let () = ; ( "nav" , [ Alcotest.test_case "clamp" `Quick nav_clamp ; Alcotest.test_case "paging" `Quick paging + ; Alcotest.test_case "scroll" `Quick scroll ] ) ; ( "enter" , [ Alcotest.test_case "mapping" `Quick enter_mapping @@ -130,6 +149,9 @@ let () = , [ Alcotest.test_case "success" `Quick apply_success ; Alcotest.test_case "failure keeps" `Quick apply_failure_keeps ] ) - ; "frame", [ Alcotest.test_case "shape" `Quick frame_shape ] + ; ( "frame" + , [ Alcotest.test_case "shape" `Quick frame_shape + ; Alcotest.test_case "colors" `Quick colors + ] ) ] ;; From a129d58086b099f6a887512303a8c9cc020cfac6 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 14:33:04 +0000 Subject: [PATCH 06/34] Unify TUI rows with dashboard symbols, add section dividers Rows reuse Dashboard.status_symbol so the TUI matches the exit printout. Section headers render as non-selectable divider rows. Mouse scroll moves one row per event. --- bin/tui_front.ml | 24 +++++++------------ lib/dashboard.mli | 1 + lib/tui.ml | 59 ++++++++++++++++++++++++++++------------------- lib/tui.mli | 8 +++++++ test/test_tui.ml | 15 ++++++++---- 5 files changed, 63 insertions(+), 44 deletions(-) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index 76dcd36..b21a626 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -24,23 +24,15 @@ let color_attr : Tui.color -> attr = function ;; let draw (st : Tui.state) : image = - let rows = Tui.visible st in - let img_of_line i line = - if i = 0 - then I.string A.(st bold) line - else if i = 1 - then I.string A.empty line - else ( - match List.nth_opt rows (i - 2) with - | None -> I.string A.empty line - | Some e -> - let attr = color_attr (Tui.color_of e.Tui.item.Manifest.status) in - let attr = - if st.Tui.offset + i - 2 = st.Tui.cursor then A.(attr ++ st reverse) else attr - in - I.string attr line) + let img_of_line i = function + | Tui.Head s -> if i = 0 then I.string A.(st bold) s else I.string A.empty s + | Tui.Divider _ as d -> I.string A.(st bold ++ fg lightblack) (" " ^ Tui.render_line d) + | Tui.Row (e, cursor) -> + let attr = color_attr (Tui.color_of e.Tui.item.Manifest.status) in + let attr = if cursor then A.(attr ++ st reverse) else attr in + I.string attr (Tui.render_line (Tui.Row (e, cursor))) in - I.vcat (List.mapi img_of_line (Tui.frame st)) + I.vcat (List.mapi img_of_line (Tui.lines st)) ;; type ev = diff --git a/lib/dashboard.mli b/lib/dashboard.mli index c7999f5..066fc8b 100644 --- a/lib/dashboard.mli +++ b/lib/dashboard.mli @@ -6,6 +6,7 @@ type app = ; pm : string } +val status_symbol : Manifest.status -> string val format_ver : Manifest.item -> string (** Merge the machine scan with manifest sections into dashboard sections: diff --git a/lib/tui.ml b/lib/tui.ml index 6c793bd..336b1e2 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -82,8 +82,8 @@ let step (s : state) (a : action) : state = | Down -> s.cursor + 1 | Page_up -> s.cursor - s.height | Page_down -> s.cursor + s.height - | Scroll_up -> s.cursor - 3 - | Scroll_down -> s.cursor + 3 + | Scroll_up -> s.cursor - 1 + | Scroll_down -> s.cursor + 1 | Home -> 0 | End -> max_cursor s | Quit -> s.cursor @@ -126,18 +126,12 @@ let color_of : status -> color = function | Manual -> Plain ;; -let symbol : status -> string = function - | Installed -> "ok" - | NeedsUpdate -> "update" - | NotFound -> "new" - | New -> "?" - | Manual -> "manual" -;; - +(** Same bracket symbol as the plain renderer, so the TUI and the + exit printout show identical rows. *) let row_text (e : entry) : string = Printf.sprintf - "%s %s %s" - (symbol e.item.status) + "[%s] %s%s" + (Dashboard.status_symbol e.item.status) e.item.value (Dashboard.format_ver e.item) ;; @@ -162,17 +156,20 @@ let visible (s : state) : entry list = take s.height (drop s.offset s.entries) ;; -(** Text frame: header, legend, visible rows (cursor marked), message, - footer. The notty frontend draws one line per string. *) -let frame (s : state) : string list = - let header = "devkit — enter installs/updates, q quits" in - let legend = "ok installed · update pending · new missing · manual link" in - let rows = - List.mapi - (fun i e -> - let mark = if s.offset + i = s.cursor then "> " else " " in - mark ^ row_text e) - (visible s) +(** Structured frame lines: headers and dividers are plain text, + rows carry their entry plus a cursor flag for the frontend. *) +type line = + | Head of string + | Divider of string + | Row of entry * bool + +let lines (s : state) : line list = + let vis = List.mapi (fun i e -> s.offset + i, e) (visible s) in + let rec rows prev_section = function + | [] -> [] + | (idx, e) :: rest -> + let head = if Some e.section <> prev_section then [ Divider e.section ] else [] in + head @ [ Row (e, idx = s.cursor) ] @ rows (Some e.section) rest in let footer = match s.message with @@ -183,9 +180,23 @@ let frame (s : state) : string list = (min (s.cursor + 1) (List.length s.entries)) (List.length s.entries) in - (header :: legend :: rows) @ [ footer ] + [ Head "devkit — enter installs/updates, q quits" + ; Head "[✓] installed · [!] update · [+] missing · [~] manual" + ] + @ rows None vis + @ [ Head footer ] ;; +let render_line : line -> string = function + | Head s -> s + | Divider name -> String.uppercase_ascii name + | Row (e, cursor) -> (if cursor then "> " else " ") ^ row_text e +;; + +(** Text frame: one string per line. The notty frontend draws these + with per-row colors from {!lines}. *) +let frame (s : state) : string list = List.map render_line (lines s) + (** Record an install outcome: refresh the row status, append the log. *) let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = let status = diff --git a/lib/tui.mli b/lib/tui.mli index 3c452cf..f51ea18 100644 --- a/lib/tui.mli +++ b/lib/tui.mli @@ -57,5 +57,13 @@ type enter = val enter_action : state -> enter val row_text : entry -> string val visible : state -> entry list + +type line = + | Head of string + | Divider of string + | Row of entry * bool + +val lines : state -> line list +val render_line : line -> string val frame : state -> string list val apply_outcome : state -> string -> Install.outcome -> state diff --git a/test/test_tui.ml b/test/test_tui.ml index 3339022..3b4bdf5 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -106,12 +106,19 @@ let apply_failure_keeps () = let frame_shape () = let s = Tui.make (sections ()) ~height:10 ~width:80 in let f = Tui.frame s in - Alcotest.(check int) "header+legend+3rows+footer" 6 (List.length f); + (* header + legend + TOOLS divider + a + b + MORE divider + url + footer *) + Alcotest.(check int) "lines" 8 (List.length f); + Alcotest.(check string) "divider uppercased" "TOOLS" (List.nth f 2); Alcotest.(check bool) "cursor marked" true - (let row = List.nth f 2 in - String.length row >= 2 && String.sub row 0 2 = "> ") + (let row = List.nth f 3 in + String.length row >= 2 && String.sub row 0 2 = "> "); + Alcotest.(check bool) + "bracket symbol" + true + (let row = List.nth f 3 in + String.length row >= 8 && String.sub row 2 6 = "[✓] ") ;; let colors () = @@ -127,7 +134,7 @@ let colors () = let scroll () = let s = Devkit.Tui.make (sections ()) ~height:2 ~width:80 in let s = Devkit.Tui.step s Devkit.Tui.Scroll_down in - Alcotest.(check int) "scroll moves 3" 2 s.Devkit.Tui.cursor; + Alcotest.(check int) "scroll moves 1" 1 s.Devkit.Tui.cursor; let s = Devkit.Tui.step s Devkit.Tui.Scroll_up in Alcotest.(check int) "scroll back clamps" 0 s.Devkit.Tui.cursor ;; From d7b0f3afad8ce40ac38bd367795d0f1ac18a77b2 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 15:09:29 +0000 Subject: [PATCH 07/34] Cap TUI frame at viewport height, keep cursor visible Divider rows pushed the frame past the terminal height so the end of the list rendered off-screen. The window is now budgeted in lines and fills upward when the cursor row would fall outside. --- lib/tui.ml | 62 +++++++++++++++++++++++++++++++++++++++++++----- test/test_tui.ml | 24 +++++++++++++++++++ 2 files changed, 80 insertions(+), 6 deletions(-) diff --git a/lib/tui.ml b/lib/tui.ml index 336b1e2..367e487 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -164,13 +164,63 @@ type line = | Row of entry * bool let lines (s : state) : line list = - let vis = List.mapi (fun i e -> s.offset + i, e) (visible s) in - let rec rows prev_section = function + let at i = if i < 0 then None else List.nth_opt s.entries i in + let prev0 = + match at (s.offset - 1) with + | None -> None + | Some e -> Some e.section + in + (* Entry units from the offset, each tagged with its index. *) + let rec units i prev = + match at i with + | None -> [] + | Some e -> + let div = if Some e.section <> prev then Some (Divider e.section) else None in + (i, div, e) :: units (i + 1) (Some e.section) + in + (* Flatten to tagged lines: divider (if any) then the row. *) + let all = + List.concat_map + (fun (i, div, e) -> + (match div with + | Some d -> [ i, d ] + | None -> []) + @ [ i, Row (e, i = s.cursor) ]) + (units s.offset prev0) + in + let rec take k = function | [] -> [] - | (idx, e) :: rest -> - let head = if Some e.section <> prev_section then [ Divider e.section ] else [] in - head @ [ Row (e, idx = s.cursor) ] @ rows (Some e.section) rest + | (i, l) :: t -> if k <= 0 then [] else (i, l) :: take (k - 1) t + in + let win = take s.height all in + let win = + if List.exists (fun (i, _) -> i = s.cursor) win + then win + else ( + (* Dividers pushed the cursor row past the budget: end the window + at the cursor and fill upward so the screen stays full. *) + let rec upto acc = function + | [] -> List.rev acc + | (i, l) :: t -> if i > s.cursor then List.rev acc else upto ((i, l) :: acc) t + in + let before = upto [] all in + List.rev (take s.height (List.rev before))) + in + (* Restore the section context when the drop cut the divider. *) + let win = + match win with + | (i, Row (e, _)) :: _ when i > 0 -> + let prev_sec = + match at (i - 1) with + | None -> None + | Some p -> Some p.section + in + if prev_sec <> Some e.section && List.length win < s.height + then (i, Divider e.section) :: win + else win + | _ -> win in + let body = List.map snd win in let footer = match s.message with | Some m -> m @@ -183,7 +233,7 @@ let lines (s : state) : line list = [ Head "devkit — enter installs/updates, q quits" ; Head "[✓] installed · [!] update · [+] missing · [~] manual" ] - @ rows None vis + @ body @ [ Head footer ] ;; diff --git a/test/test_tui.ml b/test/test_tui.ml index 3b4bdf5..8985667 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -121,6 +121,29 @@ let frame_shape () = String.length row >= 8 && String.sub row 2 6 = "[✓] ") ;; +let frame_fits_height () = + (* 5 single-item sections, viewport 3 lines: body must fit and the + cursor row must stay visible at both ends. *) + let secs = + List.init 5 (fun i -> + { Manifest.name = Printf.sprintf "s%d" i + ; items = [ item Manifest.Installed (Printf.sprintf "v%d" i) ] + }) + in + let body_lines f = List.filter (fun l -> l <> "") f in + let s = Devkit.Tui.make secs ~height:3 ~width:80 in + let f = Devkit.Tui.frame s in + Alcotest.(check int) "2 head + 3 body + foot" 6 (List.length f); + Alcotest.(check int) "no blanks counted" 6 (List.length (body_lines f)); + let s = Devkit.Tui.step s Devkit.Tui.End in + let f = Devkit.Tui.frame s in + Alcotest.(check int) "still fits at end" 6 (List.length f); + Alcotest.(check bool) + "cursor row visible" + true + (List.exists (fun l -> String.length l >= 2 && String.sub l 0 2 = "> ") f) +;; + let colors () = let open Devkit.Tui in let open Devkit.Manifest in @@ -158,6 +181,7 @@ let () = ] ) ; ( "frame" , [ Alcotest.test_case "shape" `Quick frame_shape + ; Alcotest.test_case "fits height" `Quick frame_fits_height ; Alcotest.test_case "colors" `Quick colors ] ) ] From 2098a7004d730cf63db1bcec608325b905c843f7 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 15:14:46 +0000 Subject: [PATCH 08/34] Speed up startup: parallel winget show, no download off Windows winget show ran once per missing app (~1s each on Windows); now up to 8 domains. ensure no longer attempts the winget download where it can never succeed. Linux startup 5.7s to 0.7s. --- lib/app.ml | 4 ++-- lib/bootstrap.ml | 10 ++++++-- lib/bootstrap.mli | 4 +++- lib/dashboard.ml | 53 ++++++++++++++++++++++++++++++++++++++---- test/test_bootstrap.ml | 20 +++++++++++++++- test/test_dashboard.ml | 22 ++++++++++++++++++ 6 files changed, 102 insertions(+), 11 deletions(-) diff --git a/lib/app.ml b/lib/app.ml index 656e5d1..e9ac0dc 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -11,8 +11,8 @@ stays out. - No dead append helper: only wired commands ship. - [--new] appends every newly-detected app. - - [winget show] enrichment runs sequentially; parallelize when it - measurably hurts. + - [winget show] enrichment runs on up to 8 domains (see + [Dashboard.build_sections]); [ensure] never downloads off Windows. - pm order: [winget; npm; pipx; uv; cargo]. *) open Manifest diff --git a/lib/bootstrap.ml b/lib/bootstrap.ml index d001a5c..b174c73 100644 --- a/lib/bootstrap.ml +++ b/lib/bootstrap.ml @@ -379,14 +379,20 @@ let cached_path, reset_path_cache = make_path_cache () (** Locate winget, downloading it when nothing resolves. A non-empty [~override_path] (the [# winget:] directive) is returned blindly: no - existence check. *) -let ensure_full ~override_path ~resolve_path (io : io) : (string, string) result = + existence check. The download only ever runs on Windows ([~os] + injectable for tests): elsewhere winget cannot exist, so resolving + straight to an error instead of burning seconds on a doomed download. *) +let ensure_full ~override_path ~resolve_path ?(os = Sys.os_type) (io : io) + : (string, string) result + = if override_path <> "" then Ok override_path else ( let w = resolve_path io in if w <> "" then Ok w + else if os <> "Win32" + then Error "winget is only available on Windows" else ( match download_winget io with | Ok _ as ok -> ok diff --git a/lib/bootstrap.mli b/lib/bootstrap.mli index eb2d536..bf7cd38 100644 --- a/lib/bootstrap.mli +++ b/lib/bootstrap.mli @@ -42,10 +42,12 @@ val format_size : int64 -> string val make_path_cache : unit -> (io -> string) * (unit -> unit) (** Locate winget, downloading it when nothing resolves. A non-empty - [~override_path] is returned blindly. *) + [~override_path] is returned blindly. The download only runs when + [~os] is ["Win32"] (default: [Sys.os_type]). *) val ensure_full : override_path:string -> resolve_path:(io -> string) + -> ?os:string -> io -> (string, string) result diff --git a/lib/dashboard.ml b/lib/dashboard.ml index f197342..5db19b2 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -12,6 +12,31 @@ type app = ; pm : string } +(** Map [f] over [xs] on up to 8 domains, results in input order. One + domain per item would drown short lists in thread overhead, so items + are chunked; empty chunks are skipped. Domain-safe as long as [f] + touches no shared mutable state (here: one process spawn per call). *) +let par_map8 (f : 'a -> 'b) (xs : 'a list) : 'b list = + let arr = Array.of_list xs in + let n = Array.length arr in + if n = 0 + then [] + else ( + let workers = min 8 n in + let chunk = (n + workers - 1) / workers in + let jobs = + List.filter_map + (fun w -> + let lo = w * chunk in + if lo >= n + then None + else Some (Array.sub arr lo (min chunk (n - lo)) |> Array.to_list)) + (List.init workers Fun.id) + in + let doms = List.map (fun job -> Domain.spawn (fun () -> List.map f job)) jobs in + List.concat_map Domain.join doms) +;; + let status_symbol = function | Installed -> "✓" | NeedsUpdate -> "!" @@ -104,8 +129,26 @@ let build_sections }) pkgs_sections in - (* 2. `winget show` fallback for NotFound winget items (sequential here; - Go fans out to 8 workers; parallelism can return if this proves slow). *) + (* 2. `winget show` fallback for NotFound winget items: every missing + id is queried up front on up to 8 domains (each call is one process + spawn, ~1s on Windows; sequential was the startup bottleneck), then + the merge below reads from the table. *) + let show_ids = + List.concat_map + (fun sec -> + List.filter_map + (fun it -> + if it.typ = Winget && it.status = NotFound then Some it.value else None) + sec.items) + pkgs_sections + in + let show_table : (string, string option) Hashtbl.t = + Hashtbl.create (max 1 (List.length show_ids)) + in + List.iter2 + (fun id ver -> Hashtbl.replace show_table id ver) + show_ids + (par_map8 show show_ids); let pkgs_sections = List.map (fun sec -> @@ -116,9 +159,9 @@ let build_sections if it.typ <> Winget || it.status <> NotFound then it else ( - match show it.value with - | None -> it - | Some ver -> + match Hashtbl.find_opt show_table it.value with + | None | Some None -> it + | Some (Some ver) -> let it = { it with available_version = ver } in let name = lower it.value in (match Hashtbl.find_opt scan_lookup name with diff --git a/test/test_bootstrap.ml b/test/test_bootstrap.ml index 00e8780..fef71bd 100644 --- a/test/test_bootstrap.ml +++ b/test/test_bootstrap.ml @@ -263,7 +263,7 @@ let test_ensure_resolved () = let test_ensure_download_cert_advice () = let get, _ = fresh_cache () in let io = base_io ~latest:(Error "x509: certificate signed by unknown authority") () in - match Bootstrap.ensure_full ~override_path:"" ~resolve_path:get io with + match Bootstrap.ensure_full ~override_path:"" ~resolve_path:get ~os:"Win32" io with | Ok _ -> Alcotest.fail "expected download error" | Error e -> Alcotest.(check bool) @@ -272,6 +272,20 @@ let test_ensure_download_cert_advice () = (Strutil.contains_substring "Trusted Root" e) ;; +let test_ensure_no_download_off_windows () = + let get, _ = fresh_cache () in + let io = + base_io + ~latest:(Error "must not be called") + ~download:(fun ~url:_ -> Error "must not be called") + () + in + match Bootstrap.ensure_full ~override_path:"" ~resolve_path:get ~os:"Unix" io with + | Ok _ -> Alcotest.fail "expected error" + | Error e -> + Alcotest.(check string) "fast failure" "winget is only available on Windows" e +;; + (* --- download_winget against fixtures --- *) let copy_to_temp src name = @@ -453,6 +467,10 @@ let () = , [ Alcotest.test_case "override blind" `Quick test_ensure_override_blind ; Alcotest.test_case "resolved" `Quick test_ensure_resolved ; Alcotest.test_case "cert advice" `Quick test_ensure_download_cert_advice + ; Alcotest.test_case + "no download off Windows" + `Quick + test_ensure_no_download_off_windows ] ) ; ( "download" , [ Alcotest.test_case "happy path" `Quick test_download_happy diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml index f2d26a6..9b7c5b6 100644 --- a/test/test_dashboard.ml +++ b/test/test_dashboard.ml @@ -83,6 +83,27 @@ let show_fallback () = | _ -> Alcotest.fail "stays NotFound" ;; +let show_fallback_many () = + (* 30 missing ids: every one gets a show call and its version lands on + the right item (parallel path, order preserved). *) + let ids = List.init 30 (fun i -> Printf.sprintf "App.%d" i) in + let manifest = [ { name = "Many"; items = List.map (item Winget) ids } ] in + let calls = ref [] in + let show id = + calls := id :: !calls; + Some (id ^ "-ver") + in + let sections = Dashboard.build_sections ~show [] manifest None in + let got = (List.nth sections 0).items in + Alcotest.(check int) "all enriched" 30 (List.length got); + List.iter2 + (fun id it -> + Alcotest.(check string) ("version " ^ id) (id ^ "-ver") it.available_version) + ids + got; + Alcotest.(check int) "show called per id" 30 (List.length !calls) +;; + let render_fixture () = let sections = [ { name = "Pending updates" @@ -140,6 +161,7 @@ let () = , [ Alcotest.test_case "basic" `Quick merge_basic ; Alcotest.test_case "winget artifact dropped" `Quick winget_artifact_dropped ; Alcotest.test_case "show fallback" `Quick show_fallback + ; Alcotest.test_case "show fallback many" `Quick show_fallback_many ] ) ; ( "render" , [ Alcotest.test_case "exact fixture" `Quick render_fixture From 7cccce9b92cacbcd2c8382e2d2bec23bfcf44976 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 17:50:12 +0000 Subject: [PATCH 09/34] Parallelize PM scans, add DEVKIT_TIMING startup phases scan_all runs winget on its own domain while the other PMs scan via Proc.par_map8, so startup costs max(winget, slowest other) instead of the sum. par_map8 moves from Dashboard to Proc for reuse. DEVKIT_TIMING=1 prints per-phase timings to stderr. --- README.md | 12 +++++++++-- lib/app.ml | 53 +++++++++++++++++++++++++++++++++--------------- lib/dashboard.ml | 27 +----------------------- lib/inventory.ml | 27 ++++++++++++++---------- lib/proc.ml | 25 +++++++++++++++++++++++ lib/proc.mli | 4 ++++ 6 files changed, 93 insertions(+), 55 deletions(-) diff --git a/README.md b/README.md index 04af0ec..3ad7722 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ # devkit -Scan your PC for installed software across package managers, merge the -result with a `devkit.toml` manifest, and export a restore-ready snapshot. +Export and import your dev setup, snapshot the software +installed across your package managers into a `devkit.toml` manifest. Support for Linux and Windows. ## Build @@ -15,6 +15,14 @@ dune runtest # 129 alcotests, must stay green dune exec bin/main.exe -- --help ``` +Without `eval $(opam env ...)`, the shell finds the wrong dune +(`/usr/bin`) and the build fails with missing libraries (e.g. +`notty.unix not found`). To stop prefixing every command, persist it: + +```sh +echo 'eval $(opam env --switch=system 2>/dev/null)' >> ~/.bashrc +``` + `dune-project` is the source of truth for packaging; `devkit.opam` is generated (see AGENTS.md for the regen dance). Every `lib/*.ml` has a `.mli`; format with `ocamlformat -i` before testing. diff --git a/lib/app.ml b/lib/app.ml index e9ac0dc..4766ff1 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -97,29 +97,48 @@ type scan = ; winget : string } +(** [DEVKIT_TIMING=1] prints per-phase startup timings to stderr, so a + slow start can be blamed on a phase instead of guessed at. *) +let timed (label : string) (f : unit -> 'a) : 'a = + match Sys.getenv_opt "DEVKIT_TIMING" with + | None | Some "" -> f () + | Some _ -> + let t0 = Unix.gettimeofday () in + let r = f () in + Printf.eprintf + "[timing] %s: %.0fms\n%!" + label + ((Unix.gettimeofday () -. t0) *. 1000.0); + r +;; + (** One scan + update check; the memoized [winget list] fetch is shared by both, so a command spawns winget once per 8s window. A failed ensure degrades to winget-less operation (""). *) let scan (e : env) ~(override_path : string) ~(extra : Plugin.tool list) : scan = let winget = - match Bootstrap.ensure ~override_path e.bio with - | Ok w -> w - | Error _ -> "" + timed "ensure" (fun () -> + match Bootstrap.ensure ~override_path e.bio with + | Ok w -> w + | Error _ -> "") in let fetch, _ = Proc.winget_list e.run in - let apps = Inventory.scan_all e.run ~winget:(fun () -> fetch winget) ~extra in + let apps = + timed "scan_all" (fun () -> Inventory.scan_all e.run ~winget:(fun () -> fetch winget) ~extra) + in let info = - match fetch winget with - | None -> - let m = info_from_scan apps in - if Winget_parse.IdMap.is_empty m then None else Some m - | Some out -> - let m = Winget_parse.parse_list_table out in - if Winget_parse.IdMap.is_empty m - then ( - let fb = info_from_scan apps in - if Winget_parse.IdMap.is_empty fb then None else Some fb) - else Some m + timed "info" (fun () -> + match fetch winget with + | None -> + let m = info_from_scan apps in + if Winget_parse.IdMap.is_empty m then None else Some m + | Some out -> + let m = Winget_parse.parse_list_table out in + if Winget_parse.IdMap.is_empty m + then ( + let fb = info_from_scan apps in + if Winget_parse.IdMap.is_empty fb then None else Some fb) + else Some m) in { apps; info; winget } ;; @@ -139,7 +158,9 @@ let default_view (e : env) ~(tools : Plugin.tool list) : string = let v = winget_show e.bio s.winget id in if v = "" then None else Some v in - let dash = build_sections ~show (to_dashboard_apps s.apps) sections s.info in + let dash = + timed "build" (fun () -> build_sections ~show (to_dashboard_apps s.apps) sections s.info) + in render dash ;; diff --git a/lib/dashboard.ml b/lib/dashboard.ml index 5db19b2..bd8cf3d 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -12,31 +12,6 @@ type app = ; pm : string } -(** Map [f] over [xs] on up to 8 domains, results in input order. One - domain per item would drown short lists in thread overhead, so items - are chunked; empty chunks are skipped. Domain-safe as long as [f] - touches no shared mutable state (here: one process spawn per call). *) -let par_map8 (f : 'a -> 'b) (xs : 'a list) : 'b list = - let arr = Array.of_list xs in - let n = Array.length arr in - if n = 0 - then [] - else ( - let workers = min 8 n in - let chunk = (n + workers - 1) / workers in - let jobs = - List.filter_map - (fun w -> - let lo = w * chunk in - if lo >= n - then None - else Some (Array.sub arr lo (min chunk (n - lo)) |> Array.to_list)) - (List.init workers Fun.id) - in - let doms = List.map (fun job -> Domain.spawn (fun () -> List.map f job)) jobs in - List.concat_map Domain.join doms) -;; - let status_symbol = function | Installed -> "✓" | NeedsUpdate -> "!" @@ -148,7 +123,7 @@ let build_sections List.iter2 (fun id ver -> Hashtbl.replace show_table id ver) show_ids - (par_map8 show show_ids); + (Proc.par_map8 show show_ids); let pkgs_sections = List.map (fun sec -> diff --git a/lib/inventory.ml b/lib/inventory.ml index 65fb414..a357586 100644 --- a/lib/inventory.ml +++ b/lib/inventory.ml @@ -245,24 +245,29 @@ let scan_tool (run : Proc.runner) (t : Plugin.tool) : app list = ;; (** Full scan order: winget, npm, pipx, uv, cargo, then [extra] custom - tools in file order. [winget] is the memoized [winget list] fetch - ([Proc.winget_list]), so a scan followed by an update check spawns - winget once per window. *) + tools in file order. The winget fetch runs on its own domain while + the rest scan in parallel, so startup costs max(winget, slowest + other) instead of the sum. [winget] is the memoized [winget list] + fetch ([Proc.winget_list]), so a scan followed by an update check + spawns winget once per window. *) let scan_all (run : Proc.runner) ~(winget : unit -> string option) ~(extra : Plugin.tool list) : app list = - let winget_apps = - match winget () with - | None -> [] - | Some out -> parse_winget out + let winget_dom = + Domain.spawn + (fun () -> + match winget () with + | None -> [] + | Some out -> parse_winget out) in let apps = - List.concat_map - (fun (t : Plugin.tool) -> scan_tool run t) - [ npm_tool; pipx_tool; uv_tool; cargo_tool ] + List.concat + (Proc.par_map8 + (scan_tool run) + ([ npm_tool; pipx_tool; uv_tool; cargo_tool ] @ extra)) in - winget_apps @ apps @ List.concat_map (scan_tool run) extra + Domain.join winget_dom @ apps ;; diff --git a/lib/proc.ml b/lib/proc.ml index 4150a44..187e0d2 100644 --- a/lib/proc.ml +++ b/lib/proc.ml @@ -28,6 +28,31 @@ let default_runner : runner = | _ -> None ;; +(** Map [f] over [xs] on up to 8 domains, results in input order. One + domain per item would drown short lists in thread overhead, so items + are chunked; empty chunks are skipped. Domain-safe as long as [f] + touches no shared mutable state (here: one process spawn per call). *) +let par_map8 (f : 'a -> 'b) (xs : 'a list) : 'b list = + let arr = Array.of_list xs in + let n = Array.length arr in + if n = 0 + then [] + else ( + let workers = min 8 n in + let chunk = (n + workers - 1) / workers in + let jobs = + List.filter_map + (fun w -> + let lo = w * chunk in + if lo >= n + then None + else Some (Array.sub arr lo (min chunk (n - lo)) |> Array.to_list)) + (List.init workers Fun.id) + in + let doms = List.map (fun job -> Domain.spawn (fun () -> List.map f job)) jobs in + List.concat_map Domain.join doms) +;; + (** Memoized [winget list --verbose] fetcher with resetter. The inventory scan and the update check share one [winget list] invocation per 8s window, so refresh ticks never pop extra winget diff --git a/lib/proc.mli b/lib/proc.mli index c34c1f6..779169f 100644 --- a/lib/proc.mli +++ b/lib/proc.mli @@ -10,3 +10,7 @@ val default_runner : runner (** Memoized [winget list --verbose] fetcher with resetter: one winget invocation per 8s window per resolved path. *) val winget_list : runner -> (string -> string option) * (unit -> unit) + +(** Map [f] over [xs] on up to 8 domains, results in input order. + Domain-safe as long as [f] touches no shared mutable state. *) +val par_map8 : ('a -> 'b) -> 'a list -> 'b list From c7ec8a3f99ade3ac2c08afb825e33b3a88fbb2c2 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 17:50:12 +0000 Subject: [PATCH 10/34] Fix Windows CI notty build, fall back to plain dashboard Apply the ocaml55 patch from outside the clone (../ci path). Shim winsize.c with a Win32 console fallback so notty.unix compiles on mingw; Unix branch untouched. main falls back to plain text on Win32. Both shims die with notty in Phase B. --- .github/workflows/ci.yml | 10 ++++++-- bin/main.ml | 13 ++++++---- ci/notty-winsize-windows.c | 49 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 7 deletions(-) create mode 100644 ci/notty-winsize-windows.c diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c1b892c..4472ed6 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,11 +20,17 @@ jobs: dune-cache: true # Release notty caps ocaml < 5.4; master builds on 5.5 with one - # extra record field (ci/notty-ocaml55.patch). + # extra record field (ci/notty-ocaml55.patch). Upstream has no + # Windows backend, so ci/notty-winsize-windows.c (Win32 console + # fallback, upstream code untouched in #else) is copied over + # src-unix/native/winsize.c to keep notty.unix compiling on + # mingw. CI never runs the TUI on Windows (plain-text fallback + # in bin/main.ml); both shims die with notty in Phase B. - name: Pin patched notty run: | git clone --depth 50 https://github.com/pqwy/notty.git notty-upstream - git -C notty-upstream apply ci/notty-ocaml55.patch + git -C notty-upstream apply ../ci/notty-ocaml55.patch + cp ci/notty-winsize-windows.c notty-upstream/src-unix/native/winsize.c opam pin add notty ./notty-upstream -yn - name: Install dependencies diff --git a/bin/main.ml b/bin/main.ml index 9299644..06b726f 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,8 +1,9 @@ (** devkit CLI. - Commands: default (dashboard), import, add, append [--new], export - [-o]. The default command opens the interactive TUI on a terminal and - prints the plain-text dashboard when piped. *) + Commands: default (dashboard), import, add, append [--new], export + [-o]. The default command opens the interactive TUI on a terminal + (plain-text dashboard when piped, or on Win32 where notty has no + backend). *) open Devkit @@ -65,8 +66,10 @@ let default_term = const (fun () -> let tools = load_tools () in let env = make_env () in - (* Piped output stays plain text; a terminal gets the TUI. *) - if Unix.isatty Unix.stdout + (* Piped output stays plain text; a terminal gets the TUI. Notty + has no Windows backend, so Win32 terminals get plain text too + (the TUI returns with lambda-term). *) + if Unix.isatty Unix.stdout && Sys.os_type <> "Win32" then Tui_front.run ~tools env else print_string (App.default_view ~tools env)) $ const ()) diff --git a/ci/notty-winsize-windows.c b/ci/notty-winsize-windows.c new file mode 100644 index 0000000..1067f2b --- /dev/null +++ b/ci/notty-winsize-windows.c @@ -0,0 +1,49 @@ +/* Windows-capable replacement for notty's src-unix/native/winsize.c. + * Upstream notty has no Windows backend (sys/ioctl.h, SIGWINCH), so a + * stock master clone cannot build notty.unix on mingw. CI copies this + * file over the upstream one before pinning; the #else branch is the + * untouched upstream code, so Unix builds are unaffected. + * + * This is a compile-only shim: CI never runs the TUI on Windows, and + * bin/main.ml falls back to the plain-text dashboard on Win32. Delete + * this file (and the notty pin) when the frontend moves to lambda-term. + */ +#ifdef _WIN32 +#include +#include + +CAMLprim value caml_notty_winsize (value vfd) { + CONSOLE_SCREEN_BUFFER_INFO info; + (void)vfd; + if (GetConsoleScreenBufferInfo (GetStdHandle (STD_OUTPUT_HANDLE), &info)) { + int cols = info.srWindow.Right - info.srWindow.Left + 1; + int rows = info.srWindow.Bottom - info.srWindow.Top + 1; + return Val_int ((cols << 16) + ((rows & 0x7fff) << 1)); + } + return Val_int (0); +} + +#define __unit() value unit __attribute__((unused)) + +CAMLprim value caml_notty_winch_number (__unit()) { + return Val_int (0); +} +#else +#include +#include +#include + +CAMLprim value caml_notty_winsize (value vfd) { + int fd = Int_val (vfd); + struct winsize w; + if (ioctl (fd, TIOCGWINSZ, &w) >= 0) + return Val_int ((w.ws_col << 16) + ((w.ws_row & 0x7fff) << 1)); + return Val_int (0); +} + +#define __unit() value unit __attribute__((unused)) + +CAMLprim value caml_notty_winch_number (__unit()) { + return Val_int (SIGWINCH); +} +#endif From f701f5e714c90c42b2a41fca88fddfefddf4c929 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 17:54:28 +0000 Subject: [PATCH 11/34] Replace notty TUI with lambda-term on both OSes bin/tui_front is rewritten against LTerm events driving the untouched lib/tui state machine: same keys (arrows/j/k/pgup/pgdn/home/end/Enter/q/Esc/Ctrl), same exit-to-dashboard behavior. Wheel input dropped (no reliable mapping). notty is gone: dep, CI pin, both ci/notty shims, and the Win32 plain-text fallback. --- .github/workflows/ci.yml | 14 ---- README.md | 5 +- bin/dune | 2 +- bin/main.ml | 9 +- bin/tui_front.ml | 168 +++++++++++++++++++++++-------------- ci/notty-ocaml55.patch | 28 ------- ci/notty-winsize-windows.c | 49 ----------- devkit.opam | 3 +- dune-project | 5 +- lib/fetch.ml | 7 +- lib/tui.ml | 4 +- 11 files changed, 121 insertions(+), 173 deletions(-) delete mode 100644 ci/notty-ocaml55.patch delete mode 100644 ci/notty-winsize-windows.c diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 4472ed6..9d0984a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -19,20 +19,6 @@ jobs: ocaml-compiler: 5.5 dune-cache: true - # Release notty caps ocaml < 5.4; master builds on 5.5 with one - # extra record field (ci/notty-ocaml55.patch). Upstream has no - # Windows backend, so ci/notty-winsize-windows.c (Win32 console - # fallback, upstream code untouched in #else) is copied over - # src-unix/native/winsize.c to keep notty.unix compiling on - # mingw. CI never runs the TUI on Windows (plain-text fallback - # in bin/main.ml); both shims die with notty in Phase B. - - name: Pin patched notty - run: | - git clone --depth 50 https://github.com/pqwy/notty.git notty-upstream - git -C notty-upstream apply ../ci/notty-ocaml55.patch - cp ci/notty-winsize-windows.c notty-upstream/src-unix/native/winsize.c - opam pin add notty ./notty-upstream -yn - - name: Install dependencies run: opam install . --deps-only --with-test -y diff --git a/README.md b/README.md index 3ad7722..d209acc 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,8 @@ installed across your package managers into a `devkit.toml` manifest. Support fo ## Build System OCaml 5.5.0 + opam `system` switch. Deps: -`alcotest cmdliner yojson digestif decompress sexplib re ocamlformat`. +`alcotest cmdliner yojson digestif decompress sexplib re toml +lambda-term lwt ocamlformat`. ```sh eval $(opam env --switch=system) @@ -17,7 +18,7 @@ dune exec bin/main.exe -- --help Without `eval $(opam env ...)`, the shell finds the wrong dune (`/usr/bin`) and the build fails with missing libraries (e.g. -`notty.unix not found`). To stop prefixing every command, persist it: +`lambda-term not found`). To stop prefixing every command, persist it: ```sh echo 'eval $(opam env --switch=system 2>/dev/null)' >> ~/.bashrc diff --git a/bin/dune b/bin/dune index 69a97d4..8fb178c 100644 --- a/bin/dune +++ b/bin/dune @@ -2,4 +2,4 @@ (public_name devkit) (name main) (modules main tui_front) - (libraries devkit cmdliner unix notty.unix)) + (libraries devkit cmdliner unix lambda-term lwt.unix)) diff --git a/bin/main.ml b/bin/main.ml index 06b726f..f34b3ad 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -2,8 +2,7 @@ Commands: default (dashboard), import, add, append [--new], export [-o]. The default command opens the interactive TUI on a terminal - (plain-text dashboard when piped, or on Win32 where notty has no - backend). *) + and prints the plain-text dashboard when piped. *) open Devkit @@ -66,10 +65,8 @@ let default_term = const (fun () -> let tools = load_tools () in let env = make_env () in - (* Piped output stays plain text; a terminal gets the TUI. Notty - has no Windows backend, so Win32 terminals get plain text too - (the TUI returns with lambda-term). *) - if Unix.isatty Unix.stdout && Sys.os_type <> "Win32" + (* Piped output stays plain text; a terminal gets the TUI. *) + if Unix.isatty Unix.stdout then Tui_front.run ~tools env else print_string (App.default_view ~tools env)) $ const ()) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index b21a626..ad7f2da 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -1,64 +1,81 @@ -(** Notty frontend for the dashboard state machine. +(** Lambda-term frontend for the dashboard state machine. - Draws {!Devkit.Tui.frame} lines, feeds key events in, runs installs on - Enter. On exit the plain-text dashboard plus the install log go to - stdout, so redirected output stays usable. *) + Draws {!Devkit.Tui.frame} lines, feeds key events in, runs installs + on Enter. On exit the plain-text dashboard plus the install log go + to stdout, so redirected output stays usable. Lambda-term (unlike + notty) has a real Windows backend, so this frontend serves both + OSes. Installs run synchronously and freeze the UI while they run; + mouse/wheel input is ignored (keyboard scroll covers it). *) open Devkit -open Notty -open Notty_unix +open Lwt.Infix -let kind_of : Manifest.item_type -> string = function - | Manifest.Winget -> "winget" - | Manifest.GitHub -> "github" - | Manifest.Url -> "url" - | Manifest.Pm s -> s +let style_of_color : Tui.color -> LTerm_style.t = function + | Tui.Plain -> LTerm_style.none + | Tui.Green -> { LTerm_style.none with foreground = Some LTerm_style.green } + | Tui.Yellow -> { LTerm_style.none with foreground = Some LTerm_style.yellow } + | Tui.Red -> { LTerm_style.none with foreground = Some LTerm_style.red } + | Tui.Cyan -> { LTerm_style.none with foreground = Some LTerm_style.cyan } ;; -let color_attr : Tui.color -> attr = function - | Tui.Plain -> A.empty - | Tui.Green -> A.(fg green) - | Tui.Yellow -> A.(fg yellow) - | Tui.Red -> A.(fg red) - | Tui.Cyan -> A.(fg cyan) +let styled_of_line (i : int) : Tui.line -> LTerm_text.t = function + | Tui.Head s when i = 0 -> + LTerm_text.stylise s { LTerm_style.none with bold = Some true } + | Tui.Head s -> LTerm_text.of_utf8 s + | Tui.Divider _ as d -> + LTerm_text.stylise + (" " ^ Tui.render_line d) + { LTerm_style.none with bold = Some true; foreground = Some LTerm_style.lblack } + | Tui.Row (e, cursor) as row -> + let style = style_of_color (Tui.color_of e.Tui.item.Manifest.status) in + let style = if cursor then { style with reverse = Some true } else style in + LTerm_text.stylise (Tui.render_line row) style ;; -let draw (st : Tui.state) : image = - let img_of_line i = function - | Tui.Head s -> if i = 0 then I.string A.(st bold) s else I.string A.empty s - | Tui.Divider _ as d -> I.string A.(st bold ++ fg lightblack) (" " ^ Tui.render_line d) - | Tui.Row (e, cursor) -> - let attr = color_attr (Tui.color_of e.Tui.item.Manifest.status) in - let attr = if cursor then A.(attr ++ st reverse) else attr in - I.string attr (Tui.render_line (Tui.Row (e, cursor))) - in - I.vcat (List.mapi img_of_line (Tui.lines st)) +type ev = + | Quit + | Enter + | Action of Tui.action + | Resized of LTerm_geom.size + | Nothing + +let is_ctrl_q : Uchar.t -> bool = + fun c -> Uchar.equal c (Uchar.of_char 'q') || Uchar.equal c (Uchar.of_char 'Q') ;; -type ev = - [ Notty.Unescape.event - | `Resize of int * int - | `End - ] +let is_nav : Uchar.t -> Tui.action option = + fun c -> + if Uchar.equal c (Uchar.of_char 'k') + then Some Tui.Up + else if Uchar.equal c (Uchar.of_char 'j') + then Some Tui.Down + else None +;; -let quit_key : ev -> bool = function - | `End -> true - | `Key (`Escape, _) -> true - | `Key (`ASCII 'q', _) | `Key (`ASCII 'Q', _) -> true - | `Key (_, mods) -> List.mem `Ctrl mods - | _ -> false +let classify : LTerm_event.t -> ev = function + | LTerm_event.Resize size -> Resized size + | LTerm_event.Key k when k.LTerm_key.control -> Quit + | LTerm_event.Key { code = LTerm_key.Escape; _ } -> Quit + | LTerm_event.Key { code = LTerm_key.Char c; _ } when is_ctrl_q c -> Quit + | LTerm_event.Key { code = LTerm_key.Enter; _ } -> Enter + | LTerm_event.Key { code = LTerm_key.Up; _ } -> Action Tui.Up + | LTerm_event.Key { code = LTerm_key.Down; _ } -> Action Tui.Down + | LTerm_event.Key { code = LTerm_key.Prev_page; _ } -> Action Tui.Page_up + | LTerm_event.Key { code = LTerm_key.Next_page; _ } -> Action Tui.Page_down + | LTerm_event.Key { code = LTerm_key.Home; _ } -> Action Tui.Home + | LTerm_event.Key { code = LTerm_key.End; _ } -> Action Tui.End + | LTerm_event.Key { code = LTerm_key.Char c; _ } -> + (match is_nav c with + | Some a -> Action a + | None -> Nothing) + | LTerm_event.Key _ | LTerm_event.Sequence _ | LTerm_event.Mouse _ -> Nothing ;; -let nav : ev -> Tui.action option = function - | `Key (`Arrow `Up, _) | `Key (`ASCII 'k', _) -> Some Tui.Up - | `Key (`Arrow `Down, _) | `Key (`ASCII 'j', _) -> Some Tui.Down - | `Key (`Page `Up, _) -> Some Tui.Page_up - | `Key (`Page `Down, _) -> Some Tui.Page_down - | `Key (`Home, _) -> Some Tui.Home - | `Key (`End, _) -> Some Tui.End - | `Mouse (`Press (`Scroll `Up), _, _) -> Some Tui.Scroll_up - | `Mouse (`Press (`Scroll `Down), _, _) -> Some Tui.Scroll_down - | _ -> None +let kind_of : Manifest.item_type -> string = function + | Manifest.Winget -> "winget" + | Manifest.GitHub -> "github" + | Manifest.Url -> "url" + | Manifest.Pm s -> s ;; let press_enter (deps : Install.deps) (st : Tui.state) : Tui.state = @@ -80,6 +97,16 @@ let press_enter (deps : Install.deps) (st : Tui.state) : Tui.state = let viewport (w : int) (h : int) : int * int = max 1 w, max 1 (h - 3) +let draw_all (term : LTerm.t) (st : Tui.state) : unit Lwt.t = + LTerm.clear_screen term + >>= fun () -> + LTerm.goto term { row = 0; col = 0 } + >>= fun () -> + Lwt_list.iter_s + (fun text -> LTerm.fprintls term text) + (List.mapi styled_of_line (Tui.lines st)) +;; + let run ~(tools : Plugin.tool list) (env : App.env) : unit = let sections, winget_path = App.load_manifest env.App.fs Manifest.filename in let s = App.scan env ~override_path:winget_path ~extra:tools in @@ -91,24 +118,35 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = let dash = Dashboard.build_sections ~show s.App.apps sections s.App.info in let fetch = Fetch.curl_fetch Proc.default_runner in let deps = Install.real_deps fetch ~winget_override:winget_path () in - let term = Term.create () in - let w, h = Term.size term in - let vw, vh = viewport w h in - let rec loop (st : Tui.state) : Tui.state = - Term.image term (draw st); - match Term.event term with - | ev when quit_key ev -> st - | `Key (`Enter, _) -> loop (press_enter deps st) - | `Resize (w, h) -> - let vw, vh = viewport w h in - loop (Tui.resize st ~height:vh ~width:vw) - | ev -> - (match nav ev with - | Some a -> loop (Tui.step st a) - | None -> loop st) + let final = + Lwt_main.run + (Lazy.force LTerm.stdout + >>= fun term -> + LTerm.enter_raw_mode term + >>= fun mode -> + LTerm.hide_cursor term + >>= fun () -> + let geom = LTerm.size term in + let vw, vh = viewport geom.LTerm_geom.cols geom.LTerm_geom.rows in + let rec loop (st : Tui.state) : Tui.state Lwt.t = + draw_all term st + >>= fun () -> + LTerm.read_event term + >>= fun ev -> + match classify ev with + | Quit -> Lwt.return st + | Enter -> loop (press_enter deps st) + | Action a -> loop (Tui.step st a) + | Resized g -> + let vw, vh = viewport g.LTerm_geom.cols g.LTerm_geom.rows in + loop (Tui.resize st ~height:vh ~width:vw) + | Nothing -> loop st + in + loop (Tui.make dash ~height:vh ~width:vw) + >>= fun st -> + LTerm.leave_raw_mode term mode + >>= fun () -> LTerm.show_cursor term >>= fun () -> Lwt.return st) in - let final = loop (Tui.make dash ~height:vh ~width:vw) in - Term.release term; print_string (Dashboard.render dash); List.iter print_endline final.Tui.log ;; diff --git a/ci/notty-ocaml55.patch b/ci/notty-ocaml55.patch deleted file mode 100644 index ad43bc8..0000000 --- a/ci/notty-ocaml55.patch +++ /dev/null @@ -1,28 +0,0 @@ -# notty on OCaml >= 5.4: Format.formatter_out_functions gained an -# out_width field and upstream master does not set it yet. Apply after -# cloning pqwy/notty master: -# -# git clone https://github.com/pqwy/notty.git -# git -C notty apply /path/to/ci/notty-ocaml55.patch -# opam pin add notty ./notty -yn -# -# The implementation counts UTF-8 leading bytes in the slice, which is -# the scalar-value count Format documents as the reasonable default. -diff --git a/src/notty.ml b/src/notty.ml -index 7385083..1ea50e5 100644 ---- a/src/notty.ml -+++ b/src/notty.ml -@@ -390,6 +390,13 @@ module I = struct - img := !img <-> !line; line := void 0 1) - ; out_string = (fun s i n -> - line := !line <|> string (top_a attr) String.(sub0cp s i n)) -+ (* Width of the substring as scalar count (Format.out_width, OCaml >= 5.4). *) -+ ; out_width = (fun s ~pos ~len -> -+ let n = ref 0 in -+ for i = pos to pos + len - 1 do -+ if Char.code s.[i] land 0xC0 <> 0x80 then incr n -+ done; -+ !n) - (* Not entirely clear; either or both could be void: *) - ; out_spaces = (fun w -> line := !line <|> char (top_a attr) ' ' w 1) - ; out_indent = (fun w -> line := !line <|> char (top_a attr) ' ' w 1) diff --git a/ci/notty-winsize-windows.c b/ci/notty-winsize-windows.c deleted file mode 100644 index 1067f2b..0000000 --- a/ci/notty-winsize-windows.c +++ /dev/null @@ -1,49 +0,0 @@ -/* Windows-capable replacement for notty's src-unix/native/winsize.c. - * Upstream notty has no Windows backend (sys/ioctl.h, SIGWINCH), so a - * stock master clone cannot build notty.unix on mingw. CI copies this - * file over the upstream one before pinning; the #else branch is the - * untouched upstream code, so Unix builds are unaffected. - * - * This is a compile-only shim: CI never runs the TUI on Windows, and - * bin/main.ml falls back to the plain-text dashboard on Win32. Delete - * this file (and the notty pin) when the frontend moves to lambda-term. - */ -#ifdef _WIN32 -#include -#include - -CAMLprim value caml_notty_winsize (value vfd) { - CONSOLE_SCREEN_BUFFER_INFO info; - (void)vfd; - if (GetConsoleScreenBufferInfo (GetStdHandle (STD_OUTPUT_HANDLE), &info)) { - int cols = info.srWindow.Right - info.srWindow.Left + 1; - int rows = info.srWindow.Bottom - info.srWindow.Top + 1; - return Val_int ((cols << 16) + ((rows & 0x7fff) << 1)); - } - return Val_int (0); -} - -#define __unit() value unit __attribute__((unused)) - -CAMLprim value caml_notty_winch_number (__unit()) { - return Val_int (0); -} -#else -#include -#include -#include - -CAMLprim value caml_notty_winsize (value vfd) { - int fd = Int_val (vfd); - struct winsize w; - if (ioctl (fd, TIOCGWINSZ, &w) >= 0) - return Val_int ((w.ws_col << 16) + ((w.ws_row & 0x7fff) << 1)); - return Val_int (0); -} - -#define __unit() value unit __attribute__((unused)) - -CAMLprim value caml_notty_winch_number (__unit()) { - return Val_int (SIGWINCH); -} -#endif diff --git a/devkit.opam b/devkit.opam index ded1f7c..81950e9 100644 --- a/devkit.opam +++ b/devkit.opam @@ -18,7 +18,8 @@ depends: [ "sexplib" {>= "0.17"} "re" {>= "1.11"} "toml" {>= "7.0"} - "notty" {>= "0.2.3"} + "lambda-term" {>= "3.0"} + "lwt" {>= "5.0"} "alcotest" {>= "1.7" & with-test} "odoc" {with-doc} ] diff --git a/dune-project b/dune-project index e17d0b4..8db58ee 100644 --- a/dune-project +++ b/dune-project @@ -22,6 +22,7 @@ (decompress (>= 1.5)) (sexplib (>= 0.17)) (re (>= 1.11)) - (toml (>= 7.0)) - (notty (>= 0.2.3)) + (toml (>= 7.0)) + (lambda-term (>= 3.0)) + (lwt (>= 5.0)) (alcotest (and (>= 1.7) :with-test)))) diff --git a/lib/fetch.ml b/lib/fetch.ml index 0660048..6a4083e 100644 --- a/lib/fetch.ml +++ b/lib/fetch.ml @@ -1,8 +1,9 @@ (** HTTP fetching. - OCaml has no stock HTTPS client, and pulling in cohttp/Lwt would clash - with the no-Lwt notty choice, so production fetching shells out to - [curl]: inbox on Windows 10 1803+ and present on most Linux systems. + OCaml has no stock HTTPS client, and pulling cohttp into [lib] + would drag async into the stdlib-only core, so production fetching + shells out to [curl]: inbox on Windows 10 1803+ and present on most + Linux systems. The call shape stays injectable: tests and future backends substitute [fetch]. *) diff --git a/lib/tui.ml b/lib/tui.ml index 367e487..3e55ffe 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -1,7 +1,7 @@ (** Interactive dashboard state machine. Pure navigation, selection and frame rendering over dashboard sections. - The notty frontend in [bin/] draws the frame and feeds key actions in; + The lambda-term frontend in [bin/] draws the frame and feeds key actions in; tests drive [step] and [frame] without a terminal. Row selection mirrors [Dashboard.render]: empty sections and "Newly detected" are skipped. *) @@ -243,7 +243,7 @@ let render_line : line -> string = function | Row (e, cursor) -> (if cursor then "> " else " ") ^ row_text e ;; -(** Text frame: one string per line. The notty frontend draws these +(** Text frame: one string per line. The lambda-term frontend draws these with per-row colors from {!lines}. *) let frame (s : state) : string list = List.map render_line (lines s) From 8271434874b2c2ade2ba8c2ac09fcadf613dc7aa Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 17:58:40 +0000 Subject: [PATCH 12/34] Run TUI on the alternate screen save_state/load_state around the event loop, so redraws paint off-scrollback and exiting restores the shell view. Fixes flashing and repeated frames. --- bin/tui_front.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index ad7f2da..c641b8d 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -126,6 +126,10 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = >>= fun mode -> LTerm.hide_cursor term >>= fun () -> + (* Alternate screen: redraws paint off-scrollback, and exiting + restores the shell view (like the old notty frontend). *) + LTerm.save_state term + >>= fun () -> let geom = LTerm.size term in let vw, vh = viewport geom.LTerm_geom.cols geom.LTerm_geom.rows in let rec loop (st : Tui.state) : Tui.state Lwt.t = @@ -144,6 +148,8 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = in loop (Tui.make dash ~height:vh ~width:vw) >>= fun st -> + LTerm.load_state term + >>= fun () -> LTerm.leave_raw_mode term mode >>= fun () -> LTerm.show_cursor term >>= fun () -> Lwt.return st) in From 0d268f5d60994bee550782b905b57f6604b98810 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 18:13:10 +0000 Subject: [PATCH 13/34] Format lib to ocamlformat Whitespace-only reflow missed by the parallel-scans commit; keeps the CI fmt job green. --- lib/app.ml | 11 +++++------ lib/inventory.ml | 9 ++++----- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/lib/app.ml b/lib/app.ml index 4766ff1..d65a402 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -105,10 +105,7 @@ let timed (label : string) (f : unit -> 'a) : 'a = | Some _ -> let t0 = Unix.gettimeofday () in let r = f () in - Printf.eprintf - "[timing] %s: %.0fms\n%!" - label - ((Unix.gettimeofday () -. t0) *. 1000.0); + Printf.eprintf "[timing] %s: %.0fms\n%!" label ((Unix.gettimeofday () -. t0) *. 1000.0); r ;; @@ -124,7 +121,8 @@ let scan (e : env) ~(override_path : string) ~(extra : Plugin.tool list) : scan in let fetch, _ = Proc.winget_list e.run in let apps = - timed "scan_all" (fun () -> Inventory.scan_all e.run ~winget:(fun () -> fetch winget) ~extra) + timed "scan_all" (fun () -> + Inventory.scan_all e.run ~winget:(fun () -> fetch winget) ~extra) in let info = timed "info" (fun () -> @@ -159,7 +157,8 @@ let default_view (e : env) ~(tools : Plugin.tool list) : string = if v = "" then None else Some v in let dash = - timed "build" (fun () -> build_sections ~show (to_dashboard_apps s.apps) sections s.info) + timed "build" (fun () -> + build_sections ~show (to_dashboard_apps s.apps) sections s.info) in render dash ;; diff --git a/lib/inventory.ml b/lib/inventory.ml index a357586..90287d1 100644 --- a/lib/inventory.ml +++ b/lib/inventory.ml @@ -257,11 +257,10 @@ let scan_all : app list = let winget_dom = - Domain.spawn - (fun () -> - match winget () with - | None -> [] - | Some out -> parse_winget out) + Domain.spawn (fun () -> + match winget () with + | None -> [] + | Some out -> parse_winget out) in let apps = List.concat From e0939ede2d2361688f770f0279657789c0dee920 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 18:13:19 +0000 Subject: [PATCH 14/34] Repaint TUI in place, restore wheel scroll Per-line goto+clear+write instead of full-screen clear, so scrolling no longer flashes. No-op events skip the repaint; resize still repaints from clear. Enable mouse reporting and map wheel up/down to scroll. Add the LTerm.flush that repaints require. --- bin/tui_front.ml | 49 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 16 deletions(-) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index c641b8d..fa6df73 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -4,8 +4,9 @@ on Enter. On exit the plain-text dashboard plus the install log go to stdout, so redirected output stays usable. Lambda-term (unlike notty) has a real Windows backend, so this frontend serves both - OSes. Installs run synchronously and freeze the UI while they run; - mouse/wheel input is ignored (keyboard scroll covers it). *) + OSes. Installs run synchronously and freeze the UI while they run. + Mouse reporting is on for wheel-scroll only; other mouse events are + ignored. *) open Devkit open Lwt.Infix @@ -68,6 +69,10 @@ let classify : LTerm_event.t -> ev = function (match is_nav c with | Some a -> Action a | None -> Nothing) + | LTerm_event.Mouse m when m.LTerm_mouse.button = LTerm_mouse.Button4 -> + Action Tui.Scroll_up + | LTerm_event.Mouse m when m.LTerm_mouse.button = LTerm_mouse.Button5 -> + Action Tui.Scroll_down | LTerm_event.Key _ | LTerm_event.Sequence _ | LTerm_event.Mouse _ -> Nothing ;; @@ -97,14 +102,19 @@ let press_enter (deps : Install.deps) (st : Tui.state) : Tui.state = let viewport (w : int) (h : int) : int * int = max 1 w, max 1 (h - 3) +(** Repaint in place, one addressed line at a time: no full-screen + clear, so scrolling does not flash. Line count only changes on + resize, which repaints from a cleared screen. *) let draw_all (term : LTerm.t) (st : Tui.state) : unit Lwt.t = - LTerm.clear_screen term - >>= fun () -> - LTerm.goto term { row = 0; col = 0 } - >>= fun () -> - Lwt_list.iter_s - (fun text -> LTerm.fprintls term text) + Lwt_list.iteri_s + (fun i text -> + LTerm.goto term { row = i; col = 0 } + >>= fun () -> LTerm.clear_line term >>= fun () -> LTerm.fprints term text) (List.mapi styled_of_line (Tui.lines st)) + >>= fun () -> + (* LTerm buffers through Lwt_io: without this, repaints (and the + first frame) never reach the screen. *) + LTerm.flush term ;; let run ~(tools : Plugin.tool list) (env : App.env) : unit = @@ -130,24 +140,31 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = restores the shell view (like the old notty frontend). *) LTerm.save_state term >>= fun () -> + LTerm.enable_mouse term + >>= fun () -> let geom = LTerm.size term in let vw, vh = viewport geom.LTerm_geom.cols geom.LTerm_geom.rows in - let rec loop (st : Tui.state) : Tui.state Lwt.t = - draw_all term st - >>= fun () -> + (* Draw, then wait: events that change nothing skip the repaint. *) + let rec draw_loop (st : Tui.state) : Tui.state Lwt.t = + draw_all term st >>= fun () -> wait_loop st + and wait_loop (st : Tui.state) : Tui.state Lwt.t = LTerm.read_event term >>= fun ev -> match classify ev with | Quit -> Lwt.return st - | Enter -> loop (press_enter deps st) - | Action a -> loop (Tui.step st a) + | Nothing -> wait_loop st + | Enter -> draw_loop (press_enter deps st) + | Action a -> draw_loop (Tui.step st a) | Resized g -> + LTerm.clear_screen term + >>= fun () -> let vw, vh = viewport g.LTerm_geom.cols g.LTerm_geom.rows in - loop (Tui.resize st ~height:vh ~width:vw) - | Nothing -> loop st + draw_loop (Tui.resize st ~height:vh ~width:vw) in - loop (Tui.make dash ~height:vh ~width:vw) + draw_loop (Tui.make dash ~height:vh ~width:vw) >>= fun st -> + LTerm.disable_mouse term + >>= fun () -> LTerm.load_state term >>= fun () -> LTerm.leave_raw_mode term mode From ca6a1a3b36bc7042f06de163ada7b3b84c5259fb Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 18:35:49 +0000 Subject: [PATCH 15/34] Detect installed apps cross-PM via scan-names and PATH probe Manifest items match scan results by candidate command names (full value, basename, URL stem) instead of exact id. Anything missed falls back to Proc.which: every candidate in one spawn (command -v loop, where on Win32). build_sections takes an optional runner; all live commands pass it, tests skip it. --- bin/tui_front.ml | 4 ++- lib/app.ml | 19 ++++++++--- lib/dashboard.ml | 75 +++++++++++++++++++++++++++++++++++++++--- lib/dashboard.mli | 6 +++- lib/proc.ml | 57 ++++++++++++++++++++++++++++++++ lib/proc.mli | 6 ++++ test/dune | 4 +++ test/test_dashboard.ml | 67 +++++++++++++++++++++++++++++++++++++ test/test_proc.ml | 68 ++++++++++++++++++++++++++++++++++++++ 9 files changed, 295 insertions(+), 11 deletions(-) create mode 100644 test/test_proc.ml diff --git a/bin/tui_front.ml b/bin/tui_front.ml index fa6df73..6ae56a3 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -125,7 +125,9 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = | "" -> None | v -> Some v in - let dash = Dashboard.build_sections ~show s.App.apps sections s.App.info in + let dash = + Dashboard.build_sections ~show ~run:(Some env.App.run) s.App.apps sections s.App.info + in let fetch = Fetch.curl_fetch Proc.default_runner in let deps = Install.real_deps fetch ~winget_override:winget_path () in let final = diff --git a/lib/app.ml b/lib/app.ml index d65a402..90a2a7d 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -158,7 +158,7 @@ let default_view (e : env) ~(tools : Plugin.tool list) : string = in let dash = timed "build" (fun () -> - build_sections ~show (to_dashboard_apps s.apps) sections s.info) + build_sections ~show ~run:(Some e.run) (to_dashboard_apps s.apps) sections s.info) in render dash ;; @@ -175,7 +175,14 @@ let import_view (e : env) ?(tools : Plugin.tool list = []) (path : string) let v = winget_show e.bio s.winget id in if v = "" then None else Some v in - Ok (render (build_sections ~show (to_dashboard_apps s.apps) r.sections s.info)) + Ok + (render + (build_sections + ~show + ~run:(Some e.run) + (to_dashboard_apps s.apps) + r.sections + s.info)) ;; (** [appendSelected]: persists items under a "Newly detected" section, @@ -284,7 +291,9 @@ let run_append (e : env) ?(tools : Plugin.tool list = []) (ids : string list) else ( let s = scan e ~override_path:"" ~extra:tools in let sections, _ = load_manifest e.fs Manifest.filename in - let dash = build_sections (to_dashboard_apps s.apps) sections s.info in + let dash = + build_sections ~run:(Some e.run) (to_dashboard_apps s.apps) sections s.info + in let items = new_items ~extra:true dash in if items = [] then [ " nothing new to append" ] @@ -303,7 +312,9 @@ let run_append (e : env) ?(tools : Plugin.tool list = []) (ids : string list) let run_append_new (e : env) ~(tools : Plugin.tool list) : string list = let s = scan e ~override_path:"" ~extra:tools in let sections, _ = load_manifest e.fs Manifest.filename in - let dash = build_sections (to_dashboard_apps s.apps) sections s.info in + let dash = + build_sections ~run:(Some e.run) (to_dashboard_apps s.apps) sections s.info + in let items = new_items dash in if items = [] then [ " no newly detected apps" ] diff --git a/lib/dashboard.ml b/lib/dashboard.ml index bd8cf3d..2ee4c06 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -31,6 +31,57 @@ let format_ver (it : item) : string = else " " ^ it.installed_version ;; +(** Candidate scan-names for a manifest value: the full lowercased value + plus a short form. Dotted/slashed ids ([Git.Git], [owner/tool]) + collapse to their last segment; URLs contribute the filename and + its stem (no query/fragment/extension). The PM scan or PATH probe + sees command names, not publisher prefixes or installer URLs. *) +let after_last seps s = + let idx = + let rec go i = + if i < 0 then None else if List.mem s.[i] seps then Some i else go (i - 1) + in + go (String.length s - 1) + in + match idx with + | None -> s + | Some i -> String.sub s (i + 1) (String.length s - i - 1) +;; + +let cut_at chars s = + let idx = + let rec go i = + if i >= String.length s + then None + else if List.mem s.[i] chars + then Some i + else go (i + 1) + in + go 0 + in + match idx with + | None -> s + | Some i -> String.sub s 0 i +;; + +let strip_ext s = + match String.rindex_opt s '.' with + | None -> s + | Some i -> String.sub s 0 i +;; + +let candidates (it : item) : string list = + let v = String.lowercase_ascii it.value in + let shorts = + match it.typ with + | Url -> + let file = cut_at [ '?'; '#' ] (after_last [ '/'; '\\' ] v) in + [ file; strip_ext file ] + | Winget | GitHub | Pm _ -> [ after_last [ '.'; '/'; '\\' ] v ] + in + List.sort_uniq String.compare (List.filter (fun s -> s <> "") (v :: shorts)) +;; + (** Merge the machine scan with manifest sections into dashboard sections: 1. "Pending updates": manifest items needing update, plus non-manifest installed apps that have an Available version. @@ -40,6 +91,7 @@ let format_ver (it : item) : string = leftover artifact, never real content). *) let build_sections ?(show : string -> string option = fun _ -> None) + ?(run : Proc.runner option = None) (apps : app list) (pkgs_sections : section list) (winget_info : Winget_parse.info Winget_parse.IdMap.t option) @@ -48,6 +100,20 @@ let build_sections let lower s = String.lowercase_ascii s in let scan_lookup : (string, app) Hashtbl.t = Hashtbl.create 64 in List.iter (fun a -> Hashtbl.replace scan_lookup (lower a.name) a) apps; + (* PATH probe: one spawn over every candidate of every manifest item. + Skipped entirely when no runner is passed (tests, offline use). *) + let on_path : (string, unit) Hashtbl.t = Hashtbl.create 64 in + (match run with + | None -> () + | Some run -> + let cands = + List.concat_map (fun sec -> List.concat_map candidates sec.items) pkgs_sections + in + List.iter (fun n -> Hashtbl.replace on_path n ()) (Proc.which run cands)); + let scan_hit (it : item) : app option = + List.find_map (fun c -> Hashtbl.find_opt scan_lookup c) (candidates it) + in + let path_hit (it : item) : bool = List.exists (Hashtbl.mem on_path) (candidates it) in let info_of name = match winget_info with | None -> None @@ -63,7 +129,7 @@ let build_sections (fun it -> let name = lower it.value in let it = - match Hashtbl.find_opt scan_lookup name with + match scan_hit it with | Some a -> { it with installed_version = a.version; status = Installed } | None -> it @@ -87,10 +153,10 @@ let build_sections let it = if it.status <> Installed && it.status <> NeedsUpdate then ( - match Hashtbl.find_opt scan_lookup name with + match scan_hit it with | Some a -> { it with installed_version = a.version; status = Installed } - | None -> it) + | None -> if path_hit it then { it with status = Installed } else it) else it in if it.typ = Winget && it.status = Installed @@ -138,8 +204,7 @@ let build_sections | None | Some None -> it | Some (Some ver) -> let it = { it with available_version = ver } in - let name = lower it.value in - (match Hashtbl.find_opt scan_lookup name with + (match scan_hit it with | Some a -> { it with installed_version = a.version diff --git a/lib/dashboard.mli b/lib/dashboard.mli index 066fc8b..b4c5f84 100644 --- a/lib/dashboard.mli +++ b/lib/dashboard.mli @@ -12,9 +12,13 @@ val format_ver : Manifest.item -> string (** Merge the machine scan with manifest sections into dashboard sections: "Pending updates", "Newly detected", then the manifest sections minus their updated items. [show] enriches NotFound winget items via - [winget show]. *) + [winget show]. [run] enables a single-spawn PATH probe: manifest + items whose candidate command is on PATH (but missed by every PM + scan) count as installed. Matching is candidate-based (full value, + basename, URL stem), not exact-id. *) val build_sections : ?show:(string -> string option) + -> ?run:Proc.runner option -> app list -> Manifest.section list -> Winget_parse.info Winget_parse.IdMap.t option diff --git a/lib/proc.ml b/lib/proc.ml index 187e0d2..722ad27 100644 --- a/lib/proc.ml +++ b/lib/proc.ml @@ -53,6 +53,63 @@ let par_map8 (f : 'a -> 'b) (xs : 'a list) : 'b list = List.concat_map Domain.join doms) ;; +(** PATH probe over candidate command names in a single spawn. Unix + runs one [sh] loop over [command -v] (a shell builtin, so this is + one fork); Win32 runs one [where] call, forcing exit 0 because + [where] fails when any name is missing. [where] prints paths, so + hits map back by lowercased basename without extension. *) +let quote_sh s = "'" ^ String.concat "'\\''" (String.split_on_char '\'' s) ^ "'" + +let win_basename line = + let base = + match String.rindex_opt line '\\' with + | Some i -> String.sub line (i + 1) (String.length line - i - 1) + | None -> + (match String.rindex_opt line '/' with + | Some i -> String.sub line (i + 1) (String.length line - i - 1) + | None -> line) + in + let stem = + match String.rindex_opt base '.' with + | Some i -> String.sub base 0 i + | None -> base + in + String.lowercase_ascii (String.trim stem) +;; + +let which ?(os = Sys.os_type) (run : runner) (names : string list) : string list = + let names = List.sort_uniq String.compare (List.filter (fun s -> s <> "") names) in + if names = [] + then [] + else if os = "Win32" || os = "Cygwin" + then ( + let args = List.map (fun n -> "\"" ^ n ^ "\"") names in + match run "cmd" [ "/c"; "where " ^ String.concat " " args ^ " 2>nul || exit 0" ] with + | None -> [] + | Some out -> + let hits = + List.filter_map + (fun line -> + let stem = win_basename (String.trim line) in + if List.mem stem names then Some stem else None) + (String.split_on_char '\n' out) + in + List.sort_uniq String.compare hits) + else ( + (* The loop exits nonzero when the last candidate misses; force + success because hits arrive on stdout (default_runner drops + non-zero output entirely). *) + let script = + "for c in " + ^ String.concat " " (List.map quote_sh names) + ^ "; do command -v \"$c\" >/dev/null 2>&1 && printf '%s\\n' \"$c\"; done; exit 0" + in + match run "sh" [ "-c"; script ] with + | None -> [] + | Some out -> + List.filter (fun line -> List.mem line names) (String.split_on_char '\n' out)) +;; + (** Memoized [winget list --verbose] fetcher with resetter. The inventory scan and the update check share one [winget list] invocation per 8s window, so refresh ticks never pop extra winget diff --git a/lib/proc.mli b/lib/proc.mli index 779169f..687a57e 100644 --- a/lib/proc.mli +++ b/lib/proc.mli @@ -14,3 +14,9 @@ val winget_list : runner -> (string -> string option) * (unit -> unit) (** Map [f] over [xs] on up to 8 domains, results in input order. Domain-safe as long as [f] touches no shared mutable state. *) val par_map8 : ('a -> 'b) -> 'a list -> 'b list + +(** PATH probe over candidate command names in a single spawn: a + [command -v] loop on Unix, one [where] call on Win32. Returns the + subset of [names] found on PATH. [os] defaults to [Sys.os_type] so + tests can exercise the Windows branch. *) +val which : ?os:string -> runner -> string list -> string list diff --git a/test/dune b/test/dune index df6ba36..369dc84 100644 --- a/test/dune +++ b/test/dune @@ -51,3 +51,7 @@ (test (name test_tui) (libraries devkit alcotest)) + +(test + (name test_proc) + (libraries devkit alcotest)) diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml index 9b7c5b6..40f48f0 100644 --- a/test/test_dashboard.ml +++ b/test/test_dashboard.ml @@ -154,6 +154,69 @@ let render_versions () = Alcotest.(check string) "neither" "" (Dashboard.format_ver (item Winget "x")) ;; +let basename_match () = + (* scan name "bar" matches manifest "Foo.Bar" via basename candidate, + carrying the scanned version. *) + let manifest = [ { name = "Tools"; items = [ item Winget "Foo.Bar" ] } ] in + let apps = [ Dashboard.{ name = "bar"; version = "1.0"; pm = "winget" } ] in + let sections = Dashboard.build_sections apps manifest None in + Alcotest.(check int) "one section" 1 (List.length sections); + let it = List.nth (List.nth sections 0).items 0 in + Alcotest.(check string) "version carried" "1.0" it.installed_version; + match it.status with + | Installed -> () + | _ -> Alcotest.fail "basename should match" +;; + +let url_stem_match () = + (* installer filename stem matches the scanned tool name. *) + let manifest = + [ { name = "Tools"; items = [ item Url "https://example.com/dl/widget-2.0.exe" ] } ] + in + let apps = [ Dashboard.{ name = "widget-2.0"; version = "2.0"; pm = "manual" } ] in + let sections = Dashboard.build_sections apps manifest None in + let it = List.nth (List.nth sections 0).items 0 in + match it.status with + | Installed -> () + | _ -> Alcotest.fail "url stem should match" +;; + +let path_probe_rescue () = + (* nothing in any PM scan, but the command is on PATH: Installed with + no version, in a single spawn. *) + let manifest = [ { name = "Tools"; items = [ item GitHub "owner/gizmo" ] } ] in + let calls = ref 0 in + let run prog args = + incr calls; + match prog, args with + | "sh", [ "-c"; _ ] -> Some "gizmo\n" + | _ -> None + in + let sections = Dashboard.build_sections ~run:(Some run) [] manifest None in + Alcotest.(check int) "single spawn" 1 !calls; + let it = List.nth (List.nth sections 0).items 0 in + Alcotest.(check string) "no version" "" it.installed_version; + match it.status with + | Installed -> () + | _ -> Alcotest.fail "PATH hit should be Installed" +;; + +let path_probe_miss () = + (* no scan hit, nothing on PATH: Manual stays Manual, probe still one spawn. *) + let manifest = [ { name = "Tools"; items = [ item GitHub "owner/gizmo" ] } ] in + let calls = ref 0 in + let run _ _ = + incr calls; + Some "" + in + let sections = Dashboard.build_sections ~run:(Some run) [] manifest None in + Alcotest.(check int) "single spawn" 1 !calls; + let it = List.nth (List.nth sections 0).items 0 in + match it.status with + | Manual -> () + | _ -> Alcotest.fail "PATH miss should stay Manual" +;; + let () = Alcotest.run "dashboard" @@ -162,6 +225,10 @@ let () = ; Alcotest.test_case "winget artifact dropped" `Quick winget_artifact_dropped ; Alcotest.test_case "show fallback" `Quick show_fallback ; Alcotest.test_case "show fallback many" `Quick show_fallback_many + ; Alcotest.test_case "basename match" `Quick basename_match + ; Alcotest.test_case "url stem match" `Quick url_stem_match + ; Alcotest.test_case "PATH probe rescue" `Quick path_probe_rescue + ; Alcotest.test_case "PATH probe miss" `Quick path_probe_miss ] ) ; ( "render" , [ Alcotest.test_case "exact fixture" `Quick render_fixture diff --git a/test/test_proc.ml b/test/test_proc.ml new file mode 100644 index 0000000..e90f977 --- /dev/null +++ b/test/test_proc.ml @@ -0,0 +1,68 @@ +(** Tests for {!Proc.which}: single-spawn PATH probe. *) + +open Devkit + +let unix_subset () = + let calls = ref 0 in + let script = ref "" in + let run prog args = + incr calls; + match prog, args with + | "sh", [ "-c"; s ] -> + script := s; + Some "git\nnode\n" + | _ -> None + in + let hits = Proc.which run [ "git"; "node"; "missing"; ""; "git" ] in + Alcotest.(check (list string)) "echo order" [ "git"; "node" ] hits; + Alcotest.(check int) "single spawn" 1 !calls; + (* default_runner drops non-zero output, so the loop must force exit 0. *) + Alcotest.(check bool) + "exit forced zero" + true + (let s = !script in + String.length s >= 6 && String.sub s (String.length s - 6) 6 = "exit 0") +;; + +let unix_none () = + let run _ _ = None in + Alcotest.(check (list string)) "runner miss" [] (Proc.which run [ "git" ]) +;; + +let unix_empty () = + let run _ _ = Alcotest.fail "must not spawn" in + Alcotest.(check (list string)) "no names" [] (Proc.which run []) +;; + +let win_basenames () = + let calls = ref 0 in + let script = ref "" in + let run prog args = + incr calls; + match prog, args with + | "cmd", [ "/c"; s ] -> + script := s; + Some "C:\\Program Files\\Git\\bin\\git.exe\r\nC:\\Tools\\ripgrep\\rg.exe\r\n" + | _ -> None + in + let hits = Proc.which ~os:"Win32" run [ "git"; "rg"; "missing" ] in + Alcotest.(check (list string)) "stem match" [ "git"; "rg" ] hits; + Alcotest.(check int) "single spawn" 1 !calls; + Alcotest.(check bool) + "exit forced zero" + true + (let s = !script in + String.length s >= 9 && String.sub s (String.length s - 9) 9 = "|| exit 0") +;; + +let () = + Alcotest.run + "proc" + [ ( "which" + , [ Alcotest.test_case "unix subset" `Quick unix_subset + ; Alcotest.test_case "unix miss" `Quick unix_none + ; Alcotest.test_case "unix empty" `Quick unix_empty + ; Alcotest.test_case "win basenames" `Quick win_basenames + ] ) + ] +;; From 8f853e5f433205c4f0530539c99717049766cb6a Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 18:49:38 +0000 Subject: [PATCH 16/34] Add TUI u key for on-demand npm/pipx/uv/cargo update checks New lib/update: one npm outdated -g --json spawn (exit forced 0, npm exits 1 when updates exist), PyPI lookups for pipx/uv, crates.io max_version for cargo (with User-Agent), registry calls capped at 15s and parallel on domains. Only Installed manifest Pm rows are queried. Tui.apply_updates marks hits NeedsUpdate with a summary message + log. --- bin/tui_front.ml | 14 ++++ lib/dune | 2 +- lib/tui.ml | 26 ++++++- lib/tui.mli | 1 + lib/update.ml | 146 ++++++++++++++++++++++++++++++++++++ lib/update.mli | 20 +++++ test/dune | 4 + test/test_update.ml | 177 ++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 388 insertions(+), 2 deletions(-) create mode 100644 lib/update.ml create mode 100644 lib/update.mli create mode 100644 test/test_update.ml diff --git a/bin/tui_front.ml b/bin/tui_front.ml index 6ae56a3..fb15ee7 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -36,6 +36,7 @@ let styled_of_line (i : int) : Tui.line -> LTerm_text.t = function type ev = | Quit | Enter + | Update | Action of Tui.action | Resized of LTerm_geom.size | Nothing @@ -44,6 +45,10 @@ let is_ctrl_q : Uchar.t -> bool = fun c -> Uchar.equal c (Uchar.of_char 'q') || Uchar.equal c (Uchar.of_char 'Q') ;; +let is_update_key : Uchar.t -> bool = + fun c -> Uchar.equal c (Uchar.of_char 'u') || Uchar.equal c (Uchar.of_char 'U') +;; + let is_nav : Uchar.t -> Tui.action option = fun c -> if Uchar.equal c (Uchar.of_char 'k') @@ -59,6 +64,7 @@ let classify : LTerm_event.t -> ev = function | LTerm_event.Key { code = LTerm_key.Escape; _ } -> Quit | LTerm_event.Key { code = LTerm_key.Char c; _ } when is_ctrl_q c -> Quit | LTerm_event.Key { code = LTerm_key.Enter; _ } -> Enter + | LTerm_event.Key { code = LTerm_key.Char c; _ } when is_update_key c -> Update | LTerm_event.Key { code = LTerm_key.Up; _ } -> Action Tui.Up | LTerm_event.Key { code = LTerm_key.Down; _ } -> Action Tui.Down | LTerm_event.Key { code = LTerm_key.Prev_page; _ } -> Action Tui.Page_up @@ -102,6 +108,13 @@ let press_enter (deps : Install.deps) (st : Tui.state) : Tui.state = let viewport (w : int) (h : int) : int * int = max 1 w, max 1 (h - 3) +(** [u]: check npm/pipx/uv/cargo updates for the Installed rows, then + mark the hits. Runs synchronously like installs (UI freezes). *) +let press_u (run : Proc.runner) (fetch : Fetch.fetch) (st : Tui.state) : Tui.state = + let items = List.map (fun e -> e.Tui.item) st.Tui.entries in + Tui.apply_updates st (Update.check_all ~run ~fetch items) +;; + (** Repaint in place, one addressed line at a time: no full-screen clear, so scrolling does not flash. Line count only changes on resize, which repaints from a cleared screen. *) @@ -156,6 +169,7 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = | Quit -> Lwt.return st | Nothing -> wait_loop st | Enter -> draw_loop (press_enter deps st) + | Update -> draw_loop (press_u env.App.run fetch st) | Action a -> draw_loop (Tui.step st a) | Resized g -> LTerm.clear_screen term diff --git a/lib/dune b/lib/dune index 36d7d64..f07d127 100644 --- a/lib/dune +++ b/lib/dune @@ -1,4 +1,4 @@ (library (name devkit) (libraries unix yojson digestif.c decompress.de sexplib re toml) - (modules manifest winget_parse dashboard proc inventory strutil fetch hash gh zipx bootstrap install app winget_json plugin tui)) + (modules manifest winget_parse dashboard proc inventory strutil fetch hash gh zipx bootstrap install app winget_json plugin tui update)) diff --git a/lib/tui.ml b/lib/tui.ml index 3e55ffe..b988b68 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -230,7 +230,7 @@ let lines (s : state) : line list = (min (s.cursor + 1) (List.length s.entries)) (List.length s.entries) in - [ Head "devkit — enter installs/updates, q quits" + [ Head "devkit — enter installs/updates, u checks updates, q quits" ; Head "[✓] installed · [!] update · [+] missing · [~] manual" ] @ body @@ -267,3 +267,27 @@ let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = let line = Printf.sprintf "%s: %s" value (Install.status_to_string o.Install.status) in clamp { s with entries; message = Some line; log = s.log @ [ line ] } ;; + +(** Mark rows with available updates: set available_version + + [NeedsUpdate] by value, with a summary message + log. An empty + result keeps every row and reports everything current. *) +let apply_updates (s : state) (updates : (string * string) list) : state = + let entries = + List.map + (fun e -> + match List.assoc_opt e.item.value updates with + | Some avail -> + { e with + item = { e.item with status = NeedsUpdate; available_version = avail } + } + | None -> e) + s.entries + in + let message = + match updates with + | [] -> "everything up to date" + | [ (v, _) ] -> Printf.sprintf "1 update available: %s" v + | _ -> Printf.sprintf "%d updates available" (List.length updates) + in + clamp { s with entries; message = Some message; log = s.log @ [ message ] } +;; diff --git a/lib/tui.mli b/lib/tui.mli index f51ea18..32faa9d 100644 --- a/lib/tui.mli +++ b/lib/tui.mli @@ -67,3 +67,4 @@ val lines : state -> line list val render_line : line -> string val frame : state -> string list val apply_outcome : state -> string -> Install.outcome -> state +val apply_updates : state -> (string * string) list -> state diff --git a/lib/update.ml b/lib/update.ml new file mode 100644 index 0000000..3234eec --- /dev/null +++ b/lib/update.ml @@ -0,0 +1,146 @@ +(** On-demand update checks for non-winget package managers. + + Only manifest items drive checks, so cost stays bounded; registry + lookups run in parallel on up to 8 domains. Results are [(value, + available)] pairs the TUI marks [NeedsUpdate]. Version comparison + is dumb string inequality, like the winget path — except npm, where + [outdated] itself decides by semver. *) + +open Manifest + +(** npm: one [outdated -g --json] spawn covers every global. npm exits + 1 when updates exist (fatal to our runner, which drops non-zero + output), so the shell forces exit 0. [os] pins the shell choice + for tests; defaults to [Sys.os_type]. *) +let npm_updates ?(os = Sys.os_type) (run : Proc.runner) : (string * string) list = + let prog, args = + if os = "Win32" || os = "Cygwin" + then "cmd", [ "/c"; "npm outdated -g --json || exit 0" ] + else "sh", [ "-c"; "npm outdated -g --json || true" ] + in + let parse out = + try + match Yojson.Safe.from_string out with + | `Assoc pkgs -> + List.filter_map + (fun (name, js) -> + match js with + | `Assoc fields -> + (match List.assoc_opt "latest" fields with + | Some (`String latest) when latest <> "" -> Some (name, latest) + | _ -> None) + | _ -> None) + pkgs + | _ -> [] + with + | _ -> [] + in + match run prog args with + | None -> [] + | Some out -> parse out +;; + +let parse_json (body : string) : Yojson.Safe.t option = + try Some (Yojson.Safe.from_string body) with + | _ -> None +;; + +let pypi_latest (js : Yojson.Safe.t) : string option = + match js with + | `Assoc top -> + (match List.assoc_opt "info" top with + | Some (`Assoc info) -> + (match List.assoc_opt "version" info with + | Some (`String v) -> Some v + | _ -> None) + | _ -> None) + | _ -> None +;; + +let cargo_latest (js : Yojson.Safe.t) : string option = + match js with + | `Assoc top -> + (match List.assoc_opt "crate" top with + | Some (`Assoc crate) -> + (match List.assoc_opt "max_version" crate with + | Some (`String v) -> Some v + | _ -> None) + | _ -> None) + | _ -> None +;; + +(** One registry URL per package, checked in parallel; a stale + installed version (or any fetch/parse failure) simply yields no + update for that package. *) +let registry_updates + (fetch : Fetch.fetch) + (headers : (string * string) list) + (url_of : string -> string) + (latest_of : Yojson.Safe.t -> string option) + (versions : (string * string) list) + : (string * string) list + = + let one (name, installed) = + if name = "" || installed = "" + then None + else ( + (* 15s cap like other API calls: without it a dead network hangs + the TUI until curl gives up on its own. *) + match fetch ~timeout_s:15 (url_of name) headers with + | Error _ -> None + | Ok body -> + (match parse_json body with + | None -> None + | Some js -> + (match latest_of js with + | Some v when v <> "" && v <> installed -> Some (name, v) + | _ -> None))) + in + List.filter_map Fun.id (Proc.par_map8 one versions) +;; + +let pypi_updates (fetch : Fetch.fetch) (versions : (string * string) list) + : (string * string) list + = + registry_updates + fetch + [] + (fun n -> Printf.sprintf "https://pypi.org/pypi/%s/json" n) + pypi_latest + versions +;; + +let cargo_updates (fetch : Fetch.fetch) (versions : (string * string) list) + : (string * string) list + = + registry_updates + fetch + [ "User-Agent", "devkit (https://github.com/anomalyco/devkit)" ] + (fun n -> Printf.sprintf "https://crates.io/api/v1/crates/%s" n) + cargo_latest + versions +;; + +(** Group Installed Pm items by manager: npm via [outdated], pipx and + uv via PyPI, cargo via crates.io. Anything else (winget, links, + unknown Pms, non-Installed rows) is ignored. *) +let check_all ~(run : Proc.runner) ~(fetch : Fetch.fetch) (items : item list) + : (string * string) list + = + let installed = + List.filter_map + (fun it -> + match it.typ with + | Pm pm when it.status = Installed -> Some (pm, it.value, it.installed_version) + | _ -> None) + items + in + let has pm = List.exists (fun (p, _, _) -> p = pm) installed in + let of_pm pm = + List.filter_map (fun (p, v, i) -> if p = pm then Some (v, i) else None) installed + in + let npm = if has "npm" then npm_updates run else [] in + let pypi = pypi_updates fetch (of_pm "pipx" @ of_pm "uv") in + let cargo = cargo_updates fetch (of_pm "cargo") in + List.sort_uniq compare (npm @ pypi @ cargo) +;; diff --git a/lib/update.mli b/lib/update.mli new file mode 100644 index 0000000..2aece78 --- /dev/null +++ b/lib/update.mli @@ -0,0 +1,20 @@ +(** On-demand update checks for non-winget package managers. *) + +(** npm: one [outdated -g --json] spawn; entries are already outdated + by npm's semver compare, so every [latest] is an update. *) +val npm_updates : ?os:string -> Proc.runner -> (string * string) list + +(** PyPI latest per package (pipx and uv tools are PyPI names); + [None]/unparseable/current yields no update for that package. *) +val pypi_updates : Fetch.fetch -> (string * string) list -> (string * string) list + +(** crates.io max_version per package, same skip rules as PyPI. *) +val cargo_updates : Fetch.fetch -> (string * string) list -> (string * string) list + +(** Group Installed Pm items by manager and check each group; returns + [(value, available)] sorted and deduplicated. *) +val check_all + : run:Proc.runner + -> fetch:Fetch.fetch + -> Manifest.item list + -> (string * string) list diff --git a/test/dune b/test/dune index 369dc84..26de7b7 100644 --- a/test/dune +++ b/test/dune @@ -52,6 +52,10 @@ (name test_tui) (libraries devkit alcotest)) +(test + (name test_update) + (libraries devkit alcotest)) + (test (name test_proc) (libraries devkit alcotest)) diff --git a/test/test_update.ml b/test/test_update.ml new file mode 100644 index 0000000..5404dc5 --- /dev/null +++ b/test/test_update.ml @@ -0,0 +1,177 @@ +(** Tests for {!Update}: backend parsing/routing, plus {!Tui.apply_updates}. *) + +open Devkit +open Manifest + +let npm_json = + {|{"typescript":{"current":"5.3.3","wanted":"5.3.3","latest":"5.9.2","dependent":"global","location":"global"}}|} +;; + +let npm_parses_outdated () = + let run _ _ = Some npm_json in + Alcotest.(check (list (pair string string))) + "one update" + [ "typescript", "5.9.2" ] + (Update.npm_updates run) +;; + +let npm_shell_by_os () = + let calls = ref [] in + let run prog args = + calls := (prog, args) :: !calls; + Some "{}" + in + ignore (Update.npm_updates ~os:"Win32" run); + Alcotest.(check (pair string (list string))) + "cmd with exit guard" + ("cmd", [ "/c"; "npm outdated -g --json || exit 0" ]) + (List.hd !calls); + calls := []; + ignore (Update.npm_updates ~os:"Linux" run); + Alcotest.(check (pair string (list string))) + "sh with true guard" + ("sh", [ "-c"; "npm outdated -g --json || true" ]) + (List.hd !calls) +;; + +let npm_failures_empty () = + Alcotest.(check (list (pair string string))) + "missing npm" + [] + (Update.npm_updates (fun _ _ -> None)); + Alcotest.(check (list (pair string string))) + "bad json" + [] + (Update.npm_updates (fun _ _ -> Some "not json")) +;; + +let pypi_json v = Printf.sprintf {|{"info":{"version":%S}}|} v + +let pypi_newer () = + let fetch ?timeout_s url _ = + Alcotest.(check (option int)) "15s timeout" (Some 15) timeout_s; + Ok (pypi_json "24.0") + in + Alcotest.(check (list (pair string string))) + "update" + [ "black", "24.0" ] + (Update.pypi_updates fetch [ "black", "23.1.0" ]) +;; + +let pypi_current_and_missing () = + let fetch ?timeout_s:_ url _ = + if url = "https://pypi.org/pypi/black/json" + then Ok (pypi_json "23.1.0") + else Error "404" + in + Alcotest.(check (list (pair string string))) + "none" + [] + (Update.pypi_updates fetch [ "black", "23.1.0"; "ghost", "1.0"; "noversion", "" ]) +;; + +let cargo_newer_and_ua () = + let calls = ref [] in + let fetch ?timeout_s:_ url headers = + calls := (url, headers) :: !calls; + Ok {|{"crate":{"max_version":"1.75.0"}}|} + in + Alcotest.(check (list (pair string string))) + "update" + [ "ripgrep", "1.75.0" ] + (Update.cargo_updates fetch [ "ripgrep", "1.70.0" ]); + Alcotest.(check bool) + "user-agent sent" + true + (List.exists (fun (h, _) -> h = "User-Agent") (snd (List.hd !calls))) +;; + +let inst pm value version = + { (make_item (Pm pm) value) with installed_version = version; status = Installed } +;; + +let check_all_routes () = + let run_calls = ref 0 in + let run _ _ = + incr run_calls; + Some "{}" + in + let fetch_calls = ref [] in + let fetch ?timeout_s:_ url headers = + fetch_calls := (url, headers) :: !fetch_calls; + if String.length url >= 19 && String.sub url 8 11 = "crates.io/a" + then Ok {|{"crate":{"max_version":"9.9"}}|} + else Ok (pypi_json "9.9") + in + let items = + [ inst "npm" "typescript" "5.3.3" + ; inst "pipx" "black" "1.0" + ; inst "uv" "ruff" "1.0" + ; inst "cargo" "ripgrep" "1.0" + ; { (make_item Winget "Git.Git") with status = Installed } + ; { (make_item (Pm "npm") "missing") with status = NotFound } + ; { (make_item GitHub "o/t") with status = Manual } + ] + in + let got = Update.check_all ~run ~fetch items in + Alcotest.(check int) "npm once" 1 !run_calls; + Alcotest.(check int) "three registry hits" 3 (List.length !fetch_calls); + Alcotest.(check (list (pair string string))) + "updates" + [ "black", "9.9"; "ripgrep", "9.9"; "ruff", "9.9" ] + got +;; + +let apply_updates_marks () = + let st = + Tui.make + [ { name = "Setup"; items = [ inst "npm" "typescript" "5.3.3" ] } ] + ~height:10 + ~width:80 + in + let st = Tui.apply_updates st [ "typescript", "5.9.2" ] in + let e = List.hd st.Tui.entries in + (match e.Tui.item.status with + | NeedsUpdate -> () + | _ -> Alcotest.fail "should need update"); + Alcotest.(check string) "available set" "5.9.2" e.Tui.item.available_version; + Alcotest.(check (option string)) + "message" + (Some "1 update available: typescript") + st.Tui.message +;; + +let apply_updates_empty () = + let st = + Tui.make + [ { name = "Setup"; items = [ inst "npm" "typescript" "5.3.3" ] } ] + ~height:10 + ~width:80 + in + let st = Tui.apply_updates st [] in + (match (List.hd st.Tui.entries).Tui.item.status with + | Installed -> () + | _ -> Alcotest.fail "should stay installed"); + Alcotest.(check (option string)) "message" (Some "everything up to date") st.Tui.message +;; + +let () = + Alcotest.run + "update" + [ ( "npm" + , [ Alcotest.test_case "parses outdated" `Quick npm_parses_outdated + ; Alcotest.test_case "shell by os" `Quick npm_shell_by_os + ; Alcotest.test_case "failures empty" `Quick npm_failures_empty + ] ) + ; ( "registry" + , [ Alcotest.test_case "pypi newer" `Quick pypi_newer + ; Alcotest.test_case "pypi current/missing" `Quick pypi_current_and_missing + ; Alcotest.test_case "cargo newer + UA" `Quick cargo_newer_and_ua + ; Alcotest.test_case "check_all routes" `Quick check_all_routes + ] ) + ; ( "tui" + , [ Alcotest.test_case "apply marks" `Quick apply_updates_marks + ; Alcotest.test_case "apply empty" `Quick apply_updates_empty + ] ) + ] +;; From d99df8e09b000717f426346f8327070388abd0c1 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 18:54:12 +0000 Subject: [PATCH 17/34] Add export --only/--except per-PM filter run_export takes ?only/?except: sections, winget JSON sibling, counts and empty-scan message all respect the filter. CLI gains --only/--except (comma-separated via Arg.list). README + CHANGES updated. --- README.md | 5 ++++- bin/main.ml | 22 ++++++++++++++++++---- lib/app.ml | 21 +++++++++++++++------ lib/app.mli | 9 ++++++++- test/test_app.ml | 27 +++++++++++++++++++++++++++ 5 files changed, 72 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index d209acc..6ad0267 100644 --- a/README.md +++ b/README.md @@ -35,12 +35,15 @@ devkit # dashboard: manifest status, or full scan devkit import FILE # preview a manifest against this machine devkit add ID... # append installed apps to devkit.toml devkit append [--new] # append newly-detected apps (or given ids) -devkit export [-o FILE] # write devkit.toml + winget import-ready JSON +devkit export [-o FILE] [--only PM,...] [--except PM,...] + # write devkit.toml + winget import-ready JSON ``` `export` writes two files: the TOML manifest (`devkit.toml`) and a `winget import -i`-compatible JSON sibling (schema 2.0.0, installed versions pinned; skipped when no winget apps are installed). +`--only npm,uv` / `--except winget` restrict both files to the given +package managers. ## Custom package managers (`tools.sexp`) diff --git a/bin/main.ml b/bin/main.ml index f34b3ad..e562111 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -128,14 +128,28 @@ let export_cmd = & opt string Manifest.filename & info [ "o"; "output" ] ~docv:"FILE" ~doc:"output file path") in - let run output = - print_lines (App.run_export ~tools:(load_tools ()) (make_env ()) output) + let only = + Cmdliner.Arg.( + value + & opt (list string) [] + & info [ "only" ] ~docv:"PM,..." ~doc:"export only these package managers") + in + let except = + Cmdliner.Arg.( + value + & opt (list string) [] + & info [ "except" ] ~docv:"PM,..." ~doc:"skip these package managers") + in + let run output only except = + print_lines (App.run_export ~tools:(load_tools ()) (make_env ()) ~only ~except output) in Cmdliner.Cmd.v (Cmdliner.Cmd.info "export" - ~doc:"Scan PC and write all installed software to devkit.toml") - Cmdliner.Term.(const run $ output) + ~doc: + "Scan PC and write installed software to devkit.toml (filter with \ + --only/--except)") + Cmdliner.Term.(const run $ output $ only $ except) ;; let () = diff --git a/lib/app.ml b/lib/app.ml index 90a2a7d..cee3f32 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -345,15 +345,24 @@ let order_for (tools : Plugin.tool list) : string list = (List.map (fun (t : Plugin.tool) -> t.name) tools) ;; -let run_export (e : env) ?(tools : Plugin.tool list = []) (output : string) : string list = +let run_export + (e : env) + ?(tools : Plugin.tool list = []) + ?(only : string list = []) + ?(except : string list = []) + (output : string) + : string list + = let s = scan e ~override_path:"" ~extra:tools in - if s.apps = [] + let keep pm = (only = [] || List.mem pm only) && not (List.mem pm except) in + let apps = List.filter (fun (a : app) -> keep a.pm) s.apps in + if apps = [] then [ " no installed software found" ] else ( let sections = List.filter_map (fun pm -> - let apps = List.filter (fun (a : app) -> a.pm = pm) s.apps in + let apps = List.filter (fun (a : app) -> a.pm = pm) apps in match apps with | [] -> None | _ -> @@ -373,14 +382,14 @@ let run_export (e : env) ?(tools : Plugin.tool list = []) (output : string) : st | Error e -> [ " error: " ^ e ] | Ok () -> let json_path = json_sibling output in - let winget_apps = List.filter (fun (a : app) -> a.pm = "winget") s.apps in - let base = Printf.sprintf "wrote %s (%d apps)" output (List.length s.apps) in + let winget_apps = List.filter (fun (a : app) -> a.pm = "winget") apps in + let base = Printf.sprintf "wrote %s (%d apps)" output (List.length apps) in (* An empty Packages list violates the schema (minItems 1) and winget import would reject it, so the file is skipped instead. *) if winget_apps = [] then [ base; " no winget apps, json skipped" ] else ( - match e.fs.write_file json_path (Winget_json.to_string s.apps) with + match e.fs.write_file json_path (Winget_json.to_string apps) with | Error e -> [ base; " winget json skipped: " ^ e ] | Ok () -> [ base diff --git a/lib/app.mli b/lib/app.mli index ee89d16..7ba48e5 100644 --- a/lib/app.mli +++ b/lib/app.mli @@ -34,4 +34,11 @@ val run_append : env -> ?tools:Plugin.tool list -> string list -> string list val run_append_new : env -> tools:Plugin.tool list -> string list val json_sibling : string -> string val order_for : Plugin.tool list -> string list -val run_export : env -> ?tools:Plugin.tool list -> string -> string list + +val run_export + : env + -> ?tools:Plugin.tool list + -> ?only:string list + -> ?except:string list + -> string + -> string list diff --git a/test/test_app.ml b/test/test_app.ml index 498fcfc..10ddbac 100644 --- a/test/test_app.ml +++ b/test/test_app.ml @@ -201,6 +201,31 @@ let export_no_winget () = Alcotest.(check bool) "no json file" false (Hashtbl.mem files "out.json") ;; +let export_only () = + let files = Hashtbl.create 1 in + let e = + { (env files) with + run = (fun prog _ -> if prog = "npm" then Some "x@1.0.0\n" else None) + } + in + let msgs = App.run_export e ~only:[ "npm" ] "out.toml" in + Alcotest.(check (list string)) + "messages" + [ "wrote out.toml (1 apps)"; " no winget apps, json skipped" ] + msgs; + let r = Devkit.Manifest.parse (Hashtbl.find files "out.toml") in + let secs = List.map (fun (sec : Devkit.Manifest.section) -> sec.name) r.sections in + Alcotest.(check (list string)) "only npm section" [ "npm" ] secs; + Alcotest.(check bool) "no json file" false (Hashtbl.mem files "out.json") +;; + +let export_except () = + let files = Hashtbl.create 1 in + let msgs = App.run_export (env files) ~except:[ "winget" ] "out.toml" in + Alcotest.(check (list string)) "filtered out" [ " no installed software found" ] msgs; + Alcotest.(check bool) "no toml file" false (Hashtbl.mem files "out.toml") +;; + let new_items () = let mk status = { Manifest.typ = Manifest.Winget @@ -259,6 +284,8 @@ let () = ; Alcotest.test_case "export" `Quick export ; Alcotest.test_case "export_empty" `Quick export_empty ; Alcotest.test_case "export_no_winget" `Quick export_no_winget + ; Alcotest.test_case "export_only" `Quick export_only + ; Alcotest.test_case "export_except" `Quick export_except ; Alcotest.test_case "show" `Quick show ; Alcotest.test_case "default" `Quick default ] ) From 10c6b18ebaaf874609184ca68eb4184f9aa5858e Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 19:01:31 +0000 Subject: [PATCH 18/34] Ignore local-only files (devkit.toml, AGENTS.md, CHANGES.md) Personal machine inventory and operator notes must never be committed. --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 9a93bba..1c976cd 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,7 @@ _build/ _opam/ *.install +# Local-only: personal machine inventory + operator notes, never commit. +/devkit.toml +/AGENTS.md +/CHANGES.md From a2d85d182b10a01b92a7716d5b89bbe21aba6ff5 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 20:39:04 +0000 Subject: [PATCH 19/34] Diagnose silent Windows test deaths in CI Four suites die with no output under dune runtest on Windows. On failure, rerun those binaries directly via dune exec and print exit codes, to tell a sandbox failure apart from an exe loader crash. --- .github/workflows/ci.yml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9d0984a..5d2da64 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -28,6 +28,17 @@ jobs: - name: Test run: opam exec -- dune runtest --force + - name: Diagnose test failures + if: failure() + shell: bash + run: | + opam exec -- dune --version + opam exec -- dune build + for t in dashboard bootstrap install proc update; do + echo "== test_$t ==" + opam exec -- dune exec test/test_$t.exe && echo PASS || echo "FAIL exit=$?" + done + - name: Upload windows exe if: matrix.os == 'windows-latest' uses: actions/upload-artifact@v4 From 3e3d18b81b88e4fa616bd702cd22006594da75f4 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 20:56:32 +0000 Subject: [PATCH 20/34] Make tests pass on Windows via os injection and sep-aware paths Proc.which, build_sections and real_open_browser take after Sys.os_type when tests omit ~os, so Windows CI took the Win32 branch against Unix fakes. Thread ?os through build_sections and real_open_browser and pin ~os in the Unix tests. Bootstrap path tests now build expectations with Filename.concat instead of hardcoded slashes. --- lib/dashboard.ml | 3 ++- lib/dashboard.mli | 4 ++- lib/install.ml | 6 +++-- lib/install.mli | 2 +- test/test_bootstrap.ml | 58 ++++++++++++++++++++++++------------------ test/test_dashboard.ml | 4 +-- test/test_install.ml | 7 +++-- test/test_proc.ml | 6 ++--- 8 files changed, 53 insertions(+), 37 deletions(-) diff --git a/lib/dashboard.ml b/lib/dashboard.ml index 2ee4c06..cbbb4d6 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -92,6 +92,7 @@ let candidates (it : item) : string list = let build_sections ?(show : string -> string option = fun _ -> None) ?(run : Proc.runner option = None) + ?(os : string = Sys.os_type) (apps : app list) (pkgs_sections : section list) (winget_info : Winget_parse.info Winget_parse.IdMap.t option) @@ -109,7 +110,7 @@ let build_sections let cands = List.concat_map (fun sec -> List.concat_map candidates sec.items) pkgs_sections in - List.iter (fun n -> Hashtbl.replace on_path n ()) (Proc.which run cands)); + List.iter (fun n -> Hashtbl.replace on_path n ()) (Proc.which ~os run cands)); let scan_hit (it : item) : app option = List.find_map (fun c -> Hashtbl.find_opt scan_lookup c) (candidates it) in diff --git a/lib/dashboard.mli b/lib/dashboard.mli index b4c5f84..32eb3fd 100644 --- a/lib/dashboard.mli +++ b/lib/dashboard.mli @@ -14,11 +14,13 @@ val format_ver : Manifest.item -> string their updated items. [show] enriches NotFound winget items via [winget show]. [run] enables a single-spawn PATH probe: manifest items whose candidate command is on PATH (but missed by every PM - scan) count as installed. Matching is candidate-based (full value, + scan) count as installed. [os] selects the probe shell (default: + [Sys.os_type]) so tests stay platform-independent. Matching is candidate-based (full value, basename, URL stem), not exact-id. *) val build_sections : ?show:(string -> string option) -> ?run:Proc.runner option + -> ?os:string -> app list -> Manifest.section list -> Winget_parse.info Winget_parse.IdMap.t option diff --git a/lib/install.ml b/lib/install.ml index fec6dc5..92fba0e 100644 --- a/lib/install.ml +++ b/lib/install.ml @@ -71,9 +71,11 @@ let run_installer (spawn : Bootstrap.spawn) (path : string) : (unit, string) res (** Open [url] in the default browser: [cmd /c start] on Windows, [open] on macOS, [xdg-open] elsewhere. macOS is detected with [uname -s] through [spawn], keeping the function testable. *) -let real_open_browser (spawn : Bootstrap.spawn) (url : string) : (unit, string) result = +let real_open_browser ?(os = Sys.os_type) (spawn : Bootstrap.spawn) (url : string) + : (unit, string) result + = let prog, args = - if Sys.win32 + if os = "Win32" then "cmd", [ "/c"; "start"; ""; url ] else ( let uname, ok = spawn "uname" [ "-s" ] in diff --git a/lib/install.mli b/lib/install.mli index a29bcb7..440f4a0 100644 --- a/lib/install.mli +++ b/lib/install.mli @@ -29,6 +29,6 @@ type deps = switches, anything else refused. *) val run_installer : Bootstrap.spawn -> string -> (unit, string) result -val real_open_browser : Bootstrap.spawn -> string -> (unit, string) result +val real_open_browser : ?os:string -> Bootstrap.spawn -> string -> (unit, string) result val install : deps -> string -> string -> bool -> outcome val real_deps : Fetch.fetch -> winget_override:string -> unit -> deps diff --git a/test/test_bootstrap.ml b/test/test_bootstrap.ml index fef71bd..63cfbb2 100644 --- a/test/test_bootstrap.ml +++ b/test/test_bootstrap.ml @@ -32,33 +32,36 @@ let base_io (* --- find_portable --- *) let test_portable_hit () = - let is_file = fun p -> p = "/a/winget.exe" in - Alcotest.(check string) "hit" "/a/winget.exe" (Bootstrap.find_portable ~is_file "/a") + let want = Filename.concat "/a" "winget.exe" in + let is_file = fun p -> p = want in + Alcotest.(check string) "hit" want (Bootstrap.find_portable ~is_file "/a") ;; let test_portable_prefers_winget_exe () = - let is_file = fun p -> p = "/a/winget.exe" || p = "/a/AppInstaller.exe" in - Alcotest.(check string) "order" "/a/winget.exe" (Bootstrap.find_portable ~is_file "/a") + let want = Filename.concat "/a" "winget.exe" in + let other = Filename.concat "/a" "AppInstaller.exe" in + let is_file = fun p -> p = want || p = other in + Alcotest.(check string) "order" want (Bootstrap.find_portable ~is_file "/a") ;; let test_portable_subfolder () = - let is_file = fun p -> p = "/a/build/winget/AppInstaller.exe" in - Alcotest.(check string) - "subfolder" - "/a/build/winget/AppInstaller.exe" - (Bootstrap.find_portable ~is_file "/a") + let want = + Filename.concat + (Filename.concat (Filename.concat "/a" "build") "winget") + "AppInstaller.exe" + in + let is_file = fun p -> p = want in + Alcotest.(check string) "subfolder" want (Bootstrap.find_portable ~is_file "/a") ;; let test_portable_walks_up () = - let is_file = fun p -> p = "/a/winget/winget.exe" in - Alcotest.(check string) - "walk-up" - "/a/winget/winget.exe" - (Bootstrap.find_portable ~is_file "/a/b/c") + let want = Filename.concat (Filename.concat "/a" "winget") "winget.exe" in + let is_file = fun p -> p = want in + Alcotest.(check string) "walk-up" want (Bootstrap.find_portable ~is_file "/a/b/c") ;; let test_portable_stops_at_4 () = - let is_file = fun p -> p = "/a/winget.exe" in + let is_file = fun p -> p = Filename.concat "/a" "winget.exe" in Alcotest.(check string) "beyond 4 levels" "" @@ -72,10 +75,10 @@ let test_on_path () = | "PATH" -> Some "/x;/y:/z" | _ -> None in - let is_file = fun p -> p = "/y/winget" in + let is_file = fun p -> p = Filename.concat "/y" "winget" in Alcotest.(check string) "both separators" - "/y/winget" + (Filename.concat "/y" "winget") (Bootstrap.find_on_path ~getenv ~is_file "winget") ;; @@ -207,16 +210,17 @@ let test_sizes () = let test_resolve_cwd_wins_no_spawn () = let spawns = ref 0 in + let want = Filename.concat (Filename.dirname "/proj/sub") "winget.exe" in let io = base_io - ~is_file:(fun p -> p = "/proj/winget.exe") + ~is_file:(fun p -> p = want) ~spawn:(fun _ _ -> incr spawns; "", false) ~cwd:(Ok "/proj/sub") () in - Alcotest.(check string) "cwd portable" "/proj/winget.exe" (Bootstrap.resolve io); + Alcotest.(check string) "cwd portable" want (Bootstrap.resolve io); Alcotest.(check int) "no probes" 0 !spawns ;; @@ -226,12 +230,15 @@ let test_resolve_path_fallback () = ~getenv:(function | "PATH" -> Some "/bin" | _ -> None) - ~is_file:(fun p -> p = "/bin/winget") + ~is_file:(fun p -> p = Filename.concat "/bin" "winget") ~cwd:(Ok "/proj") ~exe:(Ok "/opt/app") () in - Alcotest.(check string) "PATH hit" "/bin/winget" (Bootstrap.resolve io) + Alcotest.(check string) + "PATH hit" + (Filename.concat "/bin" "winget") + (Bootstrap.resolve io) ;; let test_resolve_miss () = @@ -254,10 +261,11 @@ let test_ensure_override_blind () = let test_ensure_resolved () = let get, _ = fresh_cache () in - let io = base_io ~is_file:(fun p -> p = "/p/winget.exe") ~cwd:(Ok "/p") () in + let want = Filename.concat "/p" "winget.exe" in + let io = base_io ~is_file:(fun p -> p = want) ~cwd:(Ok "/p") () in match Bootstrap.ensure_full ~override_path:"" ~resolve_path:get io with | Error e -> Alcotest.fail e - | Ok p -> Alcotest.(check string) "resolved" "/p/winget.exe" p + | Ok p -> Alcotest.(check string) "resolved" want p ;; let test_ensure_download_cert_advice () = @@ -411,7 +419,7 @@ let test_cache_memoizes () = ~getenv:(function | "PATH" -> Some "/bin" | _ -> None) - ~is_file:(fun p -> p = "/bin/winget") + ~is_file:(fun p -> p = Filename.concat "/bin" "winget") ~cwd:(Ok "/proj") ~exe:(Ok "/opt/app") () @@ -423,7 +431,7 @@ let test_cache_memoizes () = call returns the cached value without re-resolving, even after the filesystem changes. *) let io2 = { io with Bootstrap.is_file = (fun _ -> false) } in - Alcotest.(check string) "memoized" "/bin/winget" (get io2); + Alcotest.(check string) "memoized" (Filename.concat "/bin" "winget") (get io2); reset (); Alcotest.(check string) "reset clears" "" (get io2) ;; diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml index 40f48f0..596ce52 100644 --- a/test/test_dashboard.ml +++ b/test/test_dashboard.ml @@ -192,7 +192,7 @@ let path_probe_rescue () = | "sh", [ "-c"; _ ] -> Some "gizmo\n" | _ -> None in - let sections = Dashboard.build_sections ~run:(Some run) [] manifest None in + let sections = Dashboard.build_sections ~os:"Unix" ~run:(Some run) [] manifest None in Alcotest.(check int) "single spawn" 1 !calls; let it = List.nth (List.nth sections 0).items 0 in Alcotest.(check string) "no version" "" it.installed_version; @@ -209,7 +209,7 @@ let path_probe_miss () = incr calls; Some "" in - let sections = Dashboard.build_sections ~run:(Some run) [] manifest None in + let sections = Dashboard.build_sections ~os:"Unix" ~run:(Some run) [] manifest None in Alcotest.(check int) "single spawn" 1 !calls; let it = List.nth (List.nth sections 0).items 0 in match it.status with diff --git a/test/test_install.ml b/test/test_install.ml index 613312e..609c765 100644 --- a/test/test_install.ml +++ b/test/test_install.ml @@ -304,7 +304,10 @@ let test_browser_linux () = seen := prog, args; "", true) in - Alcotest.(check bool) "ok" true (Install.real_open_browser spawn "https://x" = Ok ()); + Alcotest.(check bool) + "ok" + true + (Install.real_open_browser ~os:"Unix" spawn "https://x" = Ok ()); Alcotest.(check string) "xdg-open" "xdg-open" (fst !seen) ;; @@ -318,7 +321,7 @@ let test_browser_darwin () = ignore args; "", true) in - ignore (Install.real_open_browser spawn "https://x"); + ignore (Install.real_open_browser ~os:"Unix" spawn "https://x"); Alcotest.(check string) "open" "open" !seen ;; diff --git a/test/test_proc.ml b/test/test_proc.ml index e90f977..a43d604 100644 --- a/test/test_proc.ml +++ b/test/test_proc.ml @@ -13,7 +13,7 @@ let unix_subset () = Some "git\nnode\n" | _ -> None in - let hits = Proc.which run [ "git"; "node"; "missing"; ""; "git" ] in + let hits = Proc.which ~os:"Unix" run [ "git"; "node"; "missing"; ""; "git" ] in Alcotest.(check (list string)) "echo order" [ "git"; "node" ] hits; Alcotest.(check int) "single spawn" 1 !calls; (* default_runner drops non-zero output, so the loop must force exit 0. *) @@ -26,12 +26,12 @@ let unix_subset () = let unix_none () = let run _ _ = None in - Alcotest.(check (list string)) "runner miss" [] (Proc.which run [ "git" ]) + Alcotest.(check (list string)) "runner miss" [] (Proc.which ~os:"Unix" run [ "git" ]) ;; let unix_empty () = let run _ _ = Alcotest.fail "must not spawn" in - Alcotest.(check (list string)) "no names" [] (Proc.which run []) + Alcotest.(check (list string)) "no names" [] (Proc.which ~os:"Unix" run []) ;; let win_basenames () = From e6d816d9b1fbe62643999f5583035b8cb365276f Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 21:01:40 +0000 Subject: [PATCH 21/34] Point repo URLs at proxylat/devkit and add MIT LICENSE Source stanza, generated opam URLs and crates.io User-Agent. LICENSE matches the declared MIT license stanza. --- LICENSE | 21 +++++++++++++++++++++ devkit.opam | 6 +++--- dune-project | 2 +- lib/update.ml | 2 +- 4 files changed, 26 insertions(+), 5 deletions(-) create mode 100644 LICENSE diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..9b31bb2 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Proxy Works + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/devkit.opam b/devkit.opam index 81950e9..0e9a9ac 100644 --- a/devkit.opam +++ b/devkit.opam @@ -6,8 +6,8 @@ description: maintainer: ["devkit contributors"] authors: ["devkit contributors"] license: "MIT" -homepage: "https://github.com/anomalyco/devkit" -bug-reports: "https://github.com/anomalyco/devkit/issues" +homepage: "https://github.com/proxylat/devkit" +bug-reports: "https://github.com/proxylat/devkit/issues" depends: [ "ocaml" {>= "5.2"} "dune" {>= "3.24"} @@ -37,5 +37,5 @@ build: [ "@doc" {with-doc} ] ] -dev-repo: "git+https://github.com/anomalyco/devkit.git" +dev-repo: "git+https://github.com/proxylat/devkit.git" x-maintenance-intent: ["(latest)"] diff --git a/dune-project b/dune-project index 8db58ee..c193600 100644 --- a/dune-project +++ b/dune-project @@ -4,7 +4,7 @@ (generate_opam_files true) -(source (github anomalyco/devkit)) +(source (github proxylat/devkit)) (license MIT) (authors "devkit contributors") (maintainers "devkit contributors") diff --git a/lib/update.ml b/lib/update.ml index 3234eec..3af2d46 100644 --- a/lib/update.ml +++ b/lib/update.ml @@ -115,7 +115,7 @@ let cargo_updates (fetch : Fetch.fetch) (versions : (string * string) list) = registry_updates fetch - [ "User-Agent", "devkit (https://github.com/anomalyco/devkit)" ] + [ "User-Agent", "devkit (https://github.com/proxylat/devkit)" ] (fun n -> Printf.sprintf "https://crates.io/api/v1/crates/%s" n) cargo_latest versions From 5fd904c7f360b15adf94e7c845187d6770f87210 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 21:15:36 +0000 Subject: [PATCH 22/34] Silence CI warnings: checkout v5 and cache input actions/checkout@v4 targets deprecated Node 20; setup-ocaml dune-cache input is deprecated in favor of cache. --- .github/workflows/ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5d2da64..7826ec6 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -12,12 +12,12 @@ jobs: os: [ubuntu-latest, windows-latest] runs-on: ${{ matrix.os }} steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v5 - uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: 5.5 - dune-cache: true + cache: true - name: Install dependencies run: opam install . --deps-only --with-test -y @@ -49,7 +49,7 @@ jobs: fmt: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v5 - uses: ocaml/setup-ocaml@v3 with: From 14019545c3c2d8fd101ecafeee7adf9a84fc254f Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 21:39:59 +0000 Subject: [PATCH 23/34] Set CI token permissions to contents read Silences CodeQL missing-workflow-permissions; nothing in the workflow needs write. --- .github/workflows/ci.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7826ec6..7bbbbb8 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -4,6 +4,9 @@ on: push: pull_request: +permissions: + contents: read + jobs: build: strategy: From 156c3478208c97eae6f1b4d582c6f6bdb4fa802a Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 22:24:16 +0000 Subject: [PATCH 24/34] Diagnose empty scans and show install progress in TUI find_on_path takes ?os: Win32 splits PATH on ';' only and probes name.exe, so drive-letter dirs and extensionless lookups hit. App.scan carries the ensure error; empty scans print the winget resolution and, in the TUI, pause for a keypress so Explorer-launched windows stay readable. press_enter/press_u repaint a Tui.set_message status line before the blocking call. --- bin/tui_front.ml | 80 ++++++++++++++++++++++++++++++++++-------- lib/app.ml | 29 +++++++++++---- lib/app.mli | 1 + lib/bootstrap.ml | 31 ++++++++++------ lib/bootstrap.mli | 3 +- lib/tui.ml | 7 ++++ lib/tui.mli | 1 + test/test_app.ml | 16 +++++++++ test/test_bootstrap.ml | 34 ++++++++++++++++-- test/test_tui.ml | 8 +++++ 10 files changed, 173 insertions(+), 37 deletions(-) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index fb15ee7..3e5d727 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -3,8 +3,10 @@ Draws {!Devkit.Tui.frame} lines, feeds key events in, runs installs on Enter. On exit the plain-text dashboard plus the install log go to stdout, so redirected output stays usable. Lambda-term (unlike - notty) has a real Windows backend, so this frontend serves both - OSes. Installs run synchronously and freeze the UI while they run. + notty) has a real Windows backend, so this frontend serves both + OSes. Installs and update checks run synchronously (the event loop + freezes) but paint a status line first, so the screen states what is + running instead of looking dead. Mouse reporting is on for wheel-scroll only; other mouse events are ignored. *) @@ -89,30 +91,44 @@ let kind_of : Manifest.item_type -> string = function | Manifest.Pm s -> s ;; -let press_enter (deps : Install.deps) (st : Tui.state) : Tui.state = +let press_enter ~draw (deps : Install.deps) (st : Tui.state) : Tui.state Lwt.t = match Tui.enter_action st with - | Tui.Do_nothing -> st + | Tui.Do_nothing -> Lwt.return st | Tui.Do_install item -> let update = item.Manifest.status = Manifest.NeedsUpdate in - let o = Install.install deps (kind_of item.Manifest.typ) item.Manifest.value update in - Tui.apply_outcome st item.Manifest.value o + draw (Tui.set_message st ("installing " ^ item.Manifest.value ^ " ...")) + >>= fun () -> + (* Let the repaint reach the screen before the blocking call. *) + Lwt.pause () + >>= fun () -> + Lwt.return + (Tui.apply_outcome + st + item.Manifest.value + (Install.install deps (kind_of item.Manifest.typ) item.Manifest.value update)) | Tui.Do_open url -> (match deps.Install.open_browser url with | Ok () -> let o = { Install.value = url; status = Install.Opened } in - Tui.apply_outcome st url o + Lwt.return (Tui.apply_outcome st url o) | Error e -> let o = { Install.value = url; status = Install.Failed e } in - Tui.apply_outcome st url o) + Lwt.return (Tui.apply_outcome st url o)) ;; let viewport (w : int) (h : int) : int * int = max 1 w, max 1 (h - 3) (** [u]: check npm/pipx/uv/cargo updates for the Installed rows, then - mark the hits. Runs synchronously like installs (UI freezes). *) -let press_u (run : Proc.runner) (fetch : Fetch.fetch) (st : Tui.state) : Tui.state = + mark the hits. Paints a status line first, then runs synchronously + like installs (UI freezes). *) +let press_u ~draw (run : Proc.runner) (fetch : Fetch.fetch) (st : Tui.state) + : Tui.state Lwt.t + = let items = List.map (fun e -> e.Tui.item) st.Tui.entries in - Tui.apply_updates st (Update.check_all ~run ~fetch items) + draw (Tui.set_message st "checking updates ...") + >>= fun () -> + Lwt.pause () + >>= fun () -> Lwt.return (Tui.apply_updates st (Update.check_all ~run ~fetch items)) ;; (** Repaint in place, one addressed line at a time: no full-screen @@ -168,8 +184,8 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = match classify ev with | Quit -> Lwt.return st | Nothing -> wait_loop st - | Enter -> draw_loop (press_enter deps st) - | Update -> draw_loop (press_u env.App.run fetch st) + | Enter -> press_enter ~draw:(draw_all term) deps st >>= draw_loop + | Update -> press_u ~draw:(draw_all term) env.App.run fetch st >>= draw_loop | Action a -> draw_loop (Tui.step st a) | Resized g -> LTerm.clear_screen term @@ -177,7 +193,20 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = let vw, vh = viewport g.LTerm_geom.cols g.LTerm_geom.rows in draw_loop (Tui.resize st ~height:vh ~width:vw) in - draw_loop (Tui.make dash ~height:vh ~width:vw) + let init = Tui.make dash ~height:vh ~width:vw in + let init = + if s.App.apps = [] + then + Tui.set_message + init + (if s.App.winget <> "" + then "empty scan; winget at " ^ s.App.winget + else if s.App.winget_error <> "" + then "empty scan; " ^ s.App.winget_error + else "empty scan; winget not found") + else init + in + draw_loop init >>= fun st -> LTerm.disable_mouse term >>= fun () -> @@ -187,5 +216,26 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = >>= fun () -> LTerm.show_cursor term >>= fun () -> Lwt.return st) in print_string (Dashboard.render dash); - List.iter print_endline final.Tui.log + List.iter print_endline final.Tui.log; + (* An empty scan behind a double-clicked window would vanish with the + console: leave the diagnostics readable until a keypress. Normal + runs (and piped stdin) never pause. *) + if s.App.apps = [] + then ( + let winget = + if s.App.winget <> "" + then "winget: " ^ s.App.winget + else if s.App.winget_error <> "" + then "winget error: " ^ s.App.winget_error + else "winget: not found" + in + print_endline (" no installed software found\n " ^ winget); + try + if Unix.isatty Unix.stdin + then ( + print_string "Press Enter to exit..."; + flush stdout; + ignore (input_line stdin)) + with + | _ -> ()) ;; diff --git a/lib/app.ml b/lib/app.ml index cee3f32..d18cd92 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -95,6 +95,7 @@ type scan = { apps : app list ; info : Winget_parse.info Winget_parse.IdMap.t option ; winget : string + ; winget_error : string } (** [DEVKIT_TIMING=1] prints per-phase startup timings to stderr, so a @@ -111,13 +112,14 @@ let timed (label : string) (f : unit -> 'a) : 'a = (** One scan + update check; the memoized [winget list] fetch is shared by both, so a command spawns winget once per 8s window. A failed ensure - degrades to winget-less operation (""). *) + degrades to winget-less operation ([""] + the error in + [winget_error]) instead of hiding the cause. *) let scan (e : env) ~(override_path : string) ~(extra : Plugin.tool list) : scan = - let winget = + let winget, winget_error = timed "ensure" (fun () -> match Bootstrap.ensure ~override_path e.bio with - | Ok w -> w - | Error _ -> "") + | Ok w -> w, "" + | Error err -> "", err) in let fetch, _ = Proc.winget_list e.run in let apps = @@ -138,7 +140,7 @@ let scan (e : env) ~(override_path : string) ~(extra : Plugin.tool list) : scan if Winget_parse.IdMap.is_empty fb then None else Some fb) else Some m) in - { apps; info; winget } + { apps; info; winget; winget_error } ;; let to_dashboard_apps (apps : app list) : Dashboard.app list = @@ -148,7 +150,9 @@ let to_dashboard_apps (apps : app list) : Dashboard.app list = ;; (** Default view: scan, enrich, merge with the manifest, render plain - text. Returns the rendered dashboard (the TUI takes over on a tty). *) + text. Returns the rendered dashboard (the TUI takes over on a tty). + An empty scan appends what the winget resolution found, so a bare + dashboard never hides the cause. *) let default_view (e : env) ~(tools : Plugin.tool list) : string = let sections, winget_path = load_manifest e.fs Manifest.filename in let s = scan e ~override_path:winget_path ~extra:tools in @@ -160,7 +164,18 @@ let default_view (e : env) ~(tools : Plugin.tool list) : string = timed "build" (fun () -> build_sections ~show ~run:(Some e.run) (to_dashboard_apps s.apps) sections s.info) in - render dash + let body = render dash in + if s.apps <> [] + then body + else ( + let winget = + if s.winget <> "" + then "winget: " ^ s.winget + else if s.winget_error <> "" + then "winget error: " ^ s.winget_error + else "winget: not found" + in + body ^ "\n no installed software found\n " ^ winget) ;; let import_view (e : env) ?(tools : Plugin.tool list = []) (path : string) diff --git a/lib/app.mli b/lib/app.mli index 7ba48e5..10ca940 100644 --- a/lib/app.mli +++ b/lib/app.mli @@ -18,6 +18,7 @@ type scan = { apps : Dashboard.app list ; info : Winget_parse.info Winget_parse.IdMap.t option ; winget : string + ; winget_error : string } (** Missing/unparseable file yields empty sections. *) diff --git a/lib/bootstrap.ml b/lib/bootstrap.ml index b174c73..c59b93d 100644 --- a/lib/bootstrap.ml +++ b/lib/bootstrap.ml @@ -2,7 +2,7 @@ Resolution order: [# winget:] override → portable candidates walking up 4 levels from the cwd, then the exe dir → exe-adjacent [winget/] - subfolder → PATH lookup of ["winget"] (no [.exe]) → [cmd /c where + subfolder → PATH lookup of ["winget"] (+ [.exe] on Win32) → [cmd /c where winget] alias resolution with a [--version] probe → [%LOCALAPPDATA%/…/WindowsApps/winget.exe] with probe → cached [AppInstaller.exe] → download. @@ -123,22 +123,31 @@ let find_portable ~is_file (base : string) : string = level base 4 ;; -(** PATH lookup for [name]. Splits on both [:] and [;] so fakes stay - platform-independent. *) -let find_on_path ~getenv ~is_file (name : string) : string = +(** PATH lookup for [name]. The separator is [;] on Win32 ([?] injected + for tests) and [:] elsewhere: splitting on both mangles drive-letter + dirs like [C:\…]. On Win32 each dir is also probed for [name.exe], + since the file on disk carries the extension. *) +let find_on_path ?(os = Sys.os_type) ~getenv ~is_file (name : string) : string = let raw = match getenv "PATH" with | None -> "" | Some p -> p in - let dirs = - String.split_on_char ':' raw - |> List.concat_map (String.split_on_char ';') - |> List.filter (fun d -> d <> "") + let win = os = "Win32" || os = "Cygwin" in + let sep = if os = "Win32" then ';' else ':' in + let dirs = List.filter (fun d -> d <> "") (String.split_on_char sep raw) in + let names = if win then [ name; name ^ ".exe" ] else [ name ] in + let hit = + List.find_map + (fun d -> + List.find_map + (fun n -> + let p = Filename.concat d n in + if is_file p then Some p else None) + names) + dirs in - match List.find_opt (fun d -> is_file (Filename.concat d name)) dirs with - | None -> "" - | Some d -> Filename.concat d name + Option.value hit ~default:"" ;; (** True when [path] answers [--version] with exit 0, or prints anything diff --git a/lib/bootstrap.mli b/lib/bootstrap.mli index bf7cd38..ddd8224 100644 --- a/lib/bootstrap.mli +++ b/lib/bootstrap.mli @@ -26,7 +26,8 @@ val real_io : Fetch.fetch -> io val find_portable : is_file:(string -> bool) -> string -> string val find_on_path - : getenv:(string -> string option) + : ?os:string + -> getenv:(string -> string option) -> is_file:(string -> bool) -> string -> string diff --git a/lib/tui.ml b/lib/tui.ml index b988b68..1e4fce4 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -247,6 +247,13 @@ let render_line : line -> string = function with per-row colors from {!lines}. *) let frame (s : state) : string list = List.map render_line (lines s) +(** Set the footer message and append it to the log. The frontend paints + this before a blocking install/update check, so the screen states + what is running while the event loop is frozen. *) +let set_message (s : state) (m : string) : state = + { s with message = Some m; log = s.log @ [ m ] } +;; + (** Record an install outcome: refresh the row status, append the log. *) let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = let status = diff --git a/lib/tui.mli b/lib/tui.mli index 32faa9d..88fdb2f 100644 --- a/lib/tui.mli +++ b/lib/tui.mli @@ -66,5 +66,6 @@ type line = val lines : state -> line list val render_line : line -> string val frame : state -> string list +val set_message : state -> string -> state val apply_outcome : state -> string -> Install.outcome -> state val apply_updates : state -> (string * string) list -> state diff --git a/test/test_app.ml b/test/test_app.ml index 10ddbac..9b73b00 100644 --- a/test/test_app.ml +++ b/test/test_app.ml @@ -266,6 +266,20 @@ let default () = Alcotest.(check bool) "mentions app" true (contains "Git.Git" s) ;; +let scan_error () = + let s = App.scan (env (Hashtbl.create 1)) ~override_path:"" ~extra:[] in + Alcotest.(check string) "no winget" "" s.App.winget; + Alcotest.(check bool) "error carried" true (s.App.winget_error <> "") +;; + +let default_empty () = + let e = + { App.run = (fun _ _ -> None); fs = mem_fs (Hashtbl.create 1); bio = fake_bio () } + in + let s = App.default_view ~tools:[] e in + Alcotest.(check bool) "names winget" true (contains "winget" s) +;; + let () = Alcotest.run "app" @@ -288,6 +302,8 @@ let () = ; Alcotest.test_case "export_except" `Quick export_except ; Alcotest.test_case "show" `Quick show ; Alcotest.test_case "default" `Quick default + ; Alcotest.test_case "scan error" `Quick scan_error + ; Alcotest.test_case "default empty" `Quick default_empty ] ) ] ;; diff --git a/test/test_bootstrap.ml b/test/test_bootstrap.ml index 63cfbb2..f10e64a 100644 --- a/test/test_bootstrap.ml +++ b/test/test_bootstrap.ml @@ -72,16 +72,42 @@ let test_portable_stops_at_4 () = let test_on_path () = let getenv = function - | "PATH" -> Some "/x;/y:/z" + | "PATH" -> Some "/x:/y:/z" | _ -> None in let is_file = fun p -> p = Filename.concat "/y" "winget" in Alcotest.(check string) - "both separators" + "colon separated" (Filename.concat "/y" "winget") (Bootstrap.find_on_path ~getenv ~is_file "winget") ;; +let test_on_path_win32_exe () = + let getenv = function + | "PATH" -> Some "C:\\tools;D:\\more" + | _ -> None + in + let want = Filename.concat "C:\\tools" "winget.exe" in + let is_file = fun p -> p = want in + Alcotest.(check string) + "win32 exe suffix" + want + (Bootstrap.find_on_path ~os:"Win32" ~getenv ~is_file "winget") +;; + +let test_on_path_win32_drive_letter () = + let getenv = function + | "PATH" -> Some "C:\\tools" + | _ -> None + in + let want = Filename.concat "C:\\tools" "winget.exe" in + let is_file = fun p -> p = want in + Alcotest.(check string) + "drive letter not split" + want + (Bootstrap.find_on_path ~os:"Win32" ~getenv ~is_file "winget") +;; + let test_on_path_miss () = Alcotest.(check string) "miss" @@ -447,8 +473,10 @@ let () = ; Alcotest.test_case "stops at 4" `Quick test_portable_stops_at_4 ] ) ; ( "find_on_path" - , [ Alcotest.test_case "both separators" `Quick test_on_path + , [ Alcotest.test_case "colon separated" `Quick test_on_path ; Alcotest.test_case "miss" `Quick test_on_path_miss + ; Alcotest.test_case "win32 exe suffix" `Quick test_on_path_win32_exe + ; Alcotest.test_case "win32 drive letter" `Quick test_on_path_win32_drive_letter ] ) ; ( "winget_runs" , [ Alcotest.test_case "exit 0" `Quick test_runs_ok diff --git a/test/test_tui.ml b/test/test_tui.ml index 8985667..b586f30 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -162,6 +162,13 @@ let scroll () = Alcotest.(check int) "scroll back clamps" 0 s.Devkit.Tui.cursor ;; +let set_message () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let s = Tui.set_message s "installing b ..." in + Alcotest.(check (option string)) "footer" (Some "installing b ...") s.Tui.message; + Alcotest.(check bool) "logged" true (List.mem "installing b ..." s.Tui.log) +;; + let () = Alcotest.run "tui" @@ -178,6 +185,7 @@ let () = ; ( "outcome" , [ Alcotest.test_case "success" `Quick apply_success ; Alcotest.test_case "failure keeps" `Quick apply_failure_keeps + ; Alcotest.test_case "set message" `Quick set_message ] ) ; ( "frame" , [ Alcotest.test_case "shape" `Quick frame_shape From b7a430094f06bd03c8662438d7c198d2312ab39e Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 22:39:40 +0000 Subject: [PATCH 25/34] Ship windows exe as devkit.exe Copy main.exe to devkit.exe before artifact upload so the download runs under its own name. README uses dune exec devkit. --- .github/workflows/ci.yml | 6 +++++- README.md | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7bbbbb8..7e29215 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -42,12 +42,16 @@ jobs: opam exec -- dune exec test/test_$t.exe && echo PASS || echo "FAIL exit=$?" done + - name: Rename exe to devkit.exe + if: matrix.os == 'windows-latest' + run: cp _build/default/bin/main.exe _build/default/bin/devkit.exe + - name: Upload windows exe if: matrix.os == 'windows-latest' uses: actions/upload-artifact@v4 with: name: devkit-windows - path: _build/default/bin/main.exe + path: _build/default/bin/devkit.exe fmt: runs-on: ubuntu-latest diff --git a/README.md b/README.md index 6ad0267..058db72 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ lambda-term lwt ocamlformat`. eval $(opam env --switch=system) dune build dune runtest # 129 alcotests, must stay green -dune exec bin/main.exe -- --help +dune exec devkit -- --help ``` Without `eval $(opam env ...)`, the shell finds the wrong dune From 90033aaa77e62f07ecc2664155bd9ffe1dfe8cd9 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 22:40:18 +0000 Subject: [PATCH 26/34] Show scanning progress before first frame The PM scan takes ~2s on Windows before the TUI draws; print to stderr first so the wait looks alive instead of hung. --- bin/tui_front.ml | 4 ++++ lib/app.ml | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index 3e5d727..34db829 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -147,6 +147,10 @@ let draw_all (term : LTerm.t) (st : Tui.state) : unit Lwt.t = ;; let run ~(tools : Plugin.tool list) (env : App.env) : unit = + (* The scan below spawns winget + 4 PMs (~2s on Windows) before the + first frame draws; stderr stays visible so the wait looks alive. *) + prerr_endline "scanning installed software..."; + flush stderr; let sections, winget_path = App.load_manifest env.App.fs Manifest.filename in let s = App.scan env ~override_path:winget_path ~extra:tools in let show id = diff --git a/lib/app.ml b/lib/app.ml index d18cd92..ca4461f 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -154,6 +154,10 @@ let to_dashboard_apps (apps : app list) : Dashboard.app list = An empty scan appends what the winget resolution found, so a bare dashboard never hides the cause. *) let default_view (e : env) ~(tools : Plugin.tool list) : string = + (* Slow spawns (winget list) run after this; stderr stays visible + past the TUI's alternate screen, so the wait looks alive. *) + prerr_endline "scanning installed software..."; + flush stderr; let sections, winget_path = load_manifest e.fs Manifest.filename in let s = scan e ~override_path:winget_path ~extra:tools in let show id = From be1bc92dc7b65a32531c80a5bd6bc87935e88d23 Mon Sep 17 00:00:00 2001 From: devkit Date: Thu, 24 Sep 2026 23:12:14 +0000 Subject: [PATCH 27/34] Fix Windows-only test failures: pin os, atomic call counter test_on_path assumed Unix colon-PATH via the default os; pin ~os:Unix. show-fallback-many counted parallel show calls with a shared ref, losing updates across domains; use an Atomic counter instead. --- test/test_bootstrap.ml | 2 +- test/test_dashboard.ml | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/test/test_bootstrap.ml b/test/test_bootstrap.ml index f10e64a..9d1de49 100644 --- a/test/test_bootstrap.ml +++ b/test/test_bootstrap.ml @@ -79,7 +79,7 @@ let test_on_path () = Alcotest.(check string) "colon separated" (Filename.concat "/y" "winget") - (Bootstrap.find_on_path ~getenv ~is_file "winget") + (Bootstrap.find_on_path ~os:"Unix" ~getenv ~is_file "winget") ;; let test_on_path_win32_exe () = diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml index 596ce52..3ef2c53 100644 --- a/test/test_dashboard.ml +++ b/test/test_dashboard.ml @@ -88,9 +88,11 @@ let show_fallback_many () = the right item (parallel path, order preserved). *) let ids = List.init 30 (fun i -> Printf.sprintf "App.%d" i) in let manifest = [ { name = "Many"; items = List.map (item Winget) ids } ] in - let calls = ref [] in + (* [show] runs on parallel domains: count with an atomic, since a + shared [ref] prepend can lose updates under concurrent writes. *) + let calls = Atomic.make 0 in let show id = - calls := id :: !calls; + Atomic.incr calls; Some (id ^ "-ver") in let sections = Dashboard.build_sections ~show [] manifest None in @@ -101,7 +103,7 @@ let show_fallback_many () = Alcotest.(check string) ("version " ^ id) (id ^ "-ver") it.available_version) ids got; - Alcotest.(check int) "show called per id" 30 (List.length !calls) + Alcotest.(check int) "show called per id" 30 (Atomic.get calls) ;; let render_fixture () = From cf6093f8061b0c0cf508773177d099345c861443 Mon Sep 17 00:00:00 2001 From: devkit Date: Wed, 30 Sep 2026 18:11:23 +0000 Subject: [PATCH 28/34] Scan in background behind loading frame, log full install errors The TUI blocked on App.scan before the first frame, showing only a stderr line. Run the scan on a preemptive worker and race it against terminal events so quit and resize stay live. Apply_outcome now logs the Failed and Skipped reason instead of the bare status. --- bin/tui_front.ml | 201 ++++++++++++++++++++++++++++++----------------- lib/tui.ml | 13 ++- test/test_tui.ml | 24 ++++++ 3 files changed, 163 insertions(+), 75 deletions(-) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index 34db829..3fe5323 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -4,9 +4,12 @@ on Enter. On exit the plain-text dashboard plus the install log go to stdout, so redirected output stays usable. Lambda-term (unlike notty) has a real Windows backend, so this frontend serves both - OSes. Installs and update checks run synchronously (the event loop - freezes) but paint a status line first, so the screen states what is - running instead of looking dead. + OSes. The scan runs on a preemptive worker behind an instant loading + frame (quit/resize stay live); installs and update checks run + synchronously (the event loop freezes) but paint a status line first, + so the screen states what is running instead of looking dead. + Install failures log the full reason ([id: error: ...]), not the + bare status. Mouse reporting is on for wheel-scroll only; other mouse events are ignored. *) @@ -146,24 +149,48 @@ let draw_all (term : LTerm.t) (st : Tui.state) : unit Lwt.t = LTerm.flush term ;; +let empty_scan_message (s : App.scan) : string option = + if s.App.apps <> [] + then None + else if s.App.winget <> "" + then Some ("empty scan; winget at " ^ s.App.winget) + else if s.App.winget_error <> "" + then Some ("empty scan; " ^ s.App.winget_error) + else Some "empty scan; winget not found" +;; + let run ~(tools : Plugin.tool list) (env : App.env) : unit = - (* The scan below spawns winget + 4 PMs (~2s on Windows) before the - first frame draws; stderr stays visible so the wait looks alive. *) + (* First frame draws instantly with a loading row; the scan below + (winget + 4 PMs, ~2s on Windows) runs on a preemptive worker while + the event loop stays responsive to quit/resize. Stderr stays visible + so the wait looks alive past the alternate screen. *) prerr_endline "scanning installed software..."; flush stderr; - let sections, winget_path = App.load_manifest env.App.fs Manifest.filename in - let s = App.scan env ~override_path:winget_path ~extra:tools in - let show id = - match App.winget_show env.App.bio s.App.winget id with - | "" -> None - | v -> Some v + let do_scan () = + let sections, winget_path = App.load_manifest env.App.fs Manifest.filename in + let s = App.scan env ~override_path:winget_path ~extra:tools in + let show id = + match App.winget_show env.App.bio s.App.winget id with + | "" -> None + | v -> Some v + in + let dash = + Dashboard.build_sections + ~show + ~run:(Some env.App.run) + s.App.apps + sections + s.App.info + in + dash, s, winget_path in - let dash = - Dashboard.build_sections ~show ~run:(Some env.App.run) s.App.apps sections s.App.info + let cleanup term mode = + LTerm.disable_mouse term + >>= fun () -> + LTerm.load_state term + >>= fun () -> LTerm.leave_raw_mode term mode >>= fun () -> LTerm.show_cursor term in - let fetch = Fetch.curl_fetch Proc.default_runner in - let deps = Install.real_deps fetch ~winget_override:winget_path () in - let final = + let outcome = Lwt_main.run (Lazy.force LTerm.stdout >>= fun term -> @@ -179,67 +206,95 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = >>= fun () -> let geom = LTerm.size term in let vw, vh = viewport geom.LTerm_geom.cols geom.LTerm_geom.rows in - (* Draw, then wait: events that change nothing skip the repaint. *) - let rec draw_loop (st : Tui.state) : Tui.state Lwt.t = - draw_all term st >>= fun () -> wait_loop st - and wait_loop (st : Tui.state) : Tui.state Lwt.t = - LTerm.read_event term - >>= fun ev -> - match classify ev with - | Quit -> Lwt.return st - | Nothing -> wait_loop st - | Enter -> press_enter ~draw:(draw_all term) deps st >>= draw_loop - | Update -> press_u ~draw:(draw_all term) env.App.run fetch st >>= draw_loop - | Action a -> draw_loop (Tui.step st a) - | Resized g -> - LTerm.clear_screen term - >>= fun () -> - let vw, vh = viewport g.LTerm_geom.cols g.LTerm_geom.rows in - draw_loop (Tui.resize st ~height:vh ~width:vw) + (* Main loop once the scan lands: draws, then waits. Events that + change nothing skip the repaint. *) + let main_loop deps fetch init = + let rec draw_loop (st : Tui.state) : Tui.state Lwt.t = + draw_all term st >>= fun () -> wait_loop st + and wait_loop (st : Tui.state) : Tui.state Lwt.t = + LTerm.read_event term + >>= fun ev -> + match classify ev with + | Quit -> Lwt.return st + | Nothing -> wait_loop st + | Enter -> press_enter ~draw:(draw_all term) deps st >>= draw_loop + | Update -> press_u ~draw:(draw_all term) env.App.run fetch st >>= draw_loop + | Action a -> draw_loop (Tui.step st a) + | Resized g -> + LTerm.clear_screen term + >>= fun () -> + let vw, vh = viewport g.LTerm_geom.cols g.LTerm_geom.rows in + draw_loop (Tui.resize st ~height:vh ~width:vw) + in + draw_loop init in - let init = Tui.make dash ~height:vh ~width:vw in - let init = - if s.App.apps = [] - then - Tui.set_message - init - (if s.App.winget <> "" - then "empty scan; winget at " ^ s.App.winget - else if s.App.winget_error <> "" - then "empty scan; " ^ s.App.winget_error - else "empty scan; winget not found") - else init + let loading = + Tui.set_message + (Tui.make [] ~height:vh ~width:vw) + "scanning installed software..." in - draw_loop init - >>= fun st -> - LTerm.disable_mouse term - >>= fun () -> - LTerm.load_state term + draw_all term loading >>= fun () -> - LTerm.leave_raw_mode term mode - >>= fun () -> LTerm.show_cursor term >>= fun () -> Lwt.return st) + let scan_job = Lwt_preemptive.detach do_scan () in + let rec wait_scan (st : Tui.state) + : [ `Done of Manifest.section list * App.scan * Tui.state | `Quit ] Lwt.t + = + Lwt.pick + [ (scan_job >|= fun r -> `Scan r) + ; (LTerm.read_event term >|= fun e -> `Event e) + ] + >>= function + | `Scan (dash, s, winget_path) -> + let fetch = Fetch.curl_fetch Proc.default_runner in + let deps = Install.real_deps fetch ~winget_override:winget_path () in + let init = Tui.make dash ~height:st.Tui.height ~width:st.Tui.width in + let init = + match empty_scan_message s with + | None -> init + | Some m -> Tui.set_message init m + in + main_loop deps fetch init + >>= fun final -> + cleanup term mode >>= fun () -> Lwt.return (`Done (dash, s, final)) + | `Event ev -> + (match classify ev with + | Quit -> + Lwt.cancel scan_job; + cleanup term mode >>= fun () -> Lwt.return `Quit + | Resized g -> + LTerm.clear_screen term + >>= fun () -> + let vw, vh = viewport g.LTerm_geom.cols g.LTerm_geom.rows in + let st = Tui.resize st ~height:vh ~width:vw in + draw_all term st >>= fun () -> wait_scan st + | _ -> wait_scan st) + in + wait_scan loading) in - print_string (Dashboard.render dash); - List.iter print_endline final.Tui.log; - (* An empty scan behind a double-clicked window would vanish with the + match outcome with + | `Quit -> () + | `Done (dash, s, final) -> + print_string (Dashboard.render dash); + List.iter print_endline final.Tui.log; + (* An empty scan behind a double-clicked window would vanish with the console: leave the diagnostics readable until a keypress. Normal runs (and piped stdin) never pause. *) - if s.App.apps = [] - then ( - let winget = - if s.App.winget <> "" - then "winget: " ^ s.App.winget - else if s.App.winget_error <> "" - then "winget error: " ^ s.App.winget_error - else "winget: not found" - in - print_endline (" no installed software found\n " ^ winget); - try - if Unix.isatty Unix.stdin - then ( - print_string "Press Enter to exit..."; - flush stdout; - ignore (input_line stdin)) - with - | _ -> ()) + if s.App.apps = [] + then ( + let winget = + if s.App.winget <> "" + then "winget: " ^ s.App.winget + else if s.App.winget_error <> "" + then "winget error: " ^ s.App.winget_error + else "winget: not found" + in + print_endline (" no installed software found\n " ^ winget); + try + if Unix.isatty Unix.stdin + then ( + print_string "Press Enter to exit..."; + flush stdout; + ignore (input_line stdin)) + with + | _ -> ()) ;; diff --git a/lib/tui.ml b/lib/tui.ml index 1e4fce4..3b14e37 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -254,7 +254,16 @@ let set_message (s : state) (m : string) : state = { s with message = Some m; log = s.log @ [ m ] } ;; -(** Record an install outcome: refresh the row status, append the log. *) +(** Record an install outcome: refresh the row status, append the log. + The log keeps the full [Failed]/[Skipped] reason instead of the bare + short status, so a row like [Audacity.Audacity: error: ...] explains + itself without a second lookup. *) +let outcome_line (value : string) : Install.status -> string = function + | Install.Failed m -> if m = "" then value ^ ": error" else value ^ ": error: " ^ m + | Install.Skipped m -> if m = "" then value ^ ": skip" else value ^ ": skip: " ^ m + | st -> Printf.sprintf "%s: %s" value (Install.status_to_string st) +;; + let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = let status = match o.Install.status with @@ -271,7 +280,7 @@ let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = if e.item.value = value then { e with item = { e.item with status } } else e) s.entries in - let line = Printf.sprintf "%s: %s" value (Install.status_to_string o.Install.status) in + let line = outcome_line value o.Install.status in clamp { s with entries; message = Some line; log = s.log @ [ line ] } ;; diff --git a/test/test_tui.ml b/test/test_tui.ml index b586f30..2661036 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -169,6 +169,29 @@ let set_message () = Alcotest.(check bool) "logged" true (List.mem "installing b ..." s.Tui.log) ;; +let apply_failure_logs_reason () = + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let s = Tui.step s Tui.Down in + let s = + Tui.apply_outcome s "b" { Install.value = "b"; status = Install.Failed "denied" } + in + Alcotest.(check string) + "full reason kept" + "b: error: denied" + (List.hd (List.rev s.Tui.log)); + let s = Tui.make (sections ()) ~height:10 ~width:80 in + let s = + Tui.apply_outcome + s + "a" + { Install.value = "a"; status = Install.Skipped "no template" } + in + Alcotest.(check string) + "skip reason kept" + "a: skip: no template" + (List.hd (List.rev s.Tui.log)) +;; + let () = Alcotest.run "tui" @@ -185,6 +208,7 @@ let () = ; ( "outcome" , [ Alcotest.test_case "success" `Quick apply_success ; Alcotest.test_case "failure keeps" `Quick apply_failure_keeps + ; Alcotest.test_case "failure logs reason" `Quick apply_failure_logs_reason ; Alcotest.test_case "set message" `Quick set_message ] ) ; ( "frame" From 58ea7a4e69a98ce1367f2c3a1140f038bc59e128 Mon Sep 17 00:00:00 2001 From: devkit Date: Wed, 30 Sep 2026 19:15:29 +0000 Subject: [PATCH 29/34] Render TUI end state on exit so installs show green The exit printout rendered the pre-session snapshot, hiding installs done in the session. Overlay the session row statuses onto the dashboard before rendering. --- bin/tui_front.ml | 3 +++ lib/tui.ml | 28 ++++++++++++++++++++++++++++ lib/tui.mli | 1 + test/test_tui.ml | 15 +++++++++++++++ 4 files changed, 47 insertions(+) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index 3fe5323..a707798 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -274,6 +274,9 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = match outcome with | `Quit -> () | `Done (dash, s, final) -> + (* Re-render from the end state, so successful installs show green + instead of the pre-session snapshot. *) + let dash = Tui.apply_to_sections dash final in print_string (Dashboard.render dash); List.iter print_endline final.Tui.log; (* An empty scan behind a double-clicked window would vanish with the diff --git a/lib/tui.ml b/lib/tui.ml index 3b14e37..288e6a2 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -284,6 +284,34 @@ let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = clamp { s with entries; message = Some line; log = s.log @ [ line ] } ;; +(** Overlay the session's row statuses back onto dashboard sections, so a + re-render after the TUI exits shows the end state: successful installs + come out green instead of the pre-session snapshot. Lookup is by + lowercased value, mirroring {!apply_outcome}. *) +let apply_to_sections (sections : section list) (s : state) : section list = + let table : (string, item) Hashtbl.t = Hashtbl.create 16 in + List.iter + (fun e -> Hashtbl.replace table (String.lowercase_ascii e.item.value) e.item) + s.entries; + List.map + (fun (sec : section) -> + { sec with + items = + List.map + (fun (it : item) -> + match Hashtbl.find_opt table (String.lowercase_ascii it.value) with + | None -> it + | Some fresh -> + { it with + status = fresh.status + ; installed_version = fresh.installed_version + ; available_version = fresh.available_version + }) + sec.items + }) + sections +;; + (** Mark rows with available updates: set available_version + [NeedsUpdate] by value, with a summary message + log. An empty result keeps every row and reports everything current. *) diff --git a/lib/tui.mli b/lib/tui.mli index 88fdb2f..4d28be5 100644 --- a/lib/tui.mli +++ b/lib/tui.mli @@ -68,4 +68,5 @@ val render_line : line -> string val frame : state -> string list val set_message : state -> string -> state val apply_outcome : state -> string -> Install.outcome -> state +val apply_to_sections : section list -> state -> section list val apply_updates : state -> (string * string) list -> state diff --git a/test/test_tui.ml b/test/test_tui.ml index 2661036..bcb977b 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -192,6 +192,20 @@ let apply_failure_logs_reason () = (List.hd (List.rev s.Tui.log)) ;; +let apply_to_sections_reflects_session () = + let secs = sections () in + let s = Tui.make secs ~height:10 ~width:80 in + let s = Tui.step s Tui.Down in + let s = Tui.apply_outcome s "b" { Install.value = "b"; status = Install.Updated } in + let out = Tui.apply_to_sections secs s in + let b = + List.concat_map (fun sec -> sec.Manifest.items) out + |> List.find (fun it -> it.Manifest.value = "b") + in + Alcotest.(check bool) "installed at end" true (b.Manifest.status = Manifest.Installed); + Alcotest.(check bool) "renders green" true (Tui.color_of b.Manifest.status = Tui.Green) +;; + let () = Alcotest.run "tui" @@ -209,6 +223,7 @@ let () = , [ Alcotest.test_case "success" `Quick apply_success ; Alcotest.test_case "failure keeps" `Quick apply_failure_keeps ; Alcotest.test_case "failure logs reason" `Quick apply_failure_logs_reason + ; Alcotest.test_case "end state green" `Quick apply_to_sections_reflects_session ; Alcotest.test_case "set message" `Quick set_message ] ) ; ( "frame" From 6232b6be41571ca63628b5965a1f59ef3ca7c756 Mon Sep 17 00:00:00 2001 From: devkit Date: Wed, 30 Sep 2026 19:19:45 +0000 Subject: [PATCH 30/34] Move installed rows into trailing INSTALLED section Build_sections splits Installed items out of manifest sections into a trailing Installed section, mirroring Pending updates. The table now ends on green checkmarks in plain output and the TUI. --- lib/dashboard.ml | 25 ++++++++++++++++++------ lib/dashboard.mli | 3 ++- test/test_dashboard.ml | 44 +++++++++++++++++++++++++++++++++++++++++- 3 files changed, 64 insertions(+), 8 deletions(-) diff --git a/lib/dashboard.ml b/lib/dashboard.ml index cbbb4d6..8c7a462 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -86,7 +86,9 @@ let candidates (it : item) : string list = 1. "Pending updates": manifest items needing update, plus non-manifest installed apps that have an Available version. 2. "Newly detected": other installed apps missing from the manifest. - 3. The manifest sections minus their updated items. + 3. The manifest sections minus their updated and installed items. + 4. "Installed": the manifest items already at their latest version, + trailing the table so the run ends on green. A manifest section literally named "winget" is dropped (it is a leftover artifact, never real content). *) let build_sections @@ -247,8 +249,11 @@ let build_sections } :: !man_updates)) ids); - (* 4. Split manifest updates out, preserving name and order. *) + (* 4. Split manifest updates and installed apps out, preserving name + and order: updates join "Pending updates" up top, installed rows + join the trailing "Installed" section. *) let man_rest = ref [] in + let done_items = ref [] in List.iter (fun sec -> let rest_items = ref [] in @@ -256,15 +261,19 @@ let build_sections (fun it -> if it.status = NeedsUpdate then man_updates := it :: !man_updates + else if it.status = Installed + then done_items := it :: !done_items else rest_items := it :: !rest_items) sec.items; let rest_items = List.rev !rest_items in if rest_items <> [] then man_rest := { sec with items = rest_items } :: !man_rest) pkgs_sections; - (* NOTE: man_updates is accumulated in reverse in steps 3 and 4. Go appends - non-manifest updates first, then manifest updates in section order; - reversing once at the end reproduces exactly that. *) + (* NOTE: man_updates and done_items accumulate in reverse in steps 3 + and 4. Go appends non-manifest updates first, then manifest updates + in section order; reversing once at the end reproduces exactly that. + Installed rows likewise un-reverse into section order. *) let man_updates = List.rev !man_updates in + let done_items = List.rev !done_items in (* 5. Newly-detected installed apps. *) let pkg_names : (string, unit) Hashtbl.t = Hashtbl.create 64 in List.iter @@ -307,13 +316,17 @@ let build_sections ids); let new_items = List.rev !new_items in (* 6. Final order, minus the raw "winget" artifact section. - man_rest was consed in section order, so it is reversed back here. *) + man_rest was consed in section order, so it is reversed back here. + Installed trails the table so the run ends on green. *) let sections : section list ref = ref [] in if man_updates <> [] then sections := [ { name = "Pending updates"; items = (man_updates : item list) } ]; if new_items <> [] then sections := !sections @ [ { name = "Newly detected"; items = new_items } ]; sections := !sections @ List.rev !man_rest; + if done_items <> [] + then + sections := !sections @ [ { name = "Installed"; items = (done_items : item list) } ]; List.filter (fun (sec : section) -> String.lowercase_ascii sec.name <> "winget") !sections diff --git a/lib/dashboard.mli b/lib/dashboard.mli index 32eb3fd..11dbb44 100644 --- a/lib/dashboard.mli +++ b/lib/dashboard.mli @@ -11,7 +11,8 @@ val format_ver : Manifest.item -> string (** Merge the machine scan with manifest sections into dashboard sections: "Pending updates", "Newly detected", then the manifest sections minus - their updated items. [show] enriches NotFound winget items via + their updated and installed items, then a trailing "Installed" section + so the table ends on green. [show] enriches NotFound winget items via [winget show]. [run] enables a single-spawn PATH probe: manifest items whose candidate command is on PATH (but missed by every PM scan) count as installed. [os] selects the probe shell (default: diff --git a/test/test_dashboard.ml b/test/test_dashboard.ml index 3ef2c53..fc0a9e8 100644 --- a/test/test_dashboard.ml +++ b/test/test_dashboard.ml @@ -126,6 +126,14 @@ let render_fixture () = ; { (item GitHub "owner/tool") with status = Manual } ] } + ; { name = "Installed" + ; items = + [ { (item Winget "Brave.Brave") with + installed_version = "1.80" + ; status = Installed + } + ] + } ; { name = "Empty"; items = [] } ] in @@ -140,6 +148,9 @@ let render_fixture () = ^ " [+] Missing.App\n" ^ " [~] owner/tool\n" ^ "\n" + ^ "INSTALLED\n" + ^ " [✓] Brave.Brave 1.80\n" + ^ "\n" in Alcotest.(check string) "exact render" expected (Dashboard.render sections) ;; @@ -158,11 +169,12 @@ let render_versions () = let basename_match () = (* scan name "bar" matches manifest "Foo.Bar" via basename candidate, - carrying the scanned version. *) + carrying the scanned version into the trailing Installed section. *) let manifest = [ { name = "Tools"; items = [ item Winget "Foo.Bar" ] } ] in let apps = [ Dashboard.{ name = "bar"; version = "1.0"; pm = "winget" } ] in let sections = Dashboard.build_sections apps manifest None in Alcotest.(check int) "one section" 1 (List.length sections); + Alcotest.(check string) "installed last" "Installed" (List.nth sections 0).name; let it = List.nth (List.nth sections 0).items 0 in Alcotest.(check string) "version carried" "1.0" it.installed_version; match it.status with @@ -170,6 +182,33 @@ let basename_match () = | _ -> Alcotest.fail "basename should match" ;; +let installed_last () = + (* updates stay up top, missing rows keep their section, installed rows + trail the table in section order. *) + let manifest = + [ { name = "Tools" + ; items = + [ item Winget "Git.Git"; item Winget "Brave.Brave"; item Winget "Missing.App" ] + } + ] + in + let info = + winget_info + [ "Git.Git", "Git", "2.47.1", "2.48.0"; "Brave.Brave", "Brave", "1.80", "1.80" ] + in + let sections = Dashboard.build_sections [] manifest (Some info) in + Alcotest.(check int) "three sections" 3 (List.length sections); + Alcotest.(check string) "pending first" "Pending updates" (List.nth sections 0).name; + Alcotest.(check string) "manifest middle" "Tools" (List.nth sections 1).name; + Alcotest.(check string) "installed last" "Installed" (List.nth sections 2).name; + let it = List.nth (List.nth sections 2).items 0 in + Alcotest.(check string) "installed value" "Brave.Brave" it.value; + (match it.status with + | Installed -> () + | _ -> Alcotest.fail "brave should be Installed"); + Alcotest.(check bool) "renders green" true (Tui.color_of it.status = Tui.Green) +;; + let url_stem_match () = (* installer filename stem matches the scanned tool name. *) let manifest = @@ -177,6 +216,7 @@ let url_stem_match () = in let apps = [ Dashboard.{ name = "widget-2.0"; version = "2.0"; pm = "manual" } ] in let sections = Dashboard.build_sections apps manifest None in + Alcotest.(check string) "installed last" "Installed" (List.nth sections 0).name; let it = List.nth (List.nth sections 0).items 0 in match it.status with | Installed -> () @@ -196,6 +236,7 @@ let path_probe_rescue () = in let sections = Dashboard.build_sections ~os:"Unix" ~run:(Some run) [] manifest None in Alcotest.(check int) "single spawn" 1 !calls; + Alcotest.(check string) "installed last" "Installed" (List.nth sections 0).name; let it = List.nth (List.nth sections 0).items 0 in Alcotest.(check string) "no version" "" it.installed_version; match it.status with @@ -228,6 +269,7 @@ let () = ; Alcotest.test_case "show fallback" `Quick show_fallback ; Alcotest.test_case "show fallback many" `Quick show_fallback_many ; Alcotest.test_case "basename match" `Quick basename_match + ; Alcotest.test_case "installed last" `Quick installed_last ; Alcotest.test_case "url stem match" `Quick url_stem_match ; Alcotest.test_case "PATH probe rescue" `Quick path_probe_rescue ; Alcotest.test_case "PATH probe miss" `Quick path_probe_miss From ab00abf137d9f2d87e8b133e9586a533d519e694 Mon Sep 17 00:00:00 2001 From: devkit Date: Wed, 30 Sep 2026 19:47:13 +0000 Subject: [PATCH 31/34] Stop child stderr leaking onto the terminal Both spawn backends move to open_process_args_full with concurrent pipe drains: the inventory runner drops stderr (silences uv's 'No tools installed' notice), the installer spawn merges it into the reported output per its combined-output contract. parse_uv explicitly skips the notice. --- lib/bootstrap.ml | 27 ++++++++++++++------------- lib/inventory.ml | 9 +++++++-- lib/proc.ml | 36 +++++++++++++++++++++++++----------- lib/proc.mli | 6 +++++- test/dune | 2 +- test/test_bootstrap.ml | 15 +++++++++++++++ test/test_inventory.ml | 5 +++++ test/test_proc.ml | 34 ++++++++++++++++++++++++++++++++++ 8 files changed, 106 insertions(+), 28 deletions(-) diff --git a/lib/bootstrap.ml b/lib/bootstrap.ml index c59b93d..3fc0c8b 100644 --- a/lib/bootstrap.ml +++ b/lib/bootstrap.ml @@ -20,23 +20,24 @@ failure: the installer needs winget's text even on non-zero exit. *) type spawn = string -> string list -> string * bool -(** Real backend on top of [Unix.open_process_args_in]. *) +(** Real backend on top of [Unix.open_process_args_full]. Stderr is + merged into the returned text (the "combined output" this type + promises), drained on a domain concurrently with stdout so neither + pipe can wedge the child, and never reaches our terminal. *) let real_spawn : spawn = fun prog args -> try let cmd = Array.of_list (prog :: args) in - let ic = Unix.open_process_args_in prog cmd in - let buf = Buffer.create 256 in - (try - while true do - Buffer.add_channel buf ic 4096 - done - with - | End_of_file -> ()); - let out = String.trim (Buffer.contents buf) in - match Unix.close_process_in ic with - | Unix.WEXITED 0 -> out, true - | _ -> out, false + let out_ic, in_oc, err_ic = + Unix.open_process_args_full prog cmd (Unix.environment ()) + in + let err_reader = Domain.spawn (fun () -> Proc.drain err_ic) in + let out = Proc.drain out_ic in + let err = Domain.join err_reader in + let combined = String.trim (String.trim out ^ "\n" ^ String.trim err) in + match Unix.close_process_full (out_ic, in_oc, err_ic) with + | Unix.WEXITED 0 -> combined, true + | _ -> combined, false with | _ -> "", false ;; diff --git a/lib/inventory.ml b/lib/inventory.ml index 90287d1..57c09a8 100644 --- a/lib/inventory.ml +++ b/lib/inventory.ml @@ -98,12 +98,17 @@ let parse_pipx (output : string) : app list = ;; (** [uv tool list]: [name vX.Y.Z] headers with [- exe] shim lines beneath. - [Failed to parse entry …] warnings are skipped. *) + [Failed to parse entry …] warnings and the empty-installation notice + ([No tools installed]) are skipped. *) let parse_uv (output : string) : app list = List.filter_map (fun raw -> let line = String.trim raw in - if line = "" || line.[0] = '-' || Strutil.contains_substring "Failed to parse" line + if + line = "" + || line.[0] = '-' + || line = "No tools installed" + || Strutil.contains_substring "Failed to parse" line then None else ( match fields line with diff --git a/lib/proc.ml b/lib/proc.ml index 722ad27..ee3ae79 100644 --- a/lib/proc.ml +++ b/lib/proc.ml @@ -7,21 +7,35 @@ success, [None] when the program is missing or exits non-zero. *) type runner = string -> string list -> string option -(** Real runner on top of [Unix.open_process_args_in]. *) +(** Drain [ic] to a string. Exposed so {!Bootstrap.real_spawn} shares the + same pipe handling. *) +let drain (ic : in_channel) : string = + let buf = Buffer.create 256 in + (try + while true do + Buffer.add_channel buf ic 4096 + done + with + | End_of_file -> ()); + Buffer.contents buf +;; + +(** Real runner on top of [Unix.open_process_args_full]. Stdout is + returned trimmed on exit 0; stderr is drained on a domain and + dropped, so chatty tools (uv's "No tools installed" notice) never + reach our terminal. Draining both pipes concurrently means a full + stderr pipe cannot wedge a child that is still writing stdout. *) let default_runner : runner = fun prog args -> try let cmd = Array.of_list (prog :: args) in - let ic = Unix.open_process_args_in prog cmd in - let buf = Buffer.create 256 in - (try - while true do - Buffer.add_channel buf ic 4096 - done - with - | End_of_file -> ()); - let out = Buffer.contents buf in - match Unix.close_process_in ic with + let out_ic, in_oc, err_ic = + Unix.open_process_args_full prog cmd (Unix.environment ()) + in + let err_reader = Domain.spawn (fun () -> drain err_ic) in + let out = drain out_ic in + let _stderr : string = Domain.join err_reader in + match Unix.close_process_full (out_ic, in_oc, err_ic) with | Unix.WEXITED 0 -> Some (String.trim out) | _ -> None with diff --git a/lib/proc.mli b/lib/proc.mli index 687a57e..f106eab 100644 --- a/lib/proc.mli +++ b/lib/proc.mli @@ -4,9 +4,13 @@ success, [None] when the program is missing or exits non-zero. *) type runner = string -> string list -> string option -(** Real runner on top of [Unix.open_process_args_in]. *) +(** Real runner on top of [Unix.open_process_args_full]: stderr is + drained, never inherited, and dropped. *) val default_runner : runner +(** Drain a channel to a string. *) +val drain : in_channel -> string + (** Memoized [winget list --verbose] fetcher with resetter: one winget invocation per 8s window per resolved path. *) val winget_list : runner -> (string -> string option) * (unit -> unit) diff --git a/test/dune b/test/dune index 26de7b7..c8f5efc 100644 --- a/test/dune +++ b/test/dune @@ -58,4 +58,4 @@ (test (name test_proc) - (libraries devkit alcotest)) + (libraries devkit alcotest unix)) diff --git a/test/test_bootstrap.ml b/test/test_bootstrap.ml index 9d1de49..aac0e1e 100644 --- a/test/test_bootstrap.ml +++ b/test/test_bootstrap.ml @@ -462,6 +462,19 @@ let test_cache_memoizes () = Alcotest.(check string) "reset clears" "" (get io2) ;; +(** [real_spawn] merges stderr into the returned text instead of leaking + it to the terminal, keeping the exit bit. *) +let test_real_spawn_merges_stderr () = + let prog, args = + if Sys.os_type = "Win32" || Sys.os_type = "Cygwin" + then "cmd", [ "/c"; "echo OUT & echo ERR 1>&2 & exit 1" ] + else "sh", [ "-c"; "echo OUT; echo ERR >&2; exit 1" ] + in + let out, ok = Devkit.Bootstrap.real_spawn prog args in + Alcotest.(check string) "both streams" "OUT\nERR" out; + Alcotest.(check bool) "exit bit" false ok +;; + let () = Alcotest.run "bootstrap" @@ -516,5 +529,7 @@ let () = ; Alcotest.test_case "missing exe" `Quick test_download_missing_exe ] ) ; "cache", [ Alcotest.test_case "memoizes + resets" `Quick test_cache_memoizes ] + ; ( "real_spawn" + , [ Alcotest.test_case "stderr merged" `Quick test_real_spawn_merges_stderr ] ) ] ;; diff --git a/test/test_inventory.ml b/test/test_inventory.ml index 25be828..1f6097a 100644 --- a/test/test_inventory.ml +++ b/test/test_inventory.ml @@ -52,6 +52,10 @@ let uv_skips () = let uv_empty () = check_apps "uv empty" [] (Inventory.parse_uv "") +let uv_notice () = + check_apps "uv empty-installation notice" [] (Inventory.parse_uv "No tools installed\n") +;; + let cargo () = check_apps "cargo rows" @@ -127,6 +131,7 @@ let () = ; Alcotest.test_case "uv" `Quick uv ; Alcotest.test_case "uv skips" `Quick uv_skips ; Alcotest.test_case "uv empty" `Quick uv_empty + ; Alcotest.test_case "uv notice" `Quick uv_notice ; Alcotest.test_case "cargo" `Quick cargo ; Alcotest.test_case "winget" `Quick winget ] ) diff --git a/test/test_proc.ml b/test/test_proc.ml index a43d604..7d05979 100644 --- a/test/test_proc.ml +++ b/test/test_proc.ml @@ -55,6 +55,39 @@ let win_basenames () = String.length s >= 9 && String.sub s (String.length s - 9) 9 = "|| exit 0") ;; +(** Child stderr never reaches our terminal: it is drained and dropped + while stdout is returned. The test's own stderr is parked in a temp + file around the spawn to prove nothing leaks. *) +let stderr_dropped () = + let prog, args = + if Sys.os_type = "Win32" || Sys.os_type = "Cygwin" + then "cmd", [ "/c"; "echo BOOM 1>&2 & echo hi" ] + else "sh", [ "-c"; "echo BOOM >&2; echo hi" ] + in + let tmp = Filename.temp_file "devkit-err-" ".log" in + let fd = Unix.openfile tmp [ Unix.O_WRONLY ] 0 in + let saved = Unix.dup Unix.stderr in + Unix.dup2 fd Unix.stderr; + let r = + match Proc.default_runner prog args with + | v -> + Unix.dup2 saved Unix.stderr; + v + | exception e -> + Unix.dup2 saved Unix.stderr; + raise e + in + Unix.close saved; + Unix.close fd; + Alcotest.(check (option string)) "stdout kept" (Some "hi") r; + let ic = open_in_bin tmp in + let n = in_channel_length ic in + let leaked = really_input_string ic n in + close_in ic; + Sys.remove tmp; + Alcotest.(check string) "stderr clean" "" leaked +;; + let () = Alcotest.run "proc" @@ -64,5 +97,6 @@ let () = ; Alcotest.test_case "unix empty" `Quick unix_empty ; Alcotest.test_case "win basenames" `Quick win_basenames ] ) + ; "runner", [ Alcotest.test_case "stderr dropped" `Quick stderr_dropped ] ] ;; From c38386fabceb6ea3472024cefa917c74e667ae0d Mon Sep 17 00:00:00 2001 From: devkit Date: Wed, 30 Sep 2026 20:22:38 +0000 Subject: [PATCH 32/34] Open link-like rows on Enter in any status Url rows open in every status; installed/manual GitHub rows open the repo page (new Install.repo_page, also the API-failure fallback instead of an error). Do_open carries the row item so reporting keys on the manifest value, and Opened outcomes keep the row status instead of demoting installed rows to manual. --- bin/tui_front.ml | 12 +++++---- lib/install.ml | 11 ++++++-- lib/install.mli | 5 ++++ lib/tui.ml | 24 ++++++++++++----- lib/tui.mli | 2 +- test/test_install.ml | 20 +++++++++++--- test/test_tui.ml | 62 +++++++++++++++++++++++++++++++++++++++++++- 7 files changed, 116 insertions(+), 20 deletions(-) diff --git a/bin/tui_front.ml b/bin/tui_front.ml index a707798..bb23447 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -109,14 +109,16 @@ let press_enter ~draw (deps : Install.deps) (st : Tui.state) : Tui.state Lwt.t = st item.Manifest.value (Install.install deps (kind_of item.Manifest.typ) item.Manifest.value update)) - | Tui.Do_open url -> + | Tui.Do_open (item, url) -> (match deps.Install.open_browser url with | Ok () -> - let o = { Install.value = url; status = Install.Opened } in - Lwt.return (Tui.apply_outcome st url o) + let value = item.Manifest.value in + let o = { Install.value; status = Install.Opened } in + Lwt.return (Tui.apply_outcome st value o) | Error e -> - let o = { Install.value = url; status = Install.Failed e } in - Lwt.return (Tui.apply_outcome st url o)) + let value = item.Manifest.value in + let o = { Install.value; status = Install.Failed e } in + Lwt.return (Tui.apply_outcome st value o)) ;; let viewport (w : int) (h : int) : int * int = max 1 w, max 1 (h - 3) diff --git a/lib/install.ml b/lib/install.ml index 92fba0e..7247a57 100644 --- a/lib/install.ml +++ b/lib/install.ml @@ -123,14 +123,21 @@ let install_winget (d : deps) (id : string) (update : bool) : outcome = else fail id ("winget " ^ String.concat " " args ^ " failed: " ^ String.trim out)) ;; +let repo_page (repo : string) : string = "https://github.com/" ^ repo + let install_github (d : deps) (repo : string) : outcome = match d.latest_release repo with - | Error e -> fail repo e + | Error _ -> + (* API unreachable: fall back to opening the repo page, mirroring + the no-asset fallback below, so a link-like row never dead-ends. *) + (match d.open_browser (repo_page repo) with + | Ok () -> succeed repo Opened + | Error e -> fail repo e) | Ok rel -> (match Gh.match_by_arch rel.Gh.assets with | None -> (* No Windows installer asset: open the release page instead. *) - let page = "https://github.com/" ^ repo ^ "/releases/latest" in + let page = repo_page repo ^ "/releases/latest" in (match d.open_browser page with | Ok () -> succeed repo Opened | Error e -> fail repo e) diff --git a/lib/install.mli b/lib/install.mli index 440f4a0..a5d3b2e 100644 --- a/lib/install.mli +++ b/lib/install.mli @@ -25,6 +25,11 @@ type deps = ; tools : Plugin.tool list } +(** The GitHub repo page for [repo] ([owner/name]). Used both as the + Enter target for installed link-like GitHub rows and as the fallback + when the release API is unreachable. *) +val repo_page : string -> string + (** Run a downloaded installer: [.msi] via [msiexec], [.exe] with silent switches, anything else refused. *) val run_installer : Bootstrap.spawn -> string -> (unit, string) result diff --git a/lib/tui.ml b/lib/tui.ml index 288e6a2..08a2a1f 100644 --- a/lib/tui.ml +++ b/lib/tui.ml @@ -94,20 +94,25 @@ let step (s : state) (a : action) : state = let selected (s : state) : entry option = List.nth_opt s.entries s.cursor (** What Enter does on the cursor row: installable statuses run the - installer, Manual rows open the URL, anything else is a no-op. *) + installer; Url rows always open the link; installed or manual GitHub + rows open the repo page; anything else is a no-op. [Do_open] carries + the row item for reporting plus the URL to open. *) type enter = | Do_install of item - | Do_open of string + | Do_open of item * string | Do_nothing let enter_action (s : state) : enter = match selected s with | None -> Do_nothing | Some e -> - (match e.item.status with - | NeedsUpdate | NotFound -> Do_install e.item - | Manual -> Do_open e.item.value - | Installed | New -> Do_nothing) + let it = e.item in + (match it.typ, it.status with + | _, (NeedsUpdate | NotFound) -> Do_install it + | Manifest.Url, _ -> Do_open (it, it.value) + | Manifest.GitHub, _ -> Do_open (it, Install.repo_page it.value) + | _, Manual -> Do_open (it, it.value) + | _, _ -> Do_nothing) ;; (** Row color by install status; the frontend maps this to terminal colors. *) @@ -268,7 +273,12 @@ let apply_outcome (s : state) (value : string) (o : Install.outcome) : state = let status = match o.Install.status with | Install.Installed | Install.Updated -> Installed - | Install.Opened -> Manual + | Install.Opened -> + (* Opening a link changes nothing about the row: keep whatever it + showed, so Enter on an installed URL keeps its green check. *) + (match selected s with + | Some e when e.item.value = value -> e.item.status + | _ -> Manual) | Install.Skipped _ | Install.Failed _ -> (match selected s with | Some e when e.item.value = value -> e.item.status diff --git a/lib/tui.mli b/lib/tui.mli index 4d28be5..6edcfa9 100644 --- a/lib/tui.mli +++ b/lib/tui.mli @@ -51,7 +51,7 @@ val color_of : status -> color type enter = | Do_install of item - | Do_open of string + | Do_open of item * string | Do_nothing val enter_action : state -> enter diff --git a/test/test_install.ml b/test/test_install.ml index 609c765..a207656 100644 --- a/test/test_install.ml +++ b/test/test_install.ml @@ -168,10 +168,19 @@ let test_github_no_asset_opens_page () = Alcotest.(check bool) "opened" true (r.Install.status = Install.Opened) ;; -let test_github_api_error () = - let d = base_deps ~latest:(fun _ -> Error "HTTP 404") () in +let test_github_api_error_opens_page () = + let opened = ref "" in + let d = + base_deps + ~latest:(fun _ -> Error "HTTP 404") + ~browser:(fun url -> + opened := url; + Ok ()) + () + in let r = Install.install d "github" "owner/tool" false in - Alcotest.(check bool) "failed" true (r.Install.status = Install.Failed "HTTP 404") + Alcotest.(check string) "repo page" "https://github.com/owner/tool" !opened; + Alcotest.(check bool) "opened" true (r.Install.status = Install.Opened) ;; let test_url_opens () = @@ -340,7 +349,10 @@ let () = ; ( "github" , [ Alcotest.test_case "happy path" `Quick test_github_happy ; Alcotest.test_case "no asset opens page" `Quick test_github_no_asset_opens_page - ; Alcotest.test_case "api error" `Quick test_github_api_error + ; Alcotest.test_case + "api error opens page" + `Quick + test_github_api_error_opens_page ] ) ; ( "dispatch" , [ Alcotest.test_case "url opens" `Quick test_url_opens diff --git a/test/test_tui.ml b/test/test_tui.ml index bcb977b..5dcb214 100644 --- a/test/test_tui.ml +++ b/test/test_tui.ml @@ -58,10 +58,68 @@ let enter_mapping () = | _ -> Alcotest.fail "needsupdate installs"); let s = Tui.step s Tui.Down in match Tui.enter_action s with - | Tui.Do_open u -> Alcotest.(check string) "url" "https://x" u + | Tui.Do_open (_, u) -> Alcotest.(check string) "url" "https://x" u | _ -> Alcotest.fail "manual opens" ;; +let litem typ status value = + { Manifest.typ; value; installed_version = "1.0"; available_version = ""; status } +;; + +let enter_opens_links () = + let open_at typ status value = + let s = + Tui.make + [ { Manifest.name = "t"; items = [ litem typ status value ] } ] + ~height:10 + ~width:80 + in + Tui.enter_action s + in + (match open_at Manifest.Url Manifest.Installed "https://example.com/dl" with + | Tui.Do_open (it, u) -> + Alcotest.(check string) "row kept" "https://example.com/dl" it.Manifest.value; + Alcotest.(check string) "url opens" "https://example.com/dl" u + | _ -> Alcotest.fail "installed url opens"); + (match open_at Manifest.GitHub Manifest.Installed "owner/tool" with + | Tui.Do_open (_, u) -> + Alcotest.(check string) "repo page" "https://github.com/owner/tool" u + | _ -> Alcotest.fail "installed github opens"); + (match open_at Manifest.GitHub Manifest.Manual "owner/tool" with + | Tui.Do_open (_, u) -> + Alcotest.(check string) "manual repo page" "https://github.com/owner/tool" u + | _ -> Alcotest.fail "manual github opens"); + match open_at Manifest.Winget Manifest.Installed "A.B" with + | Tui.Do_nothing -> () + | _ -> Alcotest.fail "installed winget is noop" +;; + +let open_keeps_status () = + (* Opening a link must not demote an installed row to manual. *) + let s = + Tui.make + [ { Manifest.name = "t" + ; items = [ litem Manifest.Url Manifest.Installed "https://x" ] + } + ] + ~height:10 + ~width:80 + in + let s = + Tui.apply_outcome + s + "https://x" + { Install.value = "https://x"; status = Install.Opened } + in + (match Tui.selected s with + | Some e -> + (match e.Tui.item.Manifest.status with + | Manifest.Installed -> () + | _ -> Alcotest.fail "open keeps installed") + | None -> Alcotest.fail "no selection"); + Alcotest.(check (option string)) "logs opened" (Some "https://x: opened") s.Tui.message +;; + let enter_notfound () = let s = Tui.make @@ -218,11 +276,13 @@ let () = ; ( "enter" , [ Alcotest.test_case "mapping" `Quick enter_mapping ; Alcotest.test_case "notfound" `Quick enter_notfound + ; Alcotest.test_case "opens links" `Quick enter_opens_links ] ) ; ( "outcome" , [ Alcotest.test_case "success" `Quick apply_success ; Alcotest.test_case "failure keeps" `Quick apply_failure_keeps ; Alcotest.test_case "failure logs reason" `Quick apply_failure_logs_reason + ; Alcotest.test_case "open keeps status" `Quick open_keeps_status ; Alcotest.test_case "end state green" `Quick apply_to_sections_reflects_session ; Alcotest.test_case "set message" `Quick set_message ] ) From 0c7f0d073226af9bb9f82908760070b3090df0d5 Mon Sep 17 00:00:00 2001 From: opencode Date: Wed, 30 Sep 2026 20:52:49 +0000 Subject: [PATCH 33/34] chore(deps): add Dependabot weekly version updates --- .github/dependabot.yml | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 .github/dependabot.yml diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..a1b0d30 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,13 @@ +version: 2 +updates: + - package-ecosystem: "github-actions" + directory: "/" + schedule: + interval: "weekly" + day: "monday" + groups: + minor-patch: + patterns: ["*"] + update-types: ["minor", "patch"] + open-pull-requests-limit: 5 + labels: ["dependencies"] From 8099505d4f5e9b66d1786d8ee57f17f6b50809fa Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Wed, 30 Sep 2026 20:59:25 +0000 Subject: [PATCH 34/34] Bump actions/checkout from 5 to 7 Bumps [actions/checkout](https://github.com/actions/checkout) from 5 to 7. - [Release notes](https://github.com/actions/checkout/releases) - [Changelog](https://github.com/actions/checkout/blob/main/CHANGELOG.md) - [Commits](https://github.com/actions/checkout/compare/v5...v7) --- updated-dependencies: - dependency-name: actions/checkout dependency-version: '7' dependency-type: direct:production update-type: version-update:semver-major ... Signed-off-by: dependabot[bot] --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7e29215..9ff3de4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -15,7 +15,7 @@ jobs: os: [ubuntu-latest, windows-latest] runs-on: ${{ matrix.os }} steps: - - uses: actions/checkout@v5 + - uses: actions/checkout@v7 - uses: ocaml/setup-ocaml@v3 with: @@ -56,7 +56,7 @@ jobs: fmt: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v5 + - uses: actions/checkout@v7 - uses: ocaml/setup-ocaml@v3 with: