diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index b497e9c..9ff3de4 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -48,7 +48,7 @@ jobs: - name: Upload windows exe if: matrix.os == 'windows-latest' - uses: actions/upload-artifact@v7 + uses: actions/upload-artifact@v4 with: name: devkit-windows path: _build/default/bin/devkit.exe diff --git a/bin/main.ml b/bin/main.ml index 51b6070..e562111 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,7 +1,7 @@ (** devkit CLI. Commands: default (dashboard), import, add, append [--new], export - [-o], doctor. The default command opens the interactive TUI on a terminal + [-o]. The default command opens the interactive TUI on a terminal and prints the plain-text dashboard when piped. *) open Devkit @@ -40,7 +40,7 @@ let real_fs : App.fs = 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; fetch } + { run = Proc.default_runner; fs = real_fs; bio = Bootstrap.real_io fetch } ;; (** Custom tools from [tools.sexp] (cwd) + config dir. A broken file @@ -111,7 +111,7 @@ let append_cmd = let tools = load_tools () in print_lines (if is_new - then App.run_append_new ~tools (make_env ()) () + then App.run_append_new ~tools (make_env ()) else App.run_append ~tools (make_env ()) ids) in Cmdliner.Cmd.v @@ -152,27 +152,12 @@ let export_cmd = Cmdliner.Term.(const run $ output $ only $ except) ;; -let doctor_cmd = - let run () = - match App.doctor_view (make_env ()) with - | Error e -> - prerr_endline ("devkit: " ^ e); - exit 1 - | Ok lines -> print_lines lines - in - Cmdliner.Cmd.v - (Cmdliner.Cmd.info - "doctor" - ~doc:"Check winget source hygiene and manifest InstallerUrl hosts") - Cmdliner.Term.(const run $ const ()) -;; - let () = let group = Cmdliner.Cmd.group ~default:default_term default_info - [ import_cmd; add_cmd; append_cmd; export_cmd; doctor_cmd ] + [ import_cmd; add_cmd; append_cmd; export_cmd ] in exit (Cmdliner.Cmd.eval group) ;; diff --git a/bin/tui_front.ml b/bin/tui_front.ml index ac1fce6..bb23447 100644 --- a/bin/tui_front.ml +++ b/bin/tui_front.ml @@ -3,19 +3,17 @@ 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. First paint is instant (cached inventory or a loading row); - a progressive refresh then repaints as each source lands on - parallel workers, followed by winget-show enrichment and upstream - tags — quit/resize stay live throughout. Installs and [u] - rescans 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. + notty) has a real Windows backend, so this frontend serves both + 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. *) -open Devkit +open Devkit open Lwt.Infix let style_of_color : Tui.color -> LTerm_style.t = function @@ -48,23 +46,6 @@ type ev = | Resized of LTerm_geom.size | Nothing -(** One background result: a landed source (apps plus the raw [winget - list] output, if it was winget's turn) or the resolved winget - binary. *) -type landing = - | Src of string * Dashboard.app list * string option - | Ens of string * string - -(** Progressive refresh accumulator: landed source results, the raw - winget output, the resolved winget binary, and jobs in flight. *) -type prog = - { landed : (string * Dashboard.app list) list - ; winget_out : string option - ; winget : string - ; winget_error : string - ; pending : int - } - let is_ctrl_q : Uchar.t -> bool = fun c -> Uchar.equal c (Uchar.of_char 'q') || Uchar.equal c (Uchar.of_char 'Q') ;; @@ -109,21 +90,10 @@ let classify : LTerm_event.t -> ev = function let kind_of : Manifest.item_type -> string = function | Manifest.Winget -> "winget" | Manifest.GitHub -> "github" - | Manifest.GitLab _ -> "gitlab" - | Manifest.Forgejo _ -> "forgejo" | Manifest.Url -> "url" - | Manifest.Registry -> "registry" | Manifest.Pm s -> s ;; -(** Self-hosted forge host for gitlab/forgejo rows; anything else - passes [""] and the callee defaults. *) -let host_of : Manifest.item_type -> string = function - | Manifest.GitLab h -> h - | Manifest.Forgejo h -> h - | _ -> "" -;; - let press_enter ~draw (deps : Install.deps) (st : Tui.state) : Tui.state Lwt.t = match Tui.enter_action st with | Tui.Do_nothing -> Lwt.return st @@ -138,73 +108,32 @@ let press_enter ~draw (deps : Install.deps) (st : Tui.state) : Tui.state Lwt.t = (Tui.apply_outcome st item.Manifest.value - (Install.install - deps - ~upstream:item.Manifest.upstream - ~host:(host_of item.Manifest.typ) - ~quarantine_days:item.Manifest.quarantine_days - (kind_of item.Manifest.typ) - item.Manifest.value - update)) + (Install.install deps (kind_of item.Manifest.typ) item.Manifest.value update)) | Tui.Do_open (item, url) -> (match deps.Install.open_browser url with | Ok () -> let value = item.Manifest.value in - let o = { Install.value; status = Install.Opened; warnings = [] } in + let o = { Install.value; status = Install.Opened } in Lwt.return (Tui.apply_outcome st value o) | Error e -> let value = item.Manifest.value in - let o = { Install.value; status = Install.Failed e; warnings = [] } 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) -(** [u]: full rescan (sources, show enrichment, upstream tags), then - the Installed-row update check for the non-winget PMs. Yank - warnings ride the log, not the footer. Paints a status line first, - then runs synchronously like installs (UI freezes). The fresh - inventory also rewrites the disk cache, so the next launch paints - current data instantly. *) -let press_u - ~draw - (env : App.env) - (tools : Plugin.tool list) - (load_lock : unit -> Lockfile.t) - (cache_file : string option) - (st : Tui.state) +(** [u]: check npm/pipx/uv/cargo updates for the Installed rows, then + 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 = - draw (Tui.set_message st "rescanning ...") + let items = List.map (fun e -> e.Tui.item) st.Tui.entries in + draw (Tui.set_message st "checking updates ...") >>= fun () -> Lwt.pause () - >>= fun () -> - let sections, winget_path, sources = App.load_manifest env.App.fs Manifest.filename in - let s = App.scan env ~override_path:winget_path ~extra:tools ~sources () in - let show id = - match App.winget_show env.App.bio s.App.winget id with - | "" -> None - | v -> Some v - in - let upstream_ver = App.upstream_ver_of_fetch env.App.fetch in - let dash = - Dashboard.build_sections - ~show - ~upstream_ver - ~run:(Some env.App.run) - s.App.apps - sections - s.App.info - in - (match cache_file with - | None -> () - | Some f -> Scan_cache.save f s.App.apps s.App.info); - let st = Tui.remake st dash in - let items = List.map (fun e -> e.Tui.item) st.Tui.entries in - let updates, warns = - Update.check_all ~run:env.App.run ~fetch:env.App.fetch ~lock:(load_lock ()) items - in - Lwt.return (Tui.log_lines (Tui.apply_updates st updates) warns) + >>= 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 @@ -223,9 +152,7 @@ let draw_all (term : LTerm.t) (st : Tui.state) : unit Lwt.t = ;; let empty_scan_message (s : App.scan) : string option = - if s.App.sources_error <> "" - then Some ("bad sources; " ^ s.App.sources_error) - else if s.App.apps <> [] + if s.App.apps <> [] then None else if s.App.winget <> "" then Some ("empty scan; winget at " ^ s.App.winget) @@ -241,65 +168,23 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = so the wait looks alive past the alternate screen. *) prerr_endline "scanning installed software..."; flush stderr; - let sections, winget_path, sources = App.load_manifest env.App.fs Manifest.filename in - let cache_file = Scan_cache.cache_path () in - let cached = Option.bind cache_file Scan_cache.load in - let fetch_exe, _ = Proc.winget_list env.App.run in - let fetch = Fetch.curl_fetch Proc.default_runner in - (* Worker bodies never raise: a failed source contributes nothing, - exactly like {!Inventory.scan_all}. *) - let guarded : type a. string -> a -> (unit -> a) -> a = - fun what dflt f -> - try f () with - | e -> - prerr_endline ("devkit: " ^ what ^ " failed: " ^ Printexc.to_string e); - dflt - in - (* One source on a worker thread: blocking spawns only, no Lwt. - [winget_exe] is the ensure-resolved binary ("" = PATH lookup). *) - let scan_one (winget_exe : string) (name : string) : Dashboard.app list * string option = - Inventory.time_src name (fun () -> - if name = "winget" - then ( - match fetch_exe winget_exe with - | None -> [], None - | Some out -> Inventory.parse_winget out, Some out) - else if name = "registry" - then - if Sys.os_type = "Win32" then Inventory.scan_reg env.App.run, None else [], None - else ( - match - List.find_opt - (fun (t : Plugin.tool) -> t.Plugin.name = name) - (Inventory.built_ins @ tools) - with - | None -> [], None - | Some t -> Inventory.scan_tool env.App.run t, None)) - in - let ensure_one () : string * string = - Inventory.time_src "ensure" (fun () -> - match Bootstrap.ensure ~override_path:winget_path env.App.bio with - | Ok w -> w, "" - | Error err -> "", err) - in - let apps_of (srcs : string list) (p : prog) : Dashboard.app list = - List.concat_map (fun n -> List.assoc_opt n p.landed |> Option.value ~default:[]) srcs - in - (* Cached paint: the previous run's inventory merged without any - spawn (no show, no upstream, no PATH probe). Guarded so a - corrupt cache degrades to the loading row instead of killing - startup. *) - let cached_dash = - guarded "cached merge" [] (fun () -> - match cached with - | None -> [] - | Some snap -> - let info = - if snap.Scan_cache.info = [] - then None - else Some (Scan_cache.to_info_map snap.Scan_cache.info) - in - Dashboard.build_sections snap.Scan_cache.apps sections info) + 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 cleanup term mode = LTerm.disable_mouse term @@ -325,7 +210,7 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = let vw, vh = viewport geom.LTerm_geom.cols geom.LTerm_geom.rows in (* Main loop once the scan lands: draws, then waits. Events that change nothing skip the repaint. *) - let main_loop deps load_lock init = + 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 = @@ -335,8 +220,7 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = | 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 tools load_lock cache_file 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 @@ -347,265 +231,47 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = draw_loop init in let loading = - match cached with - | None -> - Tui.set_message - (Tui.make [] ~height:vh ~width:vw) - "scanning installed software..." - | Some _ -> - Tui.set_message (Tui.make cached_dash ~height:vh ~width:vw) "refreshing..." + Tui.set_message + (Tui.make [] ~height:vh ~width:vw) + "scanning installed software..." in - let cur_dash = ref cached_dash in draw_all term loading >>= fun () -> - let stream, push = Lwt_stream.create () in - let cancels = ref [] in - (* One worker per job; each pushes exactly one landing, then - the forwarding fiber ends. The [>>=] continuation runs on - the Lwt thread, so [push] is safe there. *) - let spawn (f : unit -> landing) : unit = - let job = Lwt_preemptive.detach f () in - cancels := (fun () -> Lwt.cancel job) :: !cancels; - Lwt.async (fun () -> - Lwt.catch - (fun () -> - job - >>= fun r -> - push (Some r); - Lwt.return_unit) - (function - | Lwt.Canceled -> Lwt.return_unit - | e -> Lwt.fail e)) - in - let cancel_all () = List.iter (fun c -> c ()) !cancels in - let make_deps () = - let read_file p = - match env.App.fs.read_file p with - | None -> Error "not found" - | Some t -> Ok t - in - let load_lock () = - match env.App.fs.read_file Lockfile.filename with - | None -> [] - | Some t -> Lockfile.parse t - in - let deps = - Install.real_deps - fetch - ~winget_override:winget_path - ~read_file - ~write_file:env.App.fs.write_file - () - in - deps, load_lock - in - (* Single-job wait (show / upstream phases): repaint once when - the merge lands, quit/resize stay live. *) - let rec wait_one - (st : Tui.state) - (job : Manifest.section list Lwt.t) - (apply : Manifest.section list -> Tui.state -> Tui.state) - : [ `Done of Tui.state | `Quit ] Lwt.t + 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 - [ (job >|= fun r -> `Job r); (LTerm.read_event term >|= fun e -> `Event e) ] + [ (scan_job >|= fun r -> `Scan r) + ; (LTerm.read_event term >|= fun e -> `Event e) + ] >>= function - | `Job r -> - let st = apply r st in - draw_all term st >>= fun () -> Lwt.return (`Done st) + | `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 job; - cancel_all (); + 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_one st job apply - | _ -> wait_one st job apply) - in - (* Source phase: repaint per landing until every worker has - reported. Winget waits for ensure (portable installs live - off PATH), everything else races it. *) - let rec wait_sources (srcs : string list) (p : prog) (st : Tui.state) - : [ `Done of prog * Tui.state | `Quit ] Lwt.t - = - if p.pending = 0 - then Lwt.return (`Done (p, st)) - else - Lwt.pick - [ (Lwt_stream.get stream >|= fun r -> `Data r) - ; (LTerm.read_event term >|= fun e -> `Event e) - ] - >>= function - | `Data None -> Lwt.return (`Done (p, st)) - | `Data (Some (Src (name, apps, out))) -> - let p = - { p with - landed = (name, apps) :: p.landed - ; winget_out = - (match out with - | None -> p.winget_out - | Some _ -> out) - ; pending = p.pending - 1 - } - in - let apps_all = apps_of srcs p in - let info = App.info_of p.winget_out apps_all in - let dash = - Inventory.time_src "merge" (fun () -> - Dashboard.build_sections ~run:(Some env.App.run) apps_all sections info) - in - cur_dash := dash; - let st = Tui.set_message (Tui.remake st dash) "refreshing..." in - draw_all term st >>= fun () -> wait_sources srcs p st - | `Data (Some (Ens (w, err))) -> - let p = { p with winget = w; winget_error = err; pending = p.pending - 1 } in - let p = - if List.mem "winget" srcs - then ( - spawn (fun () -> - let apps, out = - guarded "scan:winget" ([], None) (fun () -> scan_one w "winget") - in - Src ("winget", apps, out)); - { p with pending = p.pending + 1 }) - else p - in - wait_sources srcs p st - | `Event ev -> - (match classify ev with - | Quit -> - cancel_all (); - 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_sources srcs p st - | _ -> wait_sources srcs p st) + draw_all term st >>= fun () -> wait_scan st + | _ -> wait_scan st) in - match App.resolve_sources sources ~tools with - | Error err -> - (* No workers: straight to the main loop with the error. *) - let s = - { App.apps = [] - ; info = None - ; winget = "" - ; winget_error = "" - ; sources_error = err - } - in - let dash = Dashboard.build_sections [] sections None in - cur_dash := dash; - let init = Tui.make dash ~height:loading.Tui.height ~width:loading.Tui.width in - let init = - match empty_scan_message s with - | None -> init - | Some m -> Tui.set_message init m - in - let deps, load_lock = make_deps () in - main_loop deps load_lock init - >>= fun final -> - cleanup term mode >>= fun () -> Lwt.return (`Done (dash, s, final)) - | Ok srcs -> - spawn (fun () -> - let w, err = guarded "ensure" ("", "ensure failed") ensure_one in - Ens (w, err)); - let non_winget = List.filter (fun n -> n <> "winget") srcs in - List.iter - (fun n -> - spawn (fun () -> - let apps, out = - guarded ("scan:" ^ n) ([], None) (fun () -> scan_one "" n) - in - Src (n, apps, out))) - non_winget; - let p = - { landed = [] - ; winget_out = None - ; winget = "" - ; winget_error = "" - ; pending = 1 + List.length non_winget - } - in - wait_sources srcs p loading - >>= (function - | `Quit -> Lwt.return `Quit - | `Done (p, st) -> - let apps = apps_of srcs p in - let info = App.info_of p.winget_out apps in - (match cache_file with - | None -> () - | Some f -> Scan_cache.save f apps info); - let s = - { App.apps - ; info - ; winget = p.winget - ; winget_error = p.winget_error - ; sources_error = "" - } - in - let show id = - match App.winget_show env.App.bio p.winget id with - | "" -> None - | v -> Some v - in - let upstream_ver = App.upstream_ver_of_fetch fetch in - let show_job = - Lwt_preemptive.detach - (fun () -> - guarded "show" !cur_dash (fun () -> - Inventory.time_src "show" (fun () -> - Dashboard.build_sections - ~show - ~run:(Some env.App.run) - apps - sections - info))) - () - in - wait_one st show_job (fun dash st -> - cur_dash := dash; - Tui.set_message (Tui.remake st dash) "refreshing...") - >>= (function - | `Quit -> Lwt.return `Quit - | `Done st -> - let up_job = - Lwt_preemptive.detach - (fun () -> - guarded "upstream" !cur_dash (fun () -> - Inventory.time_src "upstream" (fun () -> - Dashboard.build_sections - ~show - ~upstream_ver - ~run:(Some env.App.run) - apps - sections - info))) - () - in - wait_one st up_job (fun dash st -> - cur_dash := dash; - Tui.set_message (Tui.remake st dash) "refreshing...") - >>= (function - | `Quit -> Lwt.return `Quit - | `Done st -> - let st = { st with Tui.message = None } in - let deps, load_lock = make_deps () in - let init = - match empty_scan_message s with - | None -> st - | Some m -> Tui.set_message st m - in - main_loop deps load_lock init - >>= fun final -> - cleanup term mode >>= fun () -> Lwt.return (`Done (!cur_dash, s, final))))) - ) + wait_scan loading) in match outcome with | `Quit -> () @@ -620,16 +286,14 @@ let run ~(tools : Plugin.tool list) (env : App.env) : unit = runs (and piped stdin) never pause. *) if s.App.apps = [] then ( - let diag = - if s.App.sources_error <> "" - then "sources error: " ^ s.App.sources_error - else if s.App.winget <> "" + 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 " ^ diag); + print_endline (" no installed software found\n " ^ winget); try if Unix.isatty Unix.stdin then ( diff --git a/lib/app.ml b/lib/app.ml index 5295a34..ca4461f 100644 --- a/lib/app.ml +++ b/lib/app.ml @@ -13,12 +13,12 @@ - [--new] appends every newly-detected app. - [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; gitlab; forgejo; registry]. *) + - pm order: [winget; npm; pipx; uv; cargo]. *) open Manifest open Dashboard -let pm_order = [ "winget"; "npm"; "pipx"; "uv"; "cargo"; "gitlab"; "forgejo"; "registry" ] +let pm_order = [ "winget"; "npm"; "pipx"; "uv"; "cargo" ] type fs = { read_file : string -> string option @@ -30,21 +30,17 @@ type env = { run : Proc.runner ; fs : fs ; bio : Bootstrap.io - ; fetch : Fetch.fetch } let lower s = String.lowercase_ascii s -(** Missing/unparseable file yields empty sections and the default - sources. Skipped rows are reported on stderr, so a typo'd id never - vanishes silently. *) -let load_manifest (fs : fs) (path : string) : section list * string * string list = +(** Missing/unparseable file yields empty sections. *) +let load_manifest (fs : fs) (path : string) : section list * string = match fs.read_file path with - | None -> [], "", Manifest.default_sources + | None -> [], "" | Some text -> let r = Manifest.parse text in - List.iter (fun w -> prerr_endline ("devkit: warning: " ^ w)) r.warnings; - r.sections, r.winget_path, r.sources + r.sections, r.winget_path ;; (** Best-effort winget info from the scan when [winget list] fails. *) @@ -66,26 +62,6 @@ let info_from_scan (apps : app list) : Winget_parse.info Winget_parse.IdMap.t = apps ;; -(** Winget info table from raw [winget list] output, falling back to - scan rows when winget failed; [None] when both are empty. Pulled - out of [scan] so the TUI's progressive loop rebuilds it as sources - land instead of waiting for the full scan. *) -let info_of (winget_out : string option) (apps : app list) - : Winget_parse.info Winget_parse.IdMap.t option - = - match winget_out 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 -;; - (** [winget show --id ] → repo's latest version, "" on failure. *) let winget_show (bio : Bootstrap.io) (winget : string) (id : string) : string = if winget = "" @@ -115,50 +91,11 @@ let winget_show (bio : Bootstrap.io) (winget : string) (id : string) : string = find lines)) ;; -(** Vendor truth for [upstream] rows: [(provider, repo)] → latest - release tag. [None] on any failure, so the merge keeps the PM's reading. *) -let upstream_ver_of_fetch (fetch : Fetch.fetch) (prov : Provider.t) (repo : string) - : string option - = - match Provider.latest fetch prov repo with - | Ok rel when rel.Gh.tag_name <> "" -> Some rel.Gh.tag_name - | _ -> None -;; - -(** 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) -;; - -(** [resolve_sources]: validate raw [sources] names against the known - PMs ([order_for tools]), matching case-insensitively but returning - canonical spellings so the scan's exact-match lookup works. An - empty list means the key was absent: the defaults. An unknown name - is a hard error — the scan then skips every spawn so nothing - half-runs on a typo'd source. *) -let resolve_sources (raw : string list) ~(tools : Plugin.tool list) - : (string list, string) result - = - let known = order_for tools in - let find n = List.find_opt (fun k -> lower k = lower n) known in - match List.find_opt (fun n -> find n = None) raw with - | Some bad -> - Error (Printf.sprintf "unknown source: %s (known: %s)" bad (String.concat ", " known)) - | None -> - let srcs = List.filter_map find raw in - Ok (if srcs = [] then Manifest.default_sources else srcs) -;; - type scan = { apps : app list ; info : Winget_parse.info Winget_parse.IdMap.t option ; winget : string ; winget_error : string - ; sources_error : string } (** [DEVKIT_TIMING=1] prints per-phase startup timings to stderr, so a @@ -177,38 +114,33 @@ let timed (label : string) (f : unit -> 'a) : 'a = both, so a command spawns winget once per 8s window. A failed ensure degrades to winget-less operation ([""] + the error in [winget_error]) instead of hiding the cause. *) -let scan - (e : env) - ?(os : string = Sys.os_type) - ~(override_path : string) - ~(extra : Plugin.tool list) - ~(sources : string list) - () - : scan - = - match resolve_sources sources ~tools:extra with - | Error err -> - { apps = []; info = None; winget = ""; winget_error = ""; sources_error = err } - | Ok srcs -> - let winget, winget_error = - timed "ensure" (fun () -> - match Bootstrap.ensure ~override_path e.bio with - | Ok w -> w, "" - | Error err -> "", err) - in - let fetch, _ = Proc.winget_list e.run in - let apps = - timed "scan_all" (fun () -> - Inventory.scan_all - e.run - ~os - ~winget:(fun () -> fetch winget) - ~extra - ~sources:srcs - ()) - in - let info = timed "info" (fun () -> info_of (fetch winget) apps) in - { apps; info; winget; winget_error; sources_error = "" } +let scan (e : env) ~(override_path : string) ~(extra : Plugin.tool list) : scan = + let winget, winget_error = + timed "ensure" (fun () -> + match Bootstrap.ensure ~override_path e.bio with + | Ok w -> w, "" + | Error err -> "", err) + 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) + in + let info = + 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; winget_error } ;; let to_dashboard_apps (apps : app list) : Dashboard.app list = @@ -226,29 +158,18 @@ let default_view (e : env) ~(tools : Plugin.tool list) : string = past the TUI's alternate screen, so the wait looks alive. *) prerr_endline "scanning installed software..."; flush stderr; - let sections, winget_path, sources = load_manifest e.fs Manifest.filename in - let s = scan e ~override_path:winget_path ~extra:tools ~sources () 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 if v = "" then None else Some v in - let upstream_ver = upstream_ver_of_fetch e.fetch in let dash = timed "build" (fun () -> - build_sections - ~show - ~upstream_ver - ~run:(Some e.run) - (to_dashboard_apps s.apps) - sections - s.info) + build_sections ~show ~run:(Some e.run) (to_dashboard_apps s.apps) sections s.info) in let body = render dash in - if s.sources_error <> "" - then ( - prerr_endline ("devkit: error: " ^ s.sources_error); - body ^ "\n error: " ^ s.sources_error) - else if s.apps <> [] + if s.apps <> [] then body else ( let winget = @@ -268,25 +189,19 @@ let import_view (e : env) ?(tools : Plugin.tool list = []) (path : string) | None -> Error ("open: " ^ path) | Some text -> let r = Manifest.parse text in - List.iter (fun w -> prerr_endline ("devkit: warning: " ^ w)) r.warnings; - let s = scan e ~override_path:r.winget_path ~extra:tools ~sources:r.sources () in - if s.sources_error <> "" - then Error s.sources_error - else ( - let show id = - let v = winget_show e.bio s.winget id in - if v = "" then None else Some v - in - let upstream_ver = upstream_ver_of_fetch e.fetch in - Ok - (render - (build_sections - ~show - ~upstream_ver - ~run:(Some e.run) - (to_dashboard_apps s.apps) - r.sections - s.info))) + 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 + ~run:(Some e.run) + (to_dashboard_apps s.apps) + r.sections + s.info)) ;; (** [appendSelected]: persists items under a "Newly detected" section, @@ -305,9 +220,6 @@ let append_selected (fs : fs) (path : string) (items : item list) : (unit, strin ^ Manifest.to_string { sections = [ { name = "Newly detected"; items = ordered } ] ; winget_path = "" - ; warnings = [] - ; sources = [] - ; quarantine = 0 } in fs.append_file path text) @@ -331,330 +243,178 @@ let new_items ?(extra : bool = false) (sections : section list) : item list = (** [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 sections, _, sources = load_manifest e.fs Manifest.filename in - let s = scan e ~override_path:"" ~extra:tools ~sources () in - if s.sources_error <> "" - then [ " error: " ^ s.sources_error ] - else ( - 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 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 Manifest.filename items with - | Error e -> emit (" error: " ^ e) - | Ok () -> - emit - (Printf.sprintf - " appended %d app(s) to %s" - (List.length items) - Manifest.filename))); - List.rev !msgs) + 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 Manifest.filename 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 Manifest.filename items with + | Error e -> emit (" error: " ^ e) + | Ok () -> + emit + (Printf.sprintf + " appended %d app(s) to %s" + (List.length items) + Manifest.filename))); + 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 = []) - ?(os : string = Sys.os_type) - (ids : string list) +let run_append (e : env) ?(tools : Plugin.tool list = []) (ids : string list) : string list = if ids <> [] then run_add e ~tools ids else ( - let sections, _, sources = load_manifest e.fs Manifest.filename in - let s = scan e ~os ~override_path:"" ~extra:tools ~sources () in - if s.sources_error <> "" - then [ " error: " ^ s.sources_error ] - else ( - 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 - (* Registry rows are discovery-only: they stay in the table but - never persist — an id guess would rot on the next rename. *) - let keepable = List.filter (fun it -> it.typ <> Registry) items in - let skipped = List.length items - List.length keepable in - let note = - if skipped = 0 - then [] - else [ Printf.sprintf " %d registry row(s) need manual ids" skipped ] - in - if keepable = [] - then [ " nothing new to append" ] @ note - else ( - match append_selected e.fs Manifest.filename keepable with - | Error e -> [ " error: " ^ e ] @ note - | Ok () -> - [ Printf.sprintf - " appended %d app(s) to %s" - (List.length keepable) - Manifest.filename - ] - @ note))) -;; - -(** [runAppendNew] (--new): newly-detected apps only (no pending updates). *) -let run_append_new (e : env) ~(tools : Plugin.tool list) ?(os : string = Sys.os_type) () - : string list - = - let sections, _, sources = load_manifest e.fs Manifest.filename in - let s = scan e ~os ~override_path:"" ~extra:tools ~sources () in - if s.sources_error <> "" - then [ " error: " ^ s.sources_error ] - else ( + let s = scan e ~override_path:"" ~extra:tools in + let sections, _ = load_manifest e.fs Manifest.filename in let dash = build_sections ~run:(Some e.run) (to_dashboard_apps s.apps) sections s.info in - let items = new_items dash in - let keepable = List.filter (fun it -> it.typ <> Registry) items in - let skipped = List.length items - List.length keepable in - let note = - if skipped = 0 - then [] - else [ Printf.sprintf " %d registry row(s) need manual ids" skipped ] - in - if keepable = [] - then [ " no newly detected apps" ] @ note + let items = new_items ~extra:true dash in + if items = [] + then [ " nothing new to append" ] else ( - match append_selected e.fs Manifest.filename keepable with - | Error e -> [ " error: " ^ e ] @ note + match append_selected e.fs Manifest.filename items with + | Error e -> [ " error: " ^ e ] | Ok () -> [ Printf.sprintf " appended %d app(s) to %s" - (List.length keepable) + (List.length items) Manifest.filename - ] - @ note)) + ])) +;; + +(** [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 Manifest.filename 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" ] + else ( + match append_selected e.fs Manifest.filename items with + | Error e -> [ " error: " ^ e ] + | 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 manifest alone. Scans with [~sources:[]] (the defaults): a - full snapshot independent of the manifest's key, filtered only by - [~only]/[~except]. *) + in the manifest alone. *) let json_sibling (output : string) : string = if Filename.check_suffix output ".toml" then Filename.chop_suffix output ".toml" ^ ".json" else output ^ ".json" ;; -(** [doctor_view]: winget supply-chain hygiene. Reports the configured - winget sources (msstore expected), then cross-checks every manifest - winget row's community-manifest InstallerUrl hosts against the - upstream pin's forge host. Unpinned rows report hosts without a - verdict — there is no vendor to compare against. *) -let doctor_view (e : env) : (string list, string) result = - let sections, winget_path, _ = load_manifest e.fs Manifest.filename in - let winget = - match Bootstrap.ensure ~override_path:winget_path e.bio with - | Ok p -> p - | Error _ -> "" - in - let src_lines = - if winget = "" - then [ "source hygiene: winget unavailable (skipped)" ] - else ( - match e.run winget [ "source"; "list" ] with - | None -> [ "source hygiene: query failed" ] - | Some out -> - let verdict = - if Strutil.contains_substring "msstore" (lower out) - then "source hygiene: ok (msstore present)" - else "source hygiene: note (no msstore source configured)" - in - let rows = - List.filter_map - (fun ln -> - let t = String.trim ln in - if t = "" then None else Some (" " ^ t)) - (String.split_on_char '\n' out) - in - verdict :: rows) - in - let winget_rows = - List.filter - (fun it -> it.typ = Winget) - (List.concat_map (fun (sec : section) -> sec.items) sections) - in - (* Release assets ride CDNs, not the repo host: GitHub serves from - objects/release-assets hosts, forges from their own host. *) - let expected_of = function - | Provider.GitHub -> - [ "github.com" - ; "objects.githubusercontent.com" - ; "release-assets.githubusercontent.com" - ] - | Provider.GitLab h | Provider.Forgejo h -> [ lower h ] - in - let prov_host = function - | Provider.GitHub -> "github.com" - | Provider.GitLab h | Provider.Forgejo h -> h - in - let host_match h x = - h = x - || (String.length h > String.length x - && String.sub h (String.length h - String.length x - 1) (String.length x + 1) - = "." ^ x) - in - let check_row (it : item) : string list = - let lookup () = - match Winget_manifest.list_versions e.fetch it.value with - | Error msg -> Error (Printf.sprintf "manifest lookup failed (%s)" msg) - | Ok vs -> - (match Winget_manifest.pick_max vs with - | None -> Error "manifest has no versions" - | Some v -> Winget_manifest.hosts_of e.fetch it.value v) - in - match lookup () with - | Error problem -> [ Printf.sprintf " %s: %s" it.value problem ] - | Ok [] -> [ Printf.sprintf " %s: manifest has no InstallerUrl" it.value ] - | Ok hosts -> - let hs = String.concat ", " hosts in - if it.upstream = "" - then - [ Printf.sprintf - " %s: serves from %s (no upstream pin: cannot verify)" - it.value - hs - ] - else ( - let prov, _ = Provider.of_upstream it.upstream in - let expected = expected_of prov in - if List.exists (fun h -> List.exists (host_match (lower h)) expected) hosts - then [ Printf.sprintf " %s: ok (%s)" it.value hs ] - else - [ Printf.sprintf - " %s: MISMATCH serves from %s, vendor is %s" - it.value - hs - (prov_host prov) - ]) - in - let cross = - if winget_rows = [] - then [ "manifest cross-check: no winget rows" ] - else "manifest cross-check:" :: List.concat (Proc.par_map8 check_row winget_rows) - in - Ok (src_lines @ cross) +(** 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 = []) - ?(os : string = Sys.os_type) ?(only : string list = []) ?(except : string list = []) (output : string) : string list = - let s = scan e ~os ~override_path:"" ~extra:tools ~sources:[] () in - if s.sources_error <> "" - then [ " error: " ^ s.sources_error ] + let s = scan e ~override_path:"" ~extra:tools in + 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 keep pm = (only = [] || List.mem pm only) && not (List.mem pm except) in - (* Registry rows are discovery-only: no stable id to write back. *) - let reg_skipped = - List.filter (fun (a : app) -> a.pm = "registry" && keep a.pm) s.apps + let sections = + List.filter_map + (fun pm -> + let apps = List.filter (fun (a : app) -> a.pm = pm) 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 - let apps = List.filter (fun (a : app) -> keep a.pm && a.pm <> "registry") s.apps in - let note = - if reg_skipped = [] - then [] - else - [ Printf.sprintf - " %d registry app(s) skipped (need manual ids)" - (List.length reg_skipped) - ] - in - if apps = [] - then [ " no installed software found" ] @ note - else ( - let sections = - List.filter_map - (fun pm -> - let apps = List.filter (fun (a : app) -> a.pm = pm) 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 = ""; warnings = []; sources = []; quarantine = 0 }) - with - | Error e -> [ " error: " ^ e ] - | Ok () -> - let json_path = json_sibling output 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 + 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 + 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" ] @ note - else ( - match e.fs.write_file json_path (Winget_json.to_string apps) with - | Error e -> [ base; " winget json skipped: " ^ e ] @ note - | Ok () -> - [ base - ; Printf.sprintf - "wrote %s (%d winget apps, winget import -i ready)" - json_path - (List.length winget_apps) - ] - @ note))) + if winget_apps = [] + then [ base; " no winget apps, json skipped" ] + else ( + match e.fs.write_file json_path (Winget_json.to_string 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 index f635b77..10ca940 100644 --- a/lib/app.mli +++ b/lib/app.mli @@ -12,7 +12,6 @@ type env = { run : Proc.runner ; fs : fs ; bio : Bootstrap.io - ; fetch : Fetch.fetch } type scan = @@ -20,66 +19,26 @@ type scan = ; info : Winget_parse.info Winget_parse.IdMap.t option ; winget : string ; winget_error : string - ; sources_error : string } -(** Missing/unparseable file yields empty sections and default sources. *) -val load_manifest : fs -> string -> Manifest.section list * string * string list +(** Missing/unparseable file yields empty sections. *) +val load_manifest : fs -> string -> Manifest.section list * string val winget_show : Bootstrap.io -> string -> string -> string - -(** Winget info table from raw [winget list] output (scan-row fallback, - [None] when both are empty). *) -val info_of - : string option - -> Dashboard.app list - -> Winget_parse.info Winget_parse.IdMap.t option - -(** Vendor truth for [upstream] rows: [(provider, repo)] → latest - release tag ([None] on any failure). *) -val upstream_ver_of_fetch : Fetch.fetch -> Provider.t -> string -> string option - -val scan - : env - -> ?os:string - -> override_path:string - -> extra:Plugin.tool list - -> sources:string list - -> unit - -> scan - +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 -> 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 - -(** Winget supply-chain hygiene: configured sources plus a per-row - manifest-InstallerUrl vs upstream-vendor cross-check. *) -val doctor_view : env -> (string list, string) result - -val run_append - : env - -> ?tools:Plugin.tool list - -> ?os:string - -> string list - -> string list - -val run_append_new : env -> tools:Plugin.tool list -> ?os:string -> unit -> 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 -(** Case-insensitive validation of raw [sources] names against - [order_for tools]; [] means absent (the defaults). *) -val resolve_sources - : string list - -> tools:Plugin.tool list - -> (string list, string) result - val run_export : env -> ?tools:Plugin.tool list - -> ?os:string -> ?only:string list -> ?except:string list -> string diff --git a/lib/dashboard.ml b/lib/dashboard.ml index 4076365..8c7a462 100644 --- a/lib/dashboard.ml +++ b/lib/dashboard.ml @@ -77,38 +77,11 @@ let candidates (it : item) : string list = | Url -> let file = cut_at [ '?'; '#' ] (after_last [ '/'; '\\' ] v) in [ file; strip_ext file ] - | Registry -> - (* Display names carry spaces and never match scan keys or PATH - entries; the token rescue below handles them. *) - [] - | Winget | GitHub | GitLab _ | Forgejo _ | Pm _ -> [ after_last [ '.'; '/'; '\\' ] v ] + | Winget | GitHub | Pm _ -> [ after_last [ '.'; '/'; '\\' ] v ] in List.sort_uniq String.compare (List.filter (fun s -> s <> "") (v :: shorts)) ;; -(** Word tokens: lowercase alphanumeric runs. Registry [DisplayName]s - ("VLC media player") and manifest nicks ("vlc") meet here. *) -let toks_of_words (s : string) : string list = - s - |> String.lowercase_ascii - |> String.map (fun c -> - if ('a' <= c && c <= 'z') || ('0' <= c && c <= '9') then c else ' ') - |> String.split_on_char ' ' - |> List.filter (fun w -> w <> "") -;; - -(** Short matchable form: the id tail for repo/winget rows, the file - stem for links. ["VideoLAN.VLC" → "vlc"]. *) -let nick (it : item) : string = - match it.typ with - | Url -> strip_ext (cut_at [ '?'; '#' ] (after_last [ '/'; '\\' ] it.value)) - | _ -> after_last [ '.'; '/'; '\\' ] it.value -;; - -let subset (small : string list) (big : string list) : bool = - small <> [] && List.for_all (fun t -> List.mem t big) small -;; - (** 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. @@ -117,14 +90,9 @@ let subset (small : string list) (big : string list) : bool = 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). - - Rows of any kind pinned to an [upstream] repo compare against the - vendor's release tag ([?upstream_ver]) instead of their PM's - reading; a failed lookup keeps the PM reading. *) + leftover artifact, never real content). *) let build_sections ?(show : string -> string option = fun _ -> None) - ?(upstream_ver : Provider.t -> string -> string option = fun _ _ -> None) ?(run : Proc.runner option = None) ?(os : string = Sys.os_type) (apps : app list) @@ -134,20 +102,7 @@ let build_sections = let lower s = String.lowercase_ascii s in let scan_lookup : (string, app) Hashtbl.t = Hashtbl.create 64 in - (* [apps] arrives in sources order; earliest source wins ties, so the - manifest's order picks the label. *) - List.iter (fun a -> Hashtbl.replace scan_lookup (lower a.name) a) (List.rev apps); - (* Registry word index for the token rescue below. *) - let reg_idx : (string list * app) list = - List.filter_map - (fun (a : app) -> - if a.pm = "registry" then Some (toks_of_words a.name, a) else None) - apps - in - let reg_hit (it : item) : app option = - let small = toks_of_words (nick it) in - List.find_map (fun (toks, a) -> if subset small toks then Some a else None) reg_idx - 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 @@ -196,8 +151,7 @@ let build_sections } else { it with status = Installed } | None -> { it with status = NotFound }) - | GitHub | GitLab _ | Forgejo _ | Url | Pm _ | Registry -> - { it with status = Manual } + | GitHub | Url | Pm _ -> { it with status = Manual } in let it = if it.status <> Installed && it.status <> NeedsUpdate @@ -205,12 +159,7 @@ let build_sections match scan_hit it with | Some a -> { it with installed_version = a.version; status = Installed } - | None -> - (match reg_hit it with - | Some a -> - { it with installed_version = a.version; status = Installed } - | None -> - if path_hit it then { it with status = Installed } else it)) + | None -> if path_hit it then { it with status = Installed } else it) else it in if it.typ = Winget && it.status = Installed @@ -269,53 +218,6 @@ let build_sections }) pkgs_sections in - (* 2b. Upstream truth: rows of any kind pinned to an official repo - compare their installed version against the vendor's release tag - instead of trusting their PM's reading. Each repo is queried once, - up to 8 in flight; a failed query keeps the PM reading (offline - fallback). Rows without an installed version skip the check: with - nothing installed there is nothing to compare. *) - let upstream_ids = - List.concat_map - (fun sec -> - List.filter_map - (fun it -> - if it.upstream <> "" && (it.status = Installed || it.status = NeedsUpdate) - then Some (Provider.of_upstream it.upstream) - else None) - sec.items) - pkgs_sections - |> List.sort_uniq compare - in - let upstream_table : (Provider.t * string, string option) Hashtbl.t = - Hashtbl.create (max 1 (List.length upstream_ids)) - in - List.iter2 - (fun (prov, repo) tag -> Hashtbl.replace upstream_table (prov, repo) tag) - upstream_ids - (Proc.par_map8 (fun (prov, repo) -> upstream_ver prov repo) upstream_ids); - let pkgs_sections = - List.map - (fun sec -> - { sec with - items = - List.map - (fun it -> - if it.upstream = "" || it.installed_version = "" - then it - else ( - match - Hashtbl.find_opt upstream_table (Provider.of_upstream it.upstream) - with - | None | Some None -> it - | Some (Some tag) -> - if Strutil.is_newer_version it.installed_version tag - then { it with available_version = tag; status = NeedsUpdate } - else { it with available_version = ""; status = Installed })) - sec.items - }) - pkgs_sections - in (* 3. Non-manifest installed apps with updates → pending updates. *) let value_in_manifest name = List.exists @@ -344,8 +246,6 @@ let build_sections ; installed_version = inf.version ; available_version = inf.available ; status = NeedsUpdate - ; upstream = "" - ; quarantine_days = 0 } :: !man_updates)) ids); @@ -411,46 +311,9 @@ let build_sections ; installed_version = inf.version ; available_version = avail ; status = New - ; upstream = "" - ; quarantine_days = 0 } :: !new_items))) ids); - (* 5b. Registry orphans: uninstall entries matching no manifest row - join Newly detected as discovery-only [Registry] rows (they carry - no install id, so append/export skip them). Suppressed when the - entry already covers a manifest row or a winget orphan — same - token rule as the rescue, so one machine app yields one row. *) - let man_nicks = - List.concat_map - (fun sec -> List.map (fun it -> toks_of_words (nick it)) sec.items) - pkgs_sections - in - let new_nicks = List.map (fun it -> toks_of_words (nick it)) !new_items in - List.iter - (fun (a : app) -> - if a.pm <> "registry" - then () - else ( - let toks = toks_of_words a.name in - let covered = - Hashtbl.mem pkg_names (lower a.name) - || List.exists (fun small -> subset small toks) man_nicks - || List.exists (fun small -> subset small toks) new_nicks - in - if not covered - then - new_items - := { typ = Registry - ; value = a.name - ; installed_version = a.version - ; available_version = "" - ; status = New - ; upstream = "" - ; quarantine_days = 0 - } - :: !new_items)) - apps; 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. diff --git a/lib/dashboard.mli b/lib/dashboard.mli index 64f8c96..11dbb44 100644 --- a/lib/dashboard.mli +++ b/lib/dashboard.mli @@ -16,15 +16,10 @@ val format_ver : Manifest.item -> string [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: - [Sys.os_type]) so tests stay platform-independent. [upstream_ver] - maps an [(provider, upstream repo)] pair to its latest release tag: - rows of any kind pinned to an official repo compare against the vendor tag - instead of their PM's reading, and a failed lookup keeps the PM - reading. Matching is candidate-based (full value, + [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) - -> ?upstream_ver:(Provider.t -> string -> string option) -> ?run:Proc.runner option -> ?os:string -> app list diff --git a/lib/dune b/lib/dune index e286739..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 update provider verify lockfile winget_manifest scan_cache)) + (modules manifest winget_parse dashboard proc inventory strutil fetch hash gh zipx bootstrap install app winget_json plugin tui update)) diff --git a/lib/gh.ml b/lib/gh.ml index 11a1b9d..7f13f2c 100644 --- a/lib/gh.ml +++ b/lib/gh.ml @@ -11,7 +11,6 @@ type asset = type release = { tag_name : string - ; published_at : string ; assets : asset list } @@ -32,8 +31,6 @@ let asset_of_yojson (j : Yojson.Basic.t) : asset = 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:"" - ; published_at = - j |> member "published_at" |> to_string_option |> Option.value ~default:"" ; assets = j |> member "assets" |> to_list |> List.map asset_of_yojson } ;; @@ -43,9 +40,8 @@ let parse_release (body : string) : (release, string) result = | Yojson.Json_error msg -> Error ("decode: " ^ msg) ;; -(** Latest release for [owner/repo] (or a full GitHub URL, canonicalized). *) +(** Latest release for [owner/repo]. *) let latest_release (fetch : Fetch.fetch) (repo : string) : (release, string) result = - let repo = Strutil.canon_repo repo in 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" ] diff --git a/lib/gh.mli b/lib/gh.mli index 2080cec..b06ae5a 100644 --- a/lib/gh.mli +++ b/lib/gh.mli @@ -8,7 +8,6 @@ type asset = type release = { tag_name : string - ; published_at : string (** ISO-8601 release timestamp; "" when the API omits it *) ; assets : asset list } diff --git a/lib/install.ml b/lib/install.ml index 3bba90f..7247a57 100644 --- a/lib/install.ml +++ b/lib/install.ml @@ -36,23 +36,19 @@ let status_to_string = function type outcome = { value : string ; status : status - ; warnings : string list } -let succeed ?(warnings = []) value status = { value; status; warnings } -let fail ?(warnings = []) value msg = { value; status = Failed msg; warnings } +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 : Provider.t -> string -> (Gh.release, string) result + ; latest_release : string -> (Gh.release, string) result ; download : url:string -> (string, string) result - ; fetch : Fetch.fetch ; run_installer : string -> (unit, string) result - ; lock_load : unit -> Lockfile.t - ; lock_save : Lockfile.t -> unit ; tools : Plugin.tool list } @@ -127,155 +123,31 @@ 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/" ^ Strutil.canon_repo repo +let repo_page (repo : string) : string = "https://github.com/" ^ repo -(** Quarantine: refuse releases younger than [days]. A missing or - unparseable date skips the check — there is nothing to judge age by. *) -let quarantine_block (days : int) (rel : Gh.release) : string option = - if days <= 0 || rel.Gh.published_at = "" - then None - else ( - match Strutil.parse_iso_date rel.Gh.published_at with - | None -> None - | Some pub -> - let tm = Unix.gmtime (Unix.time ()) in - let today = tm.Unix.tm_year + 1900, tm.Unix.tm_mon + 1, tm.Unix.tm_mday in - let age = Strutil.days_between pub today in - if age < days - then - Some - (Printf.sprintf - "quarantined: %s released %s (%dd old, needs %dd)" - rel.Gh.tag_name - rel.Gh.published_at - age - days) - else None) -;; - -(** Post-download pipeline: tag-immutability lock, signature, checksum, - attestation, signer continuity, then run and record. *) -let install_verified - (d : deps) - ~(value : string) - ~(os : string) - (prov : Provider.t) - (rel : Gh.release) - (asset : Gh.asset) - (path : string) - done_status - : outcome - = - let lock = d.lock_load () in - let locked = Lockfile.find lock value in - let sha = - match Hash.sha256_file path with - | Ok s -> s - | Error _ -> "" - in - match locked with - | Some e - when e.Lockfile.tag = rel.Gh.tag_name - && e.Lockfile.sha256 <> "" - && sha <> "" - && e.Lockfile.sha256 <> sha -> - (* Same tag, different bytes: the vendor re-cut the release. *) - Verify.discard path; - let short s = String.sub s 0 (min 12 (String.length s)) in - fail - value - (Printf.sprintf - "tag %s changed bytes since first seen (lock %s, now %s)" - rel.Gh.tag_name - (short e.Lockfile.sha256) - (short sha)) - | _ -> - let sig_v = Verify.signature ~os ~spawn:d.spawn path in - let sum_v = - Verify.checksum ~fetch:d.fetch rel.Gh.assets ~asset:asset.Gh.name ~path - in - let att_v = Verify.attestation ~os ~spawn:d.spawn ~repo:value path in - let thumb = Verify.signer ~os ~spawn:d.spawn path in - let signer_warn = - match locked, thumb with - | Some e, Some t when e.Lockfile.thumbprint <> "" && e.Lockfile.thumbprint <> t -> - Some - (Printf.sprintf - "signer changed for %s: was %s, now %s" - value - e.Lockfile.thumbprint - t) - | _ -> None - in - let warns = - List.filter_map - (function - | Verify.Warn w -> Some w - | _ -> None) - [ sig_v; sum_v; att_v ] - @ (match signer_warn with Some w -> [ w ] | None -> []) - in - (match sig_v, sum_v, att_v with - | Verify.Block m, _, _ | _, Verify.Block m, _ | _, _, Verify.Block m -> - Verify.discard path; - fail ~warnings:warns value m - | _ -> - (match d.run_installer path with - | Error e -> fail ~warnings:warns value e - | Ok () -> - let host = - match prov with - | Provider.GitHub -> "github.com" - | Provider.GitLab h | Provider.Forgejo h -> h - in - let thumbprint = match thumb with Some t -> t | None -> "" in - d.lock_save - (Lockfile.upsert - lock - Lockfile. - { id = value - ; tag = rel.Gh.tag_name - ; sha256 = sha - ; thumbprint - ; host - }); - succeed ~warnings:warns value done_status)) -;; - -let install_repo - (d : deps) - ~(value : string) - ~(os : string) - ~quarantine_days - (prov : Provider.t) - (repo : string) - (update : bool) - : outcome - = - let done_status = if update then Updated else Installed in - match d.latest_release prov repo with +let install_github (d : deps) (repo : string) : outcome = + match d.latest_release repo with | 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 (Provider.page_url prov repo) with - | Ok () -> succeed value Opened - | Error e -> fail value e) + (match d.open_browser (repo_page repo) with + | Ok () -> succeed repo Opened + | Error e -> fail repo e) | Ok rel -> - (match quarantine_block quarantine_days rel with - | Some msg -> fail value msg + (match Gh.match_by_arch rel.Gh.assets with | None -> - (match Gh.match_by_arch rel.Gh.assets with - | None -> - (* No Windows installer asset: open the release feed instead - (the repo page for GitLab: no stable latest permalink). *) - let page = Provider.page_url prov repo ^ Provider.release_suffix prov in - (match d.open_browser page with - | Ok () -> succeed value Opened - | Error e -> fail value e) - | Some asset -> - (match d.download ~url:asset.Gh.browser_download_url with - | Error e -> fail value e - | Ok path -> install_verified d ~value ~os prov rel asset path done_status))) + (* No Windows installer asset: open the release page instead. *) + let page = repo_page 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}] @@ -296,75 +168,26 @@ let install_plugin (d : deps) (t : Plugin.tool) (id : string) (update : bool) : ;; (** Dispatch an install/update for one manifest entry. [kind] is one of - ["winget"], ["github"], ["gitlab"], ["forgejo"], ["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. A non-empty [upstream] diverts winget, github, - gitlab, forgejo, and plugin rows to the vendor's release instead of - their PM (the provider is parsed out of the pin); outcomes still - carry the manifest value. Url rows always open the page. [host] - carries the self-hosted forge host for gitlab/forgejo rows - (defaulting to gitlab.com / codeberg.org). [quarantine_days] refuses - releases younger than that many days (0 disables). Tag, digest, and - signer are recorded to the lockfile on success; a re-cut tag or a - changed signer surfaces on the next install. *) -let install - (d : deps) - ?(upstream : string = "") - ?(host : string = "") - ?(os : string = Sys.os_type) - ?(quarantine_days : int = 0) - (kind : string) - (value : string) - (update : bool) - : outcome - = + ["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" -> - if upstream <> "" - then ( - let prov, repo = Provider.of_upstream upstream in - install_repo d ~value ~os ~quarantine_days prov repo update) - else install_winget d value update - | "github" -> - let prov, repo = - if upstream <> "" then Provider.of_upstream upstream else Provider.GitHub, value - in - install_repo d ~value ~os ~quarantine_days prov repo update - | "gitlab" -> - let host = if host = "" then "gitlab.com" else host in - let repo = if upstream <> "" then snd (Provider.of_upstream upstream) else value in - install_repo d ~value ~os ~quarantine_days (Provider.GitLab host) repo update - | "forgejo" -> - let host = if host = "" then "codeberg.org" else host in - let repo = if upstream <> "" then snd (Provider.of_upstream upstream) else value in - install_repo d ~value ~os ~quarantine_days (Provider.Forgejo host) repo update + | "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 -> - if upstream <> "" - then ( - let prov, repo = Provider.of_upstream upstream in - install_repo d ~value ~os ~quarantine_days prov repo update) - else ( - match Plugin.find other d.tools with - | None -> - { value; status = Skipped ("unsupported type \"" ^ other ^ "\""); warnings = [] } - | Some t -> install_plugin d t value update) + (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, lockfile in the working dir. *) -let real_deps - (fetch : Fetch.fetch) - ~winget_override - ~(read_file : string -> (string, string) result) - ~(write_file : string -> string -> (unit, string) result) - () - : deps - = + unavailable), curl fetcher, real spawns. *) +let real_deps (fetch : Fetch.fetch) ~winget_override () : deps = let io = Bootstrap.real_io fetch in { winget = (fun () -> @@ -373,17 +196,9 @@ let real_deps | Error _ -> "") ; spawn = Bootstrap.real_spawn ; open_browser = real_open_browser Bootstrap.real_spawn - ; latest_release = Provider.latest fetch + ; latest_release = Gh.latest_release fetch ; download = (fun ~url -> Hash.download_and_verify fetch Hash.No_expected url) - ; fetch ; run_installer = run_installer Bootstrap.real_spawn - ; lock_load = - (fun () -> - match read_file Lockfile.filename with - | Error _ -> [] - | Ok text -> Lockfile.parse text) - ; lock_save = - (fun t -> ignore (write_file Lockfile.filename (Lockfile.to_string t))) ; tools = Inventory.built_ins } ;; diff --git a/lib/install.mli b/lib/install.mli index 4f7e0af..a5d3b2e 100644 --- a/lib/install.mli +++ b/lib/install.mli @@ -1,5 +1,4 @@ -(** Package installation across winget, forge releases (GitHub, GitLab, - Forgejo-family) and plain URLs. *) +(** Package installation across winget, GitHub releases and plain URLs. *) type status = | Installed @@ -13,7 +12,6 @@ val status_to_string : status -> string type outcome = { value : string ; status : status - ; warnings : string list } (** Injected surface. {!real_deps} wires production backends. *) @@ -21,12 +19,9 @@ type deps = { winget : unit -> string ; spawn : Bootstrap.spawn ; open_browser : string -> (unit, string) result - ; latest_release : Provider.t -> string -> (Gh.release, string) result + ; latest_release : string -> (Gh.release, string) result ; download : url:string -> (string, string) result - ; fetch : Fetch.fetch ; run_installer : string -> (unit, string) result - ; lock_load : unit -> Lockfile.t - ; lock_save : Lockfile.t -> unit ; tools : Plugin.tool list } @@ -40,32 +35,5 @@ val repo_page : string -> string val run_installer : Bootstrap.spawn -> string -> (unit, string) result val real_open_browser : ?os:string -> Bootstrap.spawn -> string -> (unit, string) result - -(** Dispatch an install/update for one manifest entry. A non-empty - [upstream] diverts winget, github, gitlab, forgejo, and plugin rows - to the vendor's release (the provider is parsed out of the pin). - [host] carries the self-hosted forge host for gitlab/forgejo rows. - [os] selects the platform for the Authenticode check (Win32 only). - Vendor-direct downloads are signature- and checksum-verified per - SecDoc; soft findings ride [warnings], blocks are [Failed]. - [quarantine_days] refuses releases younger than that many days. - Successful vendor installs record tag, digest, and signer via - [lock_save]; a re-cut tag fails the next install. *) -val install - : deps - -> ?upstream:string - -> ?host:string - -> ?os:string - -> ?quarantine_days:int - -> string - -> string - -> bool - -> outcome - -val real_deps - : Fetch.fetch - -> winget_override:string - -> read_file:(string -> (string, string) result) - -> write_file:(string -> string -> (unit, string) result) - -> unit - -> deps +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 index df74c68..57c09a8 100644 --- a/lib/inventory.ml +++ b/lib/inventory.ml @@ -6,11 +6,7 @@ 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. - - registry ([reg query … /s]): entries split on blank lines; - [DisplayName] without [DisplayVersion] keeps [""]; entries without - [DisplayName] and non-string value types are skipped; multi-word - data rejoins on single spaces. *) + - uv ([uv tool list]) scans like pipx. *) open Dashboard @@ -146,41 +142,6 @@ let parse_cargo (output : string) : app list = (lines_of output) ;; -(** [reg query /s]: one app per [DisplayName] ([pm] = - ["registry"]). Key headers and value types ride along ignored: only - string ([REG_SZ]/[REG_EXPAND_SZ]) [DisplayName]/[DisplayVersion] - lines matter. *) -let parse_reg (output : string) : app list = - let entries = ref [] in - let cur = ref [] in - let flush () = - if !cur <> [] then entries := List.rev !cur :: !entries; - cur := [] - in - List.iter - (fun raw -> if String.trim raw = "" then flush () else cur := raw :: !cur) - (lines_of output); - flush (); - List.filter_map - (fun lines -> - let name = ref "" in - let ver = ref "" in - List.iter - (fun raw -> - match fields (String.trim raw) with - | key :: typ :: rest - when rest <> [] && (typ = "REG_SZ" || typ = "REG_EXPAND_SZ") -> - let data = String.concat " " rest in - (match String.lowercase_ascii key with - | "displayname" -> name := data - | "displayversion" -> ver := data - | _ -> ()) - | _ -> ()) - lines; - if !name = "" then None else Some { name = !name; version = !ver; pm = "registry" }) - (List.rev !entries) -;; - (** 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. *) @@ -277,12 +238,8 @@ let built_ins : Plugin.tool list = ;; (** Names that custom tools may not take (shadowing would silently - change a built-in scan). [registry] is reserved although it scans - bespoke (three hives, one sweep): a custom tool under that name - would hijack the sources toggle and the install skip. *) -let reserved_names : string list = - "registry" :: List.map (fun (t : Plugin.tool) -> t.name) built_ins -;; + 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. *) @@ -292,127 +249,29 @@ let scan_tool (run : Proc.runner) (t : Plugin.tool) : app list = | Some out -> t.parse out ;; -(** Windows uninstall sweep: machine + 32-bit view + current user. - One spawn per hive; a missing hive (or failure) contributes nothing. - Deduped by lowercase name, hive order wins. *) -let scan_reg (run : Proc.runner) : app list = - let hives = - [ "HKLM\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall" - ; "HKLM\\SOFTWARE\\WOW6432Node\\Microsoft\\Windows\\CurrentVersion\\Uninstall" - ; "HKCU\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall" - ] - in - let apps = - List.concat_map - (fun hive -> - match run "reg" [ "query"; hive; "/s" ] with - | None -> [] - | Some out -> parse_reg out) - hives - in - let seen = Hashtbl.create 64 in - List.filter - (fun (a : app) -> - let k = String.lowercase_ascii a.name in - if Hashtbl.mem seen k - then false - else ( - Hashtbl.replace seen k (); - true)) - apps -;; - -(** Order-preserving dedup: repeated source names scan once. *) -let dedup (xs : string list) : string list = - let seen = Hashtbl.create 8 in - List.filter - (fun x -> - if Hashtbl.mem seen x - then false - else ( - Hashtbl.replace seen x (); - true)) - xs -;; - -(** Per-source phase timing for [DEVKIT_TIMING=1] (see {!App.timed}): - one line per source, formatted before printing so concurrent - domains don't interleave mid-line. *) -let time_src (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 - prerr_endline - (Printf.sprintf - "[timing] src %s: %.0fms" - label - ((Unix.gettimeofday () -. t0) *. 1000.0)); - r -;; - -(** Full scan order follows [sources]: winget, npm, pipx, uv, cargo, - registry, then [extra] custom tools in file order — each slotted - where its name appears (unknown names are ignored here; {!App} - rejects them before the scan starts). 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. - [registry] only spawns on Windows ([reg] exists nowhere else). *) - +(** Full scan order: winget, npm, pipx, uv, cargo, then [extra] custom + 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) - ?(os : string = Sys.os_type) - ?(sources : string list = Manifest.default_sources) - () : app list = - let sources = dedup sources in let winget_dom = Domain.spawn (fun () -> - time_src "winget" (fun () -> - if not (List.mem "winget" sources) - then [] - else ( - match winget () with - | None -> [] - | Some out -> parse_winget out))) + match winget () with + | None -> [] + | Some out -> parse_winget out) in - let reg_dom = - Domain.spawn (fun () -> - time_src "registry" (fun () -> - if List.mem "registry" sources && os = "Win32" then scan_reg run else [])) - in - let tool_of name = - List.find_opt - (fun (t : Plugin.tool) -> t.name = name) - ([ npm_tool; pipx_tool; uv_tool; cargo_tool ] @ extra) - in - let tools = List.filter_map tool_of sources in - let tool_apps = - Proc.par_map8 - (fun (t : Plugin.tool) -> time_src t.name (fun () -> scan_tool run t)) - tools + let apps = + List.concat + (Proc.par_map8 + (scan_tool run) + ([ npm_tool; pipx_tool; uv_tool; cargo_tool ] @ extra)) in - let winget_apps = Domain.join winget_dom in - let reg_apps = Domain.join reg_dom in - List.concat_map - (fun name -> - if name = "winget" - then winget_apps - else if name = "registry" - then reg_apps - else ( - match - List.find_opt - (fun ((t : Plugin.tool), _) -> t.name = name) - (List.combine tools tool_apps) - with - | Some (_, apps) -> apps - | None -> [])) - sources + Domain.join winget_dom @ apps ;; diff --git a/lib/inventory.mli b/lib/inventory.mli index 8187fc8..4489039 100644 --- a/lib/inventory.mli +++ b/lib/inventory.mli @@ -5,21 +5,13 @@ 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 -val parse_reg : string -> Dashboard.app list -(** Windows uninstall sweep: machine + 32-bit view + current user. *) -val scan_reg : Proc.runner -> Dashboard.app list - -(** Full scan order follows [sources] (default: {!Manifest.default_sources}); - [registry] only spawns on Windows. [winget] is the memoized - [winget list] fetch. *) +(** 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 - -> ?os:string - -> ?sources:string list - -> unit -> Dashboard.app list (** The five built-ins as plugin entries (scan order). *) @@ -30,7 +22,3 @@ val reserved_names : string list (** Run one plugin tool; missing binary means skipped. *) val scan_tool : Proc.runner -> Plugin.tool -> Dashboard.app list - -(** [DEVKIT_TIMING=1] phase timer shared by the scan and the TUI's - progressive loop: one [[timing]