From e10c775950f981fe8baba4273e0fadd2d6a2e30b Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Tue, 23 Jun 2026 15:59:36 +0200 Subject: [PATCH 1/9] Record survey findings in code-improvements backlog Concretize candidate #5 (survey large modules) into two evidence-backed splits: extract a GlobalConfig store from WorktreeApi.fs (#7) and split the DashboardState slice / CanvasWatchers out of RefreshScheduler.fs (#8). Note that strict-FP smells are already clean. --- docs/spec/future/code-improvements.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/docs/spec/future/code-improvements.md b/docs/spec/future/code-improvements.md index 737ee88..9849dba 100644 --- a/docs/spec/future/code-improvements.md +++ b/docs/spec/future/code-improvements.md @@ -37,8 +37,10 @@ its own worktree. This file is the entry point; detailed designs live in their o | 2 | **Port management** — centralize/derive the dev/prod/canvas/vite port assignments | `docs/spec/future/port-management.md` | Idea | | 3 | **Canvas roadmap items** — follow-on canvas-pane enhancements | `docs/spec/future/canvas-roadmap.md` | Idea | | 4 | **Process: guard against spec drift** — a lightweight check (or review rule) that flags `Key Files` references to moved/renamed modules so docs can't silently rot after refactors | — | Idea | -| 5 | **Survey other large modules** — apply the same view/state/update extraction lens to the next-largest files (server-side `RefreshScheduler.fs`, `WorktreeApi.fs`, etc.) if they mix concerns | — | Idea (needs investigation) | +| 5 | **Survey other large modules** — *investigated.* The two largest production modules are `WorktreeApi.fs` (870 L) and `RefreshScheduler.fs` (741 L); both mix concerns. Concrete splits broken out as #7 and #8 below. (Strict-FP smells are already clean: no stray `let mutable`/loops/`null` in production; `Dictionary` only at cache/registry boundaries.) | — | Done (survey) | | 6 | **Remoting CSRF / Origin hardening** — pipeline-level Origin/Referer (and optional custom-header) check so a cross-origin browser page can't drive the unauthenticated loopback Fable.Remoting API (covers the dangerous pre-existing process-launching endpoints, not just watched-roots) | `docs/spec/future/remoting-csrf-hardening.md` | Idea (from focused-review) | +| 7 | **Extract a `GlobalConfig` store from `WorktreeApi.fs`** — lift the ~250 lines of machine-level JSON config read/modify/write (single-writer lock, atomic temp-file replace, missing-vs-empty `worktreeRoots` semantics, plus the canvas/collapsed-repos/last-viewed-hashes/editor readers+writers) into its own module so the largest production file is left with just the `IWorktreeApi` wiring. The concern already has dedicated tests (`ConfigWriterTests.fs`, `WorktreeRootsConfigTests.fs`) but the code lives in the API module. Behavior-preserving; ripple is mechanical (3 refs in `Program.fs` + 4 test files). | — | Idea (from survey — recommended next) | +| 8 | **Split `RefreshScheduler.fs`** — the scheduler module also carries the `DashboardState`/`StateMsg`/`processMessage` state slice (~190 L) and an embedded `CanvasWatchers` filesystem-watcher module (~110 L). Lift one or both out of the scheduling loop into their own files (vertical-slice seam, like canvas/mascot/activity). Behavior-preserving but heavier ripple (26 refs to `RefreshScheduler.DashboardState`/`StateMsg`/`PerRepoState` in `WorktreeApi.fs`). | — | Idea (from survey) | > Add new candidates here as they surface (often from focused-review findings). Keep the list > honest: remove ones that turn out not to be worth it, and record why in the relevant spec. From 283f209c6199cd72c5d3038f4564934b70963baa Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Wed, 24 Jun 2026 16:11:21 +0200 Subject: [PATCH 2/9] Add spec for extracting GlobalConfig store from WorktreeApi.fs Planning spec for code-improvement candidate #7: lift the ~250-line machine-level config.json read/modify/write block out of WorktreeApi.fs into a dedicated Server.GlobalConfig module. Behavior-preserving; atomic move with all consumers retargeted (no compat shims). --- docs/spec/global-config-store.md | 115 +++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) create mode 100644 docs/spec/global-config-store.md diff --git a/docs/spec/global-config-store.md b/docs/spec/global-config-store.md new file mode 100644 index 0000000..bcba4a0 --- /dev/null +++ b/docs/spec/global-config-store.md @@ -0,0 +1,115 @@ +# GlobalConfig Store — extract machine-level config I/O from WorktreeApi + +## Goals + +- Lift the machine-level `~/.treemon/config.json` read/modify/write code out of `src/Server/WorktreeApi.fs` + into a dedicated `src/Server/GlobalConfig.fs` module, so the largest production module is left with + just the `IWorktreeApi` wiring and `DashboardResponse` assembly it is named for. +- Give the persistence concern a named home that matches its already-separate test suites + (`ConfigWriterTests.fs`, `WorktreeRootsConfigTests.fs`). +- **Behavior-preserving.** No change to config file format, key semantics, locking, atomic-write + behavior, or any `IWorktreeApi` response. The full suite (Unit + Fast + E2E) stays green; E2E asserts + on DOM/CSS, so an identical render proves the move is behaviorally invisible. + +## Expected Behavior + +This is a pure extraction — every externally observable behavior is preserved. The invariants that must +still hold after the move: + +- **Config location.** `globalConfigDir` resolves `TREEMON_CONFIG_DIR` (test override) else + `~/.treemon`; `config.json` lives there. Unchanged. +- **Single serialized writer.** Every write still funnels through the one in-process lock + (`globalConfigLock`) and the atomic temp-file-then-replace path (`updateConfigAtPath`). No write may + bypass the lock. +- **Never destroy data.** An unparseable `config.json` is still backed up to a timestamped + `*.corrupt-` sibling and a fresh object started; a write only touches the named keys, leaving every + other key intact. +- **`worktreeRoots` missing-vs-empty distinction.** `tryReadWorktreeRootsConfig` still returns `None` + for a missing/malformed key and `Some []` for a present empty list; `readWorktreeRootsConfig` still + flattens missing → `[]`. The startup resolver in `Program.fs` depends on this distinction. +- **Roots add/remove semantics.** `addRootToConfig` still normalizes, requires an existing directory, + is an idempotent no-op for an already-watched path, and surfaces persistence failures as `Error`. + `removeRootFromConfig` still errors on an unwatched path and allows removing a root whose directory no + longer exists. +- **Typed accessors.** `collapsedRepos`, `canvasPaneOpen`, `canvasPosition`, `lastViewedHashes`, and the + editor command/name reader return the same values for the same files as before. + +## Technical Approach + +### New module: `src/Server/GlobalConfig.fs` + +Move the whole config block (currently `WorktreeApi.fs` lines ~178–433) verbatim into +`module Server.GlobalConfig`. It has no dependency on anything else in `WorktreeApi.fs`; its only inputs +are `Log`, `Shared` domain types (`RepoId`, `CanvasPosition`), and `Shared.PathUtils.pathEquals` — all of +which compile before it. Functions to move: + +- **Generic JSON store (private helpers):** `globalConfigPath`, `withConfigDocument`, `readGlobalConfig`, + `globalConfigLock`, `tryParseJsonObject`, `updateGlobalConfig`, plus `canonicalRoot` / `tryNormalizeRoot`. +- **Public surface (consumed outside the module):** `globalConfigDir`, `updateConfigAtPath`, + `readCollapsedRepos`, `writeCollapsedRepos`, `tryReadWorktreeRootsConfig`, `readWorktreeRootsConfig`, + `writeWorktreeRoots`, `addRootToConfig`, `removeRootFromConfig`, `readCanvasPaneOpen`, + `writeCanvasPaneOpen`, `readCanvasPosition`, `writeCanvasPosition`, `readLastViewedHashes`, + `writeLastViewedHashes`, `getEditorConfig`. + +Helpers used only inside the module stay `private`; everything consumed by `WorktreeApi.fs`, +`Program.fs`, or tests is `internal` (assembly-scoped, and `InternalsVisibleTo Tests` keeps the test +references working). Keep the existing doc-comments with the functions they describe. + +### Compile order — `src/Server/Server.fsproj` + +Insert `` **before** `WorktreeApi.fs`. It depends only on `Log.fs`, +`PathUtils.fs` (in `Shared`), and the `Shared` types, all already earlier in the order, so it can slot in +right after `SyncEngine.fs` / `DemoFixture.fs` and before `WorktreeApi.fs`. + +### Update consumers — no compatibility shims (project rule) + +`WorktreeApi.fs` keeps the API wiring and calls the moved functions via `GlobalConfig.*` (add +`open Server.GlobalConfig` or qualify). Other call sites, all moving from `WorktreeApi.*` → +`GlobalConfig.*`: + +| Consumer | References to retarget | +|---|---| +| `src/Server/WorktreeApi.fs` | `getEditorConfig`, `readCollapsedRepos`/`writeCollapsedRepos`, `readCanvasPaneOpen`/`writeCanvasPaneOpen`, `readCanvasPosition`/`writeCanvasPosition`, `readLastViewedHashes`/`writeLastViewedHashes`, `addRootToConfig`/`removeRootFromConfig`, `readWorktreeRootsConfig` | +| `src/Server/Program.fs` | `globalConfigDir` (roots.json path), `tryReadWorktreeRootsConfig`, `writeWorktreeRoots` | +| `src/Tests/ConfigWriterTests.fs` | `open Server.WorktreeApi` → `open Server.GlobalConfig` (uses `updateConfigAtPath`) | +| `src/Tests/WorktreeRootsConfigTests.fs` | `open Server.WorktreeApi` → `open Server.GlobalConfig` (uses roots read/write/add/remove) | +| `src/Tests/ServerStartupResolutionTests.fs` | `Server.WorktreeApi.readWorktreeRootsConfig` / `writeWorktreeRoots` → `Server.GlobalConfig.*` | +| `src/Tests/SmokeTests.fs` | comment mention of `WorktreeApi.globalConfigDir` (line ~38) — keep honest | + +The move and all consumer updates land in **one atomic change** so the build never goes red: once +`globalConfigDir` (etc.) leaves `WorktreeApi`, every `WorktreeApi.globalConfigDir` reference must update in +the same commit. No re-export shims (project forbids backwards-compatibility shims). + +### Verification of the cut + +After the move, `(Get-Content src/Server/WorktreeApi.fs).Count` should drop by ~250 lines (from 870), and +`GlobalConfig.fs` should contain the moved functions. Build + Unit + Fast + E2E stay green. + +## Decisions + +- **Module name `GlobalConfig`, not `Config`.** It owns the *machine-level* `~/.treemon/config.json`, + distinct from the per-worktree `.treemon.json` handled by `TreemonConfig.fs`. The name keeps that + distinction obvious and avoids collision with the existing `TreemonConfig` module. +- **One file, not split by concern.** The generic JSON store and the typed accessors are cohesive (the + accessors are thin wrappers over the store) and share the lock/atomic-write helpers; splitting them + would scatter a single responsibility. The whole thing is one ~256-line module. +- **`internal` over `public`.** The surface is only consumed inside the `Treemon` assembly and its test + assembly (via `InternalsVisibleTo`), so `internal` preserves encapsulation while keeping every existing + reference compiling. +- **Atomic move, no shims.** Per the project's no-backwards-compatibility-shims rule, consumers are + updated in the same change rather than left pointing at re-exports. + +## Key Files + +- **New:** `src/Server/GlobalConfig.fs` — machine-level config store + typed accessors. +- **Shrinks:** `src/Server/WorktreeApi.fs` — left with `IWorktreeApi` wiring + `DashboardResponse` assembly. +- **Compile order:** `src/Server/Server.fsproj`. +- **Consumers:** `src/Server/Program.fs`, `src/Tests/ConfigWriterTests.fs`, + `src/Tests/WorktreeRootsConfigTests.fs`, `src/Tests/ServerStartupResolutionTests.fs`. +- **Docs to keep honest:** `docs/spec/worktree-monitor.md` (Key Files table), + `docs/spec/future/code-improvements.md` (move the item to *Done*). + +## Related Specs + +- `docs/spec/worktree-monitor.md` — the watched-roots / `config.json` behavior this code implements. +- `docs/spec/future/code-improvements.md` — the running backlog; this is candidate #7 (the survey's top pick). From c69f5533b235f7cbe172c8a62a44fd7dc2f85bac Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Wed, 24 Jun 2026 16:29:20 +0200 Subject: [PATCH 3/9] tm-improvement-survey-auy Move config block into GlobalConfig.fs and retarget all consumers Extract machine-level config.json I/O from WorktreeApi.fs into new Server.GlobalConfig module (263 lines); retarget all consumers (Program.fs 3 refs, 4 test files) in one atomic change with no compat shims. WorktreeApi.fs 870->614 lines. --- src/Server/GlobalConfig.fs | 263 ++++++++++++++++++++++ src/Server/Program.fs | 6 +- src/Server/Server.fsproj | 1 + src/Server/WorktreeApi.fs | 258 +-------------------- src/Tests/ConfigWriterTests.fs | 2 +- src/Tests/ServerStartupResolutionTests.fs | 20 +- src/Tests/SmokeTests.fs | 2 +- src/Tests/WorktreeRootsConfigTests.fs | 2 +- 8 files changed, 281 insertions(+), 273 deletions(-) create mode 100644 src/Server/GlobalConfig.fs diff --git a/src/Server/GlobalConfig.fs b/src/Server/GlobalConfig.fs new file mode 100644 index 0000000..ea87a31 --- /dev/null +++ b/src/Server/GlobalConfig.fs @@ -0,0 +1,263 @@ +module Server.GlobalConfig + +open System +open System.IO +open Shared +open Shared.PathUtils + +/// Directory holding the machine-level Treemon config (`config.json`), normally `~/.treemon`. +/// The `TREEMON_CONFIG_DIR` override exists for test isolation: on Windows +/// `Environment.GetFolderPath(UserProfile)` ignores the USERPROFILE/HOME env vars, so an +/// in-process test can only redirect the config dir via this explicit override. +let internal globalConfigDir () = + Environment.GetEnvironmentVariable("TREEMON_CONFIG_DIR") + |> Option.ofObj + |> Option.filter (fun d -> d <> "") + |> Option.defaultWith (fun () -> + Path.Combine( + Environment.GetFolderPath(Environment.SpecialFolder.UserProfile), + ".treemon")) + +let private globalConfigPath () = + Path.Combine(globalConfigDir (), "config.json") + +let private withConfigDocument (defaultValue: 'a) (f: System.Text.Json.JsonElement -> 'a) : 'a = + let path = globalConfigPath () + if not (File.Exists path) then defaultValue + else + try + let json = File.ReadAllText path + use doc = System.Text.Json.JsonDocument.Parse json + f doc.RootElement + with ex -> + Log.log "Config" $"Failed to read config: {ex.Message}" + defaultValue + +let private readGlobalConfig () = + withConfigDocument Map.empty (fun root -> + root.EnumerateObject() + |> Seq.choose (fun prop -> + if prop.Value.ValueKind = System.Text.Json.JsonValueKind.String + then Some (prop.Name, prop.Value.GetString()) + else None) + |> Map.ofSeq) + +let internal readCollapsedRepos () : Set = + withConfigDocument Set.empty (fun root -> + match root.TryGetProperty("collapsedRepos") with + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Array -> + prop.EnumerateArray() + |> Seq.choose (fun el -> + if el.ValueKind = System.Text.Json.JsonValueKind.String then Some (RepoId (el.GetString())) + else None) + |> Set.ofSeq + | _ -> Set.empty) + +/// Serializes every write to the machine-level `config.json`. All global-config writers +/// (collapsedRepos, canvas state, lastViewedHashes, worktreeRoots) funnel through +/// `updateConfigAtPath`, so this lock makes the server the single serialized writer and stops +/// concurrent read-modify-write cycles from clobbering each other's keys. +let private globalConfigLock = obj () + +let private tryParseJsonObject (text: string) : System.Text.Json.Nodes.JsonObject option = + try + match System.Text.Json.Nodes.JsonNode.Parse(text) with + | :? System.Text.Json.Nodes.JsonObject as root -> Some root + | _ -> None + with _ -> None + +/// Read-modify-write a JSON config file safely. Serialized by an in-process lock, +/// written atomically (temp file in the same directory, then replace), and never +/// discarding existing data: an unparseable file is backed up to a timestamped sibling +/// rather than overwritten. Updates are described as (key, node) pairs, applied as the only +/// mutation of the JSON tree. Takes the path so it can be unit-tested against a temp file. +let internal updateConfigAtPath (configPath: string) (updates: (string * System.Text.Json.Nodes.JsonNode) list) : Result = + lock globalConfigLock (fun () -> + try + let dir = Path.GetDirectoryName(configPath) + if not (Directory.Exists(dir)) then Directory.CreateDirectory(dir) |> ignore + + let root = + if not (File.Exists(configPath)) then + System.Text.Json.Nodes.JsonObject() + else + match File.ReadAllText(configPath) |> tryParseJsonObject with + | Some existing -> existing + | None -> + let timestamp = DateTime.Now.ToString("yyyyMMddHHmmss") + let backupPath = $"{configPath}.corrupt-{timestamp}" + Log.log "Config" $"Config at {configPath} is unparseable; backing up to {backupPath} and starting fresh" + File.Copy(configPath, backupPath, overwrite = true) + System.Text.Json.Nodes.JsonObject() + + updates |> List.iter (fun (key, value) -> root[key] <- value) + + let options = System.Text.Json.JsonSerializerOptions(WriteIndented = true) + let tempPath = configPath + ".tmp" + File.WriteAllText(tempPath, root.ToJsonString(options)) + File.Move(tempPath, configPath, overwrite = true) + Ok() + with ex -> + Error ex.Message) + +let private updateGlobalConfig (description: string) (updates: (string * System.Text.Json.Nodes.JsonNode) list) = + match updateConfigAtPath (globalConfigPath ()) updates with + | Ok() -> () + | Error msg -> Log.log "Config" $"Failed to save {description}: {msg}" + +let internal writeCollapsedRepos (repos: RepoId list) = + let repoArray = + System.Text.Json.Nodes.JsonArray(repos |> List.map (fun (RepoId s) -> System.Text.Json.Nodes.JsonValue.Create(s) :> System.Text.Json.Nodes.JsonNode) |> List.toArray) + updateGlobalConfig "collapsed repos" [ "collapsedRepos", repoArray :> System.Text.Json.Nodes.JsonNode ] + +/// Reads the machine-level set of watched worktree roots (`worktreeRoots` in `config.json`), +/// distinguishing a MISSING key (`None`) from a present-but-empty list (`Some []`). The startup +/// resolver depends on that distinction: an explicit `worktreeRoots:[]` means the user curated +/// every root away, so it must NOT be treated like a fresh install and repopulated from CLI args +/// or a stale orphan `roots.json`. A malformed (non-array) value is reported as `None` — absent — +/// matching the original lenient behavior. `internal` so the resolver (`Program.fs`) shares it. +let internal tryReadWorktreeRootsConfig () : string list option = + withConfigDocument None (fun root -> + match root.TryGetProperty("worktreeRoots") with + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Array -> + prop.EnumerateArray() + |> Seq.choose (fun el -> + if el.ValueKind = System.Text.Json.JsonValueKind.String then Some(el.GetString()) + else None) + |> List.ofSeq + |> Some + | _ -> None) + +/// Flattens `tryReadWorktreeRootsConfig` to a plain list (missing key -> `[]`) for callers that +/// don't need the missing-vs-empty distinction: the `getRoots` endpoint and the add/remove +/// read-modify-write. `internal` so the startup resolver and the endpoint can share the reader. +let internal readWorktreeRootsConfig () : string list = + tryReadWorktreeRootsConfig () |> Option.defaultValue [] + +/// Persists the watched worktree roots through the locked, atomic single-writer path +/// (`updateConfigAtPath`), leaving every other global-config key untouched. Returns the write +/// outcome so the `addRoot`/`removeRoot` endpoints can surface a persistence failure to the CLI +/// instead of reporting a false success. `internal` so the startup resolver can also write +/// through this one helper. +let internal writeWorktreeRoots (roots: string list) : Result = + let rootArray = + System.Text.Json.Nodes.JsonArray( + roots + |> List.map (fun r -> System.Text.Json.Nodes.JsonValue.Create(r) :> System.Text.Json.Nodes.JsonNode) + |> List.toArray) + updateConfigAtPath (globalConfigPath ()) [ "worktreeRoots", rootArray :> System.Text.Json.Nodes.JsonNode ] + +/// Canonical comparison form for a worktree root: absolute path with trailing separators +/// trimmed. Total (never throws) so it is safe to fold over already-stored roots — a malformed +/// stored entry falls back to its raw value rather than aborting the whole add/remove. +let private canonicalRoot (path: string) = + try Path.GetFullPath(path).TrimEnd(Path.DirectorySeparatorChar, Path.AltDirectorySeparatorChar) + with _ -> path + +/// Normalizes a caller-supplied root path (absolute, trailing separators trimmed), surfacing a +/// readable error for blank or malformed input so the CLI can report it. +let private tryNormalizeRoot (path: string) : Result = + if String.IsNullOrWhiteSpace path then Error "Path is empty." + else + try Ok(Path.GetFullPath(path).TrimEnd(Path.DirectorySeparatorChar, Path.AltDirectorySeparatorChar)) + with ex -> Error $"Invalid path '{path}': {ex.Message}" + +/// Adds a worktree root to the global config (restart-to-apply). Normalizes and verifies the +/// path is an existing directory, then read-modify-writes the roots list via the locked +/// single-writer helpers, surfacing a persistence failure rather than a false success. Adding an +/// already-watched path is a no-op success. add/remove are driven by the (serialized) +/// `tm add`/`tm remove` CLI, so the read-then-write is not contended in practice; the write +/// itself is serialized by `globalConfigLock`. +let internal addRootToConfig (path: string) : Result = + tryNormalizeRoot path + |> Result.bind (fun normalized -> + if not (Directory.Exists normalized) then + Error $"Path does not exist or is not a directory: {normalized}" + else + let existing = readWorktreeRootsConfig () + if existing |> List.exists (fun r -> pathEquals (canonicalRoot r) normalized) then + Ok() + else + writeWorktreeRoots (existing @ [ normalized ])) + +/// Removes a worktree root from the global config (restart-to-apply). Does not require the path +/// to still exist on disk (a deleted root is removable); reports an error when the path is not +/// currently watched, and surfaces a persistence failure instead of a false success. +let internal removeRootFromConfig (path: string) : Result = + tryNormalizeRoot path + |> Result.bind (fun normalized -> + let existing = readWorktreeRootsConfig () + let remaining = existing |> List.filter (fun r -> not (pathEquals (canonicalRoot r) normalized)) + if List.length remaining = List.length existing then + Error $"Not a watched root: {normalized}" + else + writeWorktreeRoots remaining) + +let internal readCanvasPaneOpen () : bool = + withConfigDocument false (fun root -> + match root.TryGetProperty("canvasPaneOpen") with + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.True -> true + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.False -> false + | _ -> false) + +let internal writeCanvasPaneOpen (isOpen: bool) = + updateGlobalConfig "canvas pane open state" [ "canvasPaneOpen", System.Text.Json.Nodes.JsonValue.Create(isOpen) :> System.Text.Json.Nodes.JsonNode ] + +let internal readCanvasPosition () : CanvasPosition = + withConfigDocument CanvasPosition.Right (fun root -> + match root.TryGetProperty("canvasPosition") with + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.String -> + match prop.GetString() with + | "left" -> CanvasPosition.Left + | "right" -> CanvasPosition.Right + | "top" -> CanvasPosition.Top + | "bottom" -> CanvasPosition.Bottom + | _ -> CanvasPosition.Right + | _ -> CanvasPosition.Right) + +let internal writeCanvasPosition (position: CanvasPosition) = + let value = + match position with + | CanvasPosition.Left -> "left" + | CanvasPosition.Right -> "right" + | CanvasPosition.Top -> "top" + | CanvasPosition.Bottom -> "bottom" + updateGlobalConfig "canvas position" [ "canvasPosition", System.Text.Json.Nodes.JsonValue.Create(value) :> System.Text.Json.Nodes.JsonNode ] + +let internal readLastViewedHashes () : Map> = + withConfigDocument Map.empty (fun root -> + match root.TryGetProperty("lastViewedHashes") with + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Object -> + prop.EnumerateObject() + |> Seq.choose (fun worktreeProp -> + if worktreeProp.Value.ValueKind = System.Text.Json.JsonValueKind.Object then + let fileHashes = + worktreeProp.Value.EnumerateObject() + |> Seq.choose (fun fileProp -> + if fileProp.Value.ValueKind = System.Text.Json.JsonValueKind.String + then Some (fileProp.Name, fileProp.Value.GetString()) + else None) + |> Map.ofSeq + Some (worktreeProp.Name, fileHashes) + else None) + |> Map.ofSeq + | _ -> Map.empty) + +let internal writeLastViewedHashes (hashes: Map>) = + let outerObj = System.Text.Json.Nodes.JsonObject() + hashes |> Map.iter (fun worktreePath fileHashes -> + let innerObj = System.Text.Json.Nodes.JsonObject() + fileHashes |> Map.iter (fun filename hash -> + innerObj[filename] <- System.Text.Json.Nodes.JsonValue.Create(hash)) + outerObj[worktreePath] <- innerObj) + updateGlobalConfig "last viewed hashes" [ "lastViewedHashes", outerObj :> System.Text.Json.Nodes.JsonNode ] + +let internal getEditorConfig () = + let config = readGlobalConfig () + let command = config |> Map.tryFind "editor" |> Option.defaultValue "code" + let name = + match config |> Map.tryFind "editorName", command with + | Some n, _ -> n + | None, "code" -> "VS Code" + | None, cmd -> cmd + command, name diff --git a/src/Server/Program.fs b/src/Server/Program.fs index 73162b0..28c5f9d 100644 --- a/src/Server/Program.fs +++ b/src/Server/Program.fs @@ -138,7 +138,7 @@ let private buildRemotingHandler (api: IWorktreeApi) = /// Path of the orphan `roots.json` under the (TREEMON_CONFIG_DIR-aware) global config dir. The /// file is a stale migration artifact read by nothing per the config investigation. let private orphanRootsPath () = - System.IO.Path.Combine(WorktreeApi.globalConfigDir (), "roots.json") + System.IO.Path.Combine(GlobalConfig.globalConfigDir (), "roots.json") /// Reads the orphan `roots.json` (schema `{ "WorktreeRoots": [...] }`), returning its roots or /// `[]` when absent/unreadable. Pure read — the file is deleted only after its roots are durably @@ -197,7 +197,7 @@ let internal resolveWorktreeRoots (cliRoots: string list) : RootsResolution = // the key is present (possibly an explicit empty list). Gating migration on KEY ABSENCE — not // `List.isEmpty` — is what stops an explicit `worktreeRoots:[]` from being resurrected by a // stale orphan `roots.json` or overwritten by CLI args on restart. - let configRoots = WorktreeApi.tryReadWorktreeRootsConfig () + let configRoots = GlobalConfig.tryReadWorktreeRootsConfig () let configHasKey = Option.isSome configRoots let resolved, cameFromOrphan = @@ -218,7 +218,7 @@ let internal resolveWorktreeRoots (cliRoots: string list) : RootsResolution = /// failed write can never drop the migration). A no-op when the resolution needs no persistence. let internal persistResolvedRoots (resolution: RootsResolution) = if resolution.PersistRoots then - match WorktreeApi.writeWorktreeRoots resolution.Roots with + match GlobalConfig.writeWorktreeRoots resolution.Roots with | Ok () -> Log.log "Startup" $"Persisted {List.length resolution.Roots} worktree root(s) to global config" if resolution.ConsumeOrphan then deleteOrphanRoots () diff --git a/src/Server/Server.fsproj b/src/Server/Server.fsproj index 39900ea..4ce4fe8 100644 --- a/src/Server/Server.fsproj +++ b/src/Server/Server.fsproj @@ -38,6 +38,7 @@ + diff --git a/src/Server/WorktreeApi.fs b/src/Server/WorktreeApi.fs index f64c9b1..0ba316e 100644 --- a/src/Server/WorktreeApi.fs +++ b/src/Server/WorktreeApi.fs @@ -9,6 +9,7 @@ open Shared.EventUtils open Shared.PathUtils open Newtonsoft.Json open FsToolkit.ErrorHandling +open Server.GlobalConfig let private canvasSpawnInFlight = ConcurrentDictionary() @@ -175,263 +176,6 @@ let private resolveProvider (state: RefreshScheduler.DashboardState) (path: stri |> Map.tryFind path |> Option.bind (fun data -> data.Provider |> Option.orElse data.LastMessageProvider)) -/// Directory holding the machine-level Treemon config (`config.json`), normally `~/.treemon`. -/// The `TREEMON_CONFIG_DIR` override exists for test isolation: on Windows -/// `Environment.GetFolderPath(UserProfile)` ignores the USERPROFILE/HOME env vars, so an -/// in-process test can only redirect the config dir via this explicit override. -let internal globalConfigDir () = - Environment.GetEnvironmentVariable("TREEMON_CONFIG_DIR") - |> Option.ofObj - |> Option.filter (fun d -> d <> "") - |> Option.defaultWith (fun () -> - Path.Combine( - Environment.GetFolderPath(Environment.SpecialFolder.UserProfile), - ".treemon")) - -let private globalConfigPath () = - Path.Combine(globalConfigDir (), "config.json") - -let private withConfigDocument (defaultValue: 'a) (f: System.Text.Json.JsonElement -> 'a) : 'a = - let path = globalConfigPath () - if not (File.Exists path) then defaultValue - else - try - let json = File.ReadAllText path - use doc = System.Text.Json.JsonDocument.Parse json - f doc.RootElement - with ex -> - Log.log "Config" $"Failed to read config: {ex.Message}" - defaultValue - -let private readGlobalConfig () = - withConfigDocument Map.empty (fun root -> - root.EnumerateObject() - |> Seq.choose (fun prop -> - if prop.Value.ValueKind = System.Text.Json.JsonValueKind.String - then Some (prop.Name, prop.Value.GetString()) - else None) - |> Map.ofSeq) - -let private readCollapsedRepos () : Set = - withConfigDocument Set.empty (fun root -> - match root.TryGetProperty("collapsedRepos") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Array -> - prop.EnumerateArray() - |> Seq.choose (fun el -> - if el.ValueKind = System.Text.Json.JsonValueKind.String then Some (RepoId (el.GetString())) - else None) - |> Set.ofSeq - | _ -> Set.empty) - -/// Serializes every write to the machine-level `config.json`. All global-config writers -/// (collapsedRepos, canvas state, lastViewedHashes, worktreeRoots) funnel through -/// `updateConfigAtPath`, so this lock makes the server the single serialized writer and stops -/// concurrent read-modify-write cycles from clobbering each other's keys. -let private globalConfigLock = obj () - -let private tryParseJsonObject (text: string) : System.Text.Json.Nodes.JsonObject option = - try - match System.Text.Json.Nodes.JsonNode.Parse(text) with - | :? System.Text.Json.Nodes.JsonObject as root -> Some root - | _ -> None - with _ -> None - -/// Read-modify-write a JSON config file safely. Serialized by an in-process lock, -/// written atomically (temp file in the same directory, then replace), and never -/// discarding existing data: an unparseable file is backed up to a timestamped sibling -/// rather than overwritten. Updates are described as (key, node) pairs, applied as the only -/// mutation of the JSON tree. Takes the path so it can be unit-tested against a temp file. -let internal updateConfigAtPath (configPath: string) (updates: (string * System.Text.Json.Nodes.JsonNode) list) : Result = - lock globalConfigLock (fun () -> - try - let dir = Path.GetDirectoryName(configPath) - if not (Directory.Exists(dir)) then Directory.CreateDirectory(dir) |> ignore - - let root = - if not (File.Exists(configPath)) then - System.Text.Json.Nodes.JsonObject() - else - match File.ReadAllText(configPath) |> tryParseJsonObject with - | Some existing -> existing - | None -> - let timestamp = DateTime.Now.ToString("yyyyMMddHHmmss") - let backupPath = $"{configPath}.corrupt-{timestamp}" - Log.log "Config" $"Config at {configPath} is unparseable; backing up to {backupPath} and starting fresh" - File.Copy(configPath, backupPath, overwrite = true) - System.Text.Json.Nodes.JsonObject() - - updates |> List.iter (fun (key, value) -> root[key] <- value) - - let options = System.Text.Json.JsonSerializerOptions(WriteIndented = true) - let tempPath = configPath + ".tmp" - File.WriteAllText(tempPath, root.ToJsonString(options)) - File.Move(tempPath, configPath, overwrite = true) - Ok() - with ex -> - Error ex.Message) - -let private updateGlobalConfig (description: string) (updates: (string * System.Text.Json.Nodes.JsonNode) list) = - match updateConfigAtPath (globalConfigPath ()) updates with - | Ok() -> () - | Error msg -> Log.log "Config" $"Failed to save {description}: {msg}" - -let private writeCollapsedRepos (repos: RepoId list) = - let repoArray = - System.Text.Json.Nodes.JsonArray(repos |> List.map (fun (RepoId s) -> System.Text.Json.Nodes.JsonValue.Create(s) :> System.Text.Json.Nodes.JsonNode) |> List.toArray) - updateGlobalConfig "collapsed repos" [ "collapsedRepos", repoArray :> System.Text.Json.Nodes.JsonNode ] - -/// Reads the machine-level set of watched worktree roots (`worktreeRoots` in `config.json`), -/// distinguishing a MISSING key (`None`) from a present-but-empty list (`Some []`). The startup -/// resolver depends on that distinction: an explicit `worktreeRoots:[]` means the user curated -/// every root away, so it must NOT be treated like a fresh install and repopulated from CLI args -/// or a stale orphan `roots.json`. A malformed (non-array) value is reported as `None` — absent — -/// matching the original lenient behavior. `internal` so the resolver (`Program.fs`) shares it. -let internal tryReadWorktreeRootsConfig () : string list option = - withConfigDocument None (fun root -> - match root.TryGetProperty("worktreeRoots") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Array -> - prop.EnumerateArray() - |> Seq.choose (fun el -> - if el.ValueKind = System.Text.Json.JsonValueKind.String then Some(el.GetString()) - else None) - |> List.ofSeq - |> Some - | _ -> None) - -/// Flattens `tryReadWorktreeRootsConfig` to a plain list (missing key -> `[]`) for callers that -/// don't need the missing-vs-empty distinction: the `getRoots` endpoint and the add/remove -/// read-modify-write. `internal` so the startup resolver and the endpoint can share the reader. -let internal readWorktreeRootsConfig () : string list = - tryReadWorktreeRootsConfig () |> Option.defaultValue [] - -/// Persists the watched worktree roots through the locked, atomic single-writer path -/// (`updateConfigAtPath`), leaving every other global-config key untouched. Returns the write -/// outcome so the `addRoot`/`removeRoot` endpoints can surface a persistence failure to the CLI -/// instead of reporting a false success. `internal` so the startup resolver can also write -/// through this one helper. -let internal writeWorktreeRoots (roots: string list) : Result = - let rootArray = - System.Text.Json.Nodes.JsonArray( - roots - |> List.map (fun r -> System.Text.Json.Nodes.JsonValue.Create(r) :> System.Text.Json.Nodes.JsonNode) - |> List.toArray) - updateConfigAtPath (globalConfigPath ()) [ "worktreeRoots", rootArray :> System.Text.Json.Nodes.JsonNode ] - -/// Canonical comparison form for a worktree root: absolute path with trailing separators -/// trimmed. Total (never throws) so it is safe to fold over already-stored roots — a malformed -/// stored entry falls back to its raw value rather than aborting the whole add/remove. -let private canonicalRoot (path: string) = - try Path.GetFullPath(path).TrimEnd(Path.DirectorySeparatorChar, Path.AltDirectorySeparatorChar) - with _ -> path - -/// Normalizes a caller-supplied root path (absolute, trailing separators trimmed), surfacing a -/// readable error for blank or malformed input so the CLI can report it. -let private tryNormalizeRoot (path: string) : Result = - if String.IsNullOrWhiteSpace path then Error "Path is empty." - else - try Ok(Path.GetFullPath(path).TrimEnd(Path.DirectorySeparatorChar, Path.AltDirectorySeparatorChar)) - with ex -> Error $"Invalid path '{path}': {ex.Message}" - -/// Adds a worktree root to the global config (restart-to-apply). Normalizes and verifies the -/// path is an existing directory, then read-modify-writes the roots list via the locked -/// single-writer helpers, surfacing a persistence failure rather than a false success. Adding an -/// already-watched path is a no-op success. add/remove are driven by the (serialized) -/// `tm add`/`tm remove` CLI, so the read-then-write is not contended in practice; the write -/// itself is serialized by `globalConfigLock`. -let internal addRootToConfig (path: string) : Result = - tryNormalizeRoot path - |> Result.bind (fun normalized -> - if not (Directory.Exists normalized) then - Error $"Path does not exist or is not a directory: {normalized}" - else - let existing = readWorktreeRootsConfig () - if existing |> List.exists (fun r -> pathEquals (canonicalRoot r) normalized) then - Ok() - else - writeWorktreeRoots (existing @ [ normalized ])) - -/// Removes a worktree root from the global config (restart-to-apply). Does not require the path -/// to still exist on disk (a deleted root is removable); reports an error when the path is not -/// currently watched, and surfaces a persistence failure instead of a false success. -let internal removeRootFromConfig (path: string) : Result = - tryNormalizeRoot path - |> Result.bind (fun normalized -> - let existing = readWorktreeRootsConfig () - let remaining = existing |> List.filter (fun r -> not (pathEquals (canonicalRoot r) normalized)) - if List.length remaining = List.length existing then - Error $"Not a watched root: {normalized}" - else - writeWorktreeRoots remaining) - -let private readCanvasPaneOpen () : bool = - withConfigDocument false (fun root -> - match root.TryGetProperty("canvasPaneOpen") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.True -> true - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.False -> false - | _ -> false) - -let private writeCanvasPaneOpen (isOpen: bool) = - updateGlobalConfig "canvas pane open state" [ "canvasPaneOpen", System.Text.Json.Nodes.JsonValue.Create(isOpen) :> System.Text.Json.Nodes.JsonNode ] - -let private readCanvasPosition () : CanvasPosition = - withConfigDocument CanvasPosition.Right (fun root -> - match root.TryGetProperty("canvasPosition") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.String -> - match prop.GetString() with - | "left" -> CanvasPosition.Left - | "right" -> CanvasPosition.Right - | "top" -> CanvasPosition.Top - | "bottom" -> CanvasPosition.Bottom - | _ -> CanvasPosition.Right - | _ -> CanvasPosition.Right) - -let private writeCanvasPosition (position: CanvasPosition) = - let value = - match position with - | CanvasPosition.Left -> "left" - | CanvasPosition.Right -> "right" - | CanvasPosition.Top -> "top" - | CanvasPosition.Bottom -> "bottom" - updateGlobalConfig "canvas position" [ "canvasPosition", System.Text.Json.Nodes.JsonValue.Create(value) :> System.Text.Json.Nodes.JsonNode ] - -let private readLastViewedHashes () : Map> = - withConfigDocument Map.empty (fun root -> - match root.TryGetProperty("lastViewedHashes") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Object -> - prop.EnumerateObject() - |> Seq.choose (fun worktreeProp -> - if worktreeProp.Value.ValueKind = System.Text.Json.JsonValueKind.Object then - let fileHashes = - worktreeProp.Value.EnumerateObject() - |> Seq.choose (fun fileProp -> - if fileProp.Value.ValueKind = System.Text.Json.JsonValueKind.String - then Some (fileProp.Name, fileProp.Value.GetString()) - else None) - |> Map.ofSeq - Some (worktreeProp.Name, fileHashes) - else None) - |> Map.ofSeq - | _ -> Map.empty) - -let private writeLastViewedHashes (hashes: Map>) = - let outerObj = System.Text.Json.Nodes.JsonObject() - hashes |> Map.iter (fun worktreePath fileHashes -> - let innerObj = System.Text.Json.Nodes.JsonObject() - fileHashes |> Map.iter (fun filename hash -> - innerObj[filename] <- System.Text.Json.Nodes.JsonValue.Create(hash)) - outerObj[worktreePath] <- innerObj) - updateGlobalConfig "last viewed hashes" [ "lastViewedHashes", outerObj :> System.Text.Json.Nodes.JsonNode ] - -let private getEditorConfig () = - let config = readGlobalConfig () - let command = config |> Map.tryFind "editor" |> Option.defaultValue "code" - let name = - match config |> Map.tryFind "editorName", command with - | Some n, _ -> n - | None, "code" -> "VS Code" - | None, cmd -> cmd - command, name - let getWorktrees (agent: MailboxProcessor) (sessionAgent: SessionManager.SessionAgent) diff --git a/src/Tests/ConfigWriterTests.fs b/src/Tests/ConfigWriterTests.fs index 4fc0880..53907d0 100644 --- a/src/Tests/ConfigWriterTests.fs +++ b/src/Tests/ConfigWriterTests.fs @@ -5,7 +5,7 @@ open System.IO open System.Text.Json open System.Text.Json.Nodes open NUnit.Framework -open Server.WorktreeApi +open Server.GlobalConfig open Tests.TestUtils let private withTempDir (action: string -> unit) = diff --git a/src/Tests/ServerStartupResolutionTests.fs b/src/Tests/ServerStartupResolutionTests.fs index 6179ff0..df6f7f5 100644 --- a/src/Tests/ServerStartupResolutionTests.fs +++ b/src/Tests/ServerStartupResolutionTests.fs @@ -68,13 +68,13 @@ type ServerStartupResolutionTests() = Assert.That(resolution.ConsumeOrphan, Is.False) // Applying the resolution at the boundary writes it to the global config. persistResolvedRoots resolution - Assert.That(Server.WorktreeApi.readWorktreeRootsConfig (), Is.EqualTo(cliRoots))) + Assert.That(Server.GlobalConfig.readWorktreeRootsConfig (), Is.EqualTo(cliRoots))) [] member _.``resolveWorktreeRoots prefers CLI args but does not overwrite a populated config``() = withTempConfigDir "treemon-startup-test" (fun _ -> let configured = [ @"C:\code\configured" ] - match Server.WorktreeApi.writeWorktreeRoots configured with + match Server.GlobalConfig.writeWorktreeRoots configured with | Ok () -> () | Error msg -> Assert.Fail $"setup write failed: {msg}" @@ -85,13 +85,13 @@ type ServerStartupResolutionTests() = Assert.That(resolution.PersistRoots, Is.False) persistResolvedRoots resolution // ...so a populated config is an ephemeral override, not clobbered. - Assert.That(Server.WorktreeApi.readWorktreeRootsConfig (), Is.EqualTo(configured))) + Assert.That(Server.GlobalConfig.readWorktreeRootsConfig (), Is.EqualTo(configured))) [] member _.``resolveWorktreeRoots reads global config when no CLI args``() = withTempConfigDir "treemon-startup-test" (fun _ -> let configured = [ @"C:\code\x"; @"C:\code\y" ] - match Server.WorktreeApi.writeWorktreeRoots configured with + match Server.GlobalConfig.writeWorktreeRoots configured with | Ok () -> () | Error msg -> Assert.Fail $"setup write failed: {msg}" @@ -116,7 +116,7 @@ type ServerStartupResolutionTests() = persistResolvedRoots resolution // Migrated set persisted into the global config... - Assert.That(Server.WorktreeApi.readWorktreeRootsConfig (), Is.EqualTo(orphanRoots)) + Assert.That(Server.GlobalConfig.readWorktreeRootsConfig (), Is.EqualTo(orphanRoots)) // ...and the orphan file is consumed (deleted) only after a successful persist. Assert.That(File.Exists(Path.Combine(tempDir, "roots.json")), Is.False)) @@ -128,7 +128,7 @@ type ServerStartupResolutionTests() = Assert.That(resolution.PersistRoots, Is.False) persistResolvedRoots resolution // Nothing to persist, so the config stays absent/empty. - Assert.That(Server.WorktreeApi.readWorktreeRootsConfig (), Is.Empty)) + Assert.That(Server.GlobalConfig.readWorktreeRootsConfig (), Is.Empty)) // ----- Regression (tm-config-audit-rf1): an explicit `worktreeRoots:[]` must stay empty ----- // The bug: readWorktreeRootsConfig() returned [] for BOTH a missing key and a present-but-empty @@ -139,7 +139,7 @@ type ServerStartupResolutionTests() = member _.``resolveWorktreeRoots leaves an explicit empty config empty despite an orphan roots.json``() = withTempConfigDir "treemon-startup-test" (fun tempDir -> // The user removed every root: the key is PRESENT but empty (not absent). - match Server.WorktreeApi.writeWorktreeRoots [] with + match Server.GlobalConfig.writeWorktreeRoots [] with | Ok () -> () | Error msg -> Assert.Fail $"setup write failed: {msg}" // A stale orphan roots.json from a legacy upgrade still lingers on disk. @@ -154,7 +154,7 @@ type ServerStartupResolutionTests() = persistResolvedRoots resolution // ...the explicit empty config is preserved (present key, still empty — not None, not // repopulated with the orphan's roots)... - match Server.WorktreeApi.tryReadWorktreeRootsConfig () with + match Server.GlobalConfig.tryReadWorktreeRootsConfig () with | Some [] -> () | other -> Assert.Fail $"expected the config to stay an explicit empty (Some []), got %A{other}" // ...and the unconsumed orphan is left untouched (it is only migrated when the key is absent). @@ -163,7 +163,7 @@ type ServerStartupResolutionTests() = [] member _.``resolveWorktreeRoots does not persist CLI args over an explicit empty config``() = withTempConfigDir "treemon-startup-test" (fun _ -> - match Server.WorktreeApi.writeWorktreeRoots [] with + match Server.GlobalConfig.writeWorktreeRoots [] with | Ok () -> () | Error msg -> Assert.Fail $"setup write failed: {msg}" @@ -174,6 +174,6 @@ type ServerStartupResolutionTests() = Assert.That(resolution.PersistRoots, Is.False) persistResolvedRoots resolution // ...but the explicit empty config is not clobbered, so a restart with no args stays empty. - match Server.WorktreeApi.tryReadWorktreeRootsConfig () with + match Server.GlobalConfig.tryReadWorktreeRootsConfig () with | Some [] -> () | other -> Assert.Fail $"expected the config to stay an explicit empty (Some []), got %A{other}") diff --git a/src/Tests/SmokeTests.fs b/src/Tests/SmokeTests.fs index a45e0a3..ab7b238 100644 --- a/src/Tests/SmokeTests.fs +++ b/src/Tests/SmokeTests.fs @@ -35,7 +35,7 @@ let private startSmokeServerProc (configDir: string) (args: string) = // Isolate the smoke server's machine-level config dir. Startup root-resolution now persists // the resolved worktreeRoots into config.json when it has none yet, so without this override a // normal-mode smoke run would write the developer's real ~/.treemon. Point it at a caller-owned - // throwaway dir instead (WorktreeApi.globalConfigDir honors TREEMON_CONFIG_DIR); the fixture + // throwaway dir instead (GlobalConfig.globalConfigDir honors TREEMON_CONFIG_DIR); the fixture // deletes it in teardown. psi.EnvironmentVariables["TREEMON_CONFIG_DIR"] <- configDir diff --git a/src/Tests/WorktreeRootsConfigTests.fs b/src/Tests/WorktreeRootsConfigTests.fs index c0688c7..3694ec4 100644 --- a/src/Tests/WorktreeRootsConfigTests.fs +++ b/src/Tests/WorktreeRootsConfigTests.fs @@ -4,7 +4,7 @@ open System open System.IO open System.Text.Json open NUnit.Framework -open Server.WorktreeApi +open Server.GlobalConfig open Tests.TestUtils /// Compares two roots the way the endpoints do: absolute, trailing separators trimmed, From 8f37c4e39a4014004a319c3111189f46e734aedf Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Wed, 24 Jun 2026 16:41:00 +0200 Subject: [PATCH 4/9] tm-improvement-survey-0lr Update specs to reflect GlobalConfig extraction Docs-only spec hygiene after the GlobalConfig extraction: - worktree-monitor.md Key Files: add GlobalConfig.fs row (config.json store + typed accessors), retarget WorktreeApi.fs row to IWorktreeApi wiring + DashboardResponse assembly. - code-improvements.md: move candidate #7 to Done with one-line summary + spec link; fix the now-dangling row-5 cross-reference; keep #8's stable ID. --- docs/spec/future/code-improvements.md | 9 +++++++-- docs/spec/worktree-monitor.md | 3 ++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/docs/spec/future/code-improvements.md b/docs/spec/future/code-improvements.md index 9849dba..e3b8d29 100644 --- a/docs/spec/future/code-improvements.md +++ b/docs/spec/future/code-improvements.md @@ -37,9 +37,8 @@ its own worktree. This file is the entry point; detailed designs live in their o | 2 | **Port management** — centralize/derive the dev/prod/canvas/vite port assignments | `docs/spec/future/port-management.md` | Idea | | 3 | **Canvas roadmap items** — follow-on canvas-pane enhancements | `docs/spec/future/canvas-roadmap.md` | Idea | | 4 | **Process: guard against spec drift** — a lightweight check (or review rule) that flags `Key Files` references to moved/renamed modules so docs can't silently rot after refactors | — | Idea | -| 5 | **Survey other large modules** — *investigated.* The two largest production modules are `WorktreeApi.fs` (870 L) and `RefreshScheduler.fs` (741 L); both mix concerns. Concrete splits broken out as #7 and #8 below. (Strict-FP smells are already clean: no stray `let mutable`/loops/`null` in production; `Dictionary` only at cache/registry boundaries.) | — | Done (survey) | +| 5 | **Survey other large modules** — *investigated.* The two largest production modules are `WorktreeApi.fs` (870 L) and `RefreshScheduler.fs` (741 L); both mix concerns. Concrete splits broken out as #8 below (and #7, the `GlobalConfig` extract, now *Done*). (Strict-FP smells are already clean: no stray `let mutable`/loops/`null` in production; `Dictionary` only at cache/registry boundaries.) | — | Done (survey) | | 6 | **Remoting CSRF / Origin hardening** — pipeline-level Origin/Referer (and optional custom-header) check so a cross-origin browser page can't drive the unauthenticated loopback Fable.Remoting API (covers the dangerous pre-existing process-launching endpoints, not just watched-roots) | `docs/spec/future/remoting-csrf-hardening.md` | Idea (from focused-review) | -| 7 | **Extract a `GlobalConfig` store from `WorktreeApi.fs`** — lift the ~250 lines of machine-level JSON config read/modify/write (single-writer lock, atomic temp-file replace, missing-vs-empty `worktreeRoots` semantics, plus the canvas/collapsed-repos/last-viewed-hashes/editor readers+writers) into its own module so the largest production file is left with just the `IWorktreeApi` wiring. The concern already has dedicated tests (`ConfigWriterTests.fs`, `WorktreeRootsConfigTests.fs`) but the code lives in the API module. Behavior-preserving; ripple is mechanical (3 refs in `Program.fs` + 4 test files). | — | Idea (from survey — recommended next) | | 8 | **Split `RefreshScheduler.fs`** — the scheduler module also carries the `DashboardState`/`StateMsg`/`processMessage` state slice (~190 L) and an embedded `CanvasWatchers` filesystem-watcher module (~110 L). Lift one or both out of the scheduling loop into their own files (vertical-slice seam, like canvas/mascot/activity). Behavior-preserving but heavier ripple (26 refs to `RefreshScheduler.DashboardState`/`StateMsg`/`PerRepoState` in `WorktreeApi.fs`). | — | Idea (from survey) | > Add new candidates here as they surface (often from focused-review findings). Keep the list @@ -47,6 +46,12 @@ its own worktree. This file is the entry point; detailed designs live in their o ## Done +- **`GlobalConfig` store extraction** — lifted the machine-level `~/.treemon/config.json` + read/modify/write (single-writer lock, atomic temp-file replace, missing-vs-empty + `worktreeRoots` semantics, plus the canvas / collapsed-repos / last-viewed-hashes / editor + accessors) out of `WorktreeApi.fs` (870 → 614 L) into `src/Server/GlobalConfig.fs`, leaving the + API module with just `IWorktreeApi` wiring + `DashboardResponse` assembly. Behavior-preserving; + see `docs/spec/global-config-store.md`. - **App.fs view extraction** — `src/Client/App.fs` 1861 → 795 lines. Extracted `OverviewViews.fs`, `CardViews.fs` (with `CardViewProps`/`CardCallbacks` records), `MascotState.fs`/`MascotView.fs`, and `CanvasView.fs`; flat `Msg` + single `update` diff --git a/docs/spec/worktree-monitor.md b/docs/spec/worktree-monitor.md index 48c57da..b79ea70 100644 --- a/docs/spec/worktree-monitor.md +++ b/docs/spec/worktree-monitor.md @@ -225,7 +225,8 @@ After the burst, `lastRuns` is pre-populated and the normal sequential loop take | `src/Server/PrStatus.fs` | Provider routing, AzDo PR/thread/build fetching | | `src/Server/GithubPrStatus.fs` | GitHub PR/Actions fetching via `gh` CLI | | `src/Server/GitWorktree.fs` | Worktree enumeration, commit data, dirty detection, work metrics | -| `src/Server/WorktreeApi.fs` | API implementation, `DashboardResponse` assembly | +| `src/Server/GlobalConfig.fs` | Machine-level `config.json` store + typed accessors (watched roots, canvas, collapsed repos, last-viewed hashes, editor) | +| `src/Server/WorktreeApi.fs` | `IWorktreeApi` wiring + `DashboardResponse` assembly | | `src/Server/SyncEngine.fs` | Branch sync pipeline, provider-aware conflict resolution | | `src/Server/SessionManager.fs` | MailboxProcessor session agent, spawn/focus/kill, persistence | | `src/Server/Win32.fs` | P/Invoke: EnumWindows, SetForegroundWindow, WM_CLOSE | From 94f4da970063372607478d1b4596123ef40bf658 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 26 Jun 2026 16:21:22 +0200 Subject: [PATCH 5/9] tm-improvement-survey-ppq Fold global-config-store spec into worktree-monitor parent spec (spec-hygiene) Folded the durable config-store invariants (single serialized writer + atomic temp-file replace, never-destroy-data/corrupt-backup, typed accessors over one store) into worktree-monitor.md Expected Behavior and added a GlobalConfig vs TreemonConfig Decisions bullet. Deleted the stale extraction-plan spec global-config-store.md and repointed the code-improvements.md Done entry. Sibling task Spec: pointers retargeted in beads. --- docs/spec/future/code-improvements.md | 2 +- docs/spec/global-config-store.md | 115 -------------------------- docs/spec/worktree-monitor.md | 9 ++ 3 files changed, 10 insertions(+), 116 deletions(-) delete mode 100644 docs/spec/global-config-store.md diff --git a/docs/spec/future/code-improvements.md b/docs/spec/future/code-improvements.md index e3b8d29..d915d5d 100644 --- a/docs/spec/future/code-improvements.md +++ b/docs/spec/future/code-improvements.md @@ -51,7 +51,7 @@ its own worktree. This file is the entry point; detailed designs live in their o `worktreeRoots` semantics, plus the canvas / collapsed-repos / last-viewed-hashes / editor accessors) out of `WorktreeApi.fs` (870 → 614 L) into `src/Server/GlobalConfig.fs`, leaving the API module with just `IWorktreeApi` wiring + `DashboardResponse` assembly. Behavior-preserving; - see `docs/spec/global-config-store.md`. + see `docs/spec/worktree-monitor.md` (Configuration Store). - **App.fs view extraction** — `src/Client/App.fs` 1861 → 795 lines. Extracted `OverviewViews.fs`, `CardViews.fs` (with `CardViewProps`/`CardCallbacks` records), `MascotState.fs`/`MascotView.fs`, and `CanvasView.fs`; flat `Msg` + single `update` diff --git a/docs/spec/global-config-store.md b/docs/spec/global-config-store.md deleted file mode 100644 index bcba4a0..0000000 --- a/docs/spec/global-config-store.md +++ /dev/null @@ -1,115 +0,0 @@ -# GlobalConfig Store — extract machine-level config I/O from WorktreeApi - -## Goals - -- Lift the machine-level `~/.treemon/config.json` read/modify/write code out of `src/Server/WorktreeApi.fs` - into a dedicated `src/Server/GlobalConfig.fs` module, so the largest production module is left with - just the `IWorktreeApi` wiring and `DashboardResponse` assembly it is named for. -- Give the persistence concern a named home that matches its already-separate test suites - (`ConfigWriterTests.fs`, `WorktreeRootsConfigTests.fs`). -- **Behavior-preserving.** No change to config file format, key semantics, locking, atomic-write - behavior, or any `IWorktreeApi` response. The full suite (Unit + Fast + E2E) stays green; E2E asserts - on DOM/CSS, so an identical render proves the move is behaviorally invisible. - -## Expected Behavior - -This is a pure extraction — every externally observable behavior is preserved. The invariants that must -still hold after the move: - -- **Config location.** `globalConfigDir` resolves `TREEMON_CONFIG_DIR` (test override) else - `~/.treemon`; `config.json` lives there. Unchanged. -- **Single serialized writer.** Every write still funnels through the one in-process lock - (`globalConfigLock`) and the atomic temp-file-then-replace path (`updateConfigAtPath`). No write may - bypass the lock. -- **Never destroy data.** An unparseable `config.json` is still backed up to a timestamped - `*.corrupt-` sibling and a fresh object started; a write only touches the named keys, leaving every - other key intact. -- **`worktreeRoots` missing-vs-empty distinction.** `tryReadWorktreeRootsConfig` still returns `None` - for a missing/malformed key and `Some []` for a present empty list; `readWorktreeRootsConfig` still - flattens missing → `[]`. The startup resolver in `Program.fs` depends on this distinction. -- **Roots add/remove semantics.** `addRootToConfig` still normalizes, requires an existing directory, - is an idempotent no-op for an already-watched path, and surfaces persistence failures as `Error`. - `removeRootFromConfig` still errors on an unwatched path and allows removing a root whose directory no - longer exists. -- **Typed accessors.** `collapsedRepos`, `canvasPaneOpen`, `canvasPosition`, `lastViewedHashes`, and the - editor command/name reader return the same values for the same files as before. - -## Technical Approach - -### New module: `src/Server/GlobalConfig.fs` - -Move the whole config block (currently `WorktreeApi.fs` lines ~178–433) verbatim into -`module Server.GlobalConfig`. It has no dependency on anything else in `WorktreeApi.fs`; its only inputs -are `Log`, `Shared` domain types (`RepoId`, `CanvasPosition`), and `Shared.PathUtils.pathEquals` — all of -which compile before it. Functions to move: - -- **Generic JSON store (private helpers):** `globalConfigPath`, `withConfigDocument`, `readGlobalConfig`, - `globalConfigLock`, `tryParseJsonObject`, `updateGlobalConfig`, plus `canonicalRoot` / `tryNormalizeRoot`. -- **Public surface (consumed outside the module):** `globalConfigDir`, `updateConfigAtPath`, - `readCollapsedRepos`, `writeCollapsedRepos`, `tryReadWorktreeRootsConfig`, `readWorktreeRootsConfig`, - `writeWorktreeRoots`, `addRootToConfig`, `removeRootFromConfig`, `readCanvasPaneOpen`, - `writeCanvasPaneOpen`, `readCanvasPosition`, `writeCanvasPosition`, `readLastViewedHashes`, - `writeLastViewedHashes`, `getEditorConfig`. - -Helpers used only inside the module stay `private`; everything consumed by `WorktreeApi.fs`, -`Program.fs`, or tests is `internal` (assembly-scoped, and `InternalsVisibleTo Tests` keeps the test -references working). Keep the existing doc-comments with the functions they describe. - -### Compile order — `src/Server/Server.fsproj` - -Insert `` **before** `WorktreeApi.fs`. It depends only on `Log.fs`, -`PathUtils.fs` (in `Shared`), and the `Shared` types, all already earlier in the order, so it can slot in -right after `SyncEngine.fs` / `DemoFixture.fs` and before `WorktreeApi.fs`. - -### Update consumers — no compatibility shims (project rule) - -`WorktreeApi.fs` keeps the API wiring and calls the moved functions via `GlobalConfig.*` (add -`open Server.GlobalConfig` or qualify). Other call sites, all moving from `WorktreeApi.*` → -`GlobalConfig.*`: - -| Consumer | References to retarget | -|---|---| -| `src/Server/WorktreeApi.fs` | `getEditorConfig`, `readCollapsedRepos`/`writeCollapsedRepos`, `readCanvasPaneOpen`/`writeCanvasPaneOpen`, `readCanvasPosition`/`writeCanvasPosition`, `readLastViewedHashes`/`writeLastViewedHashes`, `addRootToConfig`/`removeRootFromConfig`, `readWorktreeRootsConfig` | -| `src/Server/Program.fs` | `globalConfigDir` (roots.json path), `tryReadWorktreeRootsConfig`, `writeWorktreeRoots` | -| `src/Tests/ConfigWriterTests.fs` | `open Server.WorktreeApi` → `open Server.GlobalConfig` (uses `updateConfigAtPath`) | -| `src/Tests/WorktreeRootsConfigTests.fs` | `open Server.WorktreeApi` → `open Server.GlobalConfig` (uses roots read/write/add/remove) | -| `src/Tests/ServerStartupResolutionTests.fs` | `Server.WorktreeApi.readWorktreeRootsConfig` / `writeWorktreeRoots` → `Server.GlobalConfig.*` | -| `src/Tests/SmokeTests.fs` | comment mention of `WorktreeApi.globalConfigDir` (line ~38) — keep honest | - -The move and all consumer updates land in **one atomic change** so the build never goes red: once -`globalConfigDir` (etc.) leaves `WorktreeApi`, every `WorktreeApi.globalConfigDir` reference must update in -the same commit. No re-export shims (project forbids backwards-compatibility shims). - -### Verification of the cut - -After the move, `(Get-Content src/Server/WorktreeApi.fs).Count` should drop by ~250 lines (from 870), and -`GlobalConfig.fs` should contain the moved functions. Build + Unit + Fast + E2E stay green. - -## Decisions - -- **Module name `GlobalConfig`, not `Config`.** It owns the *machine-level* `~/.treemon/config.json`, - distinct from the per-worktree `.treemon.json` handled by `TreemonConfig.fs`. The name keeps that - distinction obvious and avoids collision with the existing `TreemonConfig` module. -- **One file, not split by concern.** The generic JSON store and the typed accessors are cohesive (the - accessors are thin wrappers over the store) and share the lock/atomic-write helpers; splitting them - would scatter a single responsibility. The whole thing is one ~256-line module. -- **`internal` over `public`.** The surface is only consumed inside the `Treemon` assembly and its test - assembly (via `InternalsVisibleTo`), so `internal` preserves encapsulation while keeping every existing - reference compiling. -- **Atomic move, no shims.** Per the project's no-backwards-compatibility-shims rule, consumers are - updated in the same change rather than left pointing at re-exports. - -## Key Files - -- **New:** `src/Server/GlobalConfig.fs` — machine-level config store + typed accessors. -- **Shrinks:** `src/Server/WorktreeApi.fs` — left with `IWorktreeApi` wiring + `DashboardResponse` assembly. -- **Compile order:** `src/Server/Server.fsproj`. -- **Consumers:** `src/Server/Program.fs`, `src/Tests/ConfigWriterTests.fs`, - `src/Tests/WorktreeRootsConfigTests.fs`, `src/Tests/ServerStartupResolutionTests.fs`. -- **Docs to keep honest:** `docs/spec/worktree-monitor.md` (Key Files table), - `docs/spec/future/code-improvements.md` (move the item to *Done*). - -## Related Specs - -- `docs/spec/worktree-monitor.md` — the watched-roots / `config.json` behavior this code implements. -- `docs/spec/future/code-improvements.md` — the running backlog; this is candidate #7 (the survey's top pick). diff --git a/docs/spec/worktree-monitor.md b/docs/spec/worktree-monitor.md index 6c7f3ea..e2cb31a 100644 --- a/docs/spec/worktree-monitor.md +++ b/docs/spec/worktree-monitor.md @@ -30,6 +30,14 @@ - Scheduler picks most-overdue task globally across all repos - Branch events scoped by `{repoId}/{branch}` to prevent cross-repo collisions +### Configuration Store + +Machine-level state persists in `~/.treemon/config.json` (or `$TREEMON_CONFIG_DIR` when set, for tests). `src/Server/GlobalConfig.fs` is the sole owner of that file — a single JSON store fronted by typed accessors, with these invariants: + +- **Single serialized writer, atomic on disk.** Every mutation funnels through one in-process lock and writes via a temp-file-then-replace; no write bypasses the lock, so concurrent updates can't interleave or leave a partially written file. +- **Never destroy data.** An unparseable `config.json` is backed up to a timestamped `*.corrupt-` sibling before a fresh object is started, and each write touches only its own named keys — every unrelated key is left intact. +- **Typed accessors over one store.** Watched roots (with the missing-vs-empty distinction the startup resolver depends on — see Multi-Repo above), canvas pane open/position, collapsed repos, last-viewed hashes, and the editor command/name reader are thin wrappers over the same locked store. + ### Worktree Identification - All `IWorktreeApi` methods use `WorktreePath` (filesystem path) as the worktree identifier — no branch name ambiguity across repos @@ -263,6 +271,7 @@ After the burst, `lastRuns` is pre-populated and the normal sequential loop take - Windows Terminal per-window tracking via HWND: tabs aren't reliably addressable, one window per worktree is simple and predictable - Upstream remote auto-detection over config-only: `upstream` remote name is the universal convention for fork workflows; config override available for non-standard setups - Watched roots are server-owned and restart-to-apply (not live-updated): `tm add`/`remove` persist to the global config and take effect on the next server (re)start (the `treemon.ps1` shims trigger it when prod is running). Chosen for simpler code — no per-root scheduler-state machinery; live application remains a clean future extension. The server is the single writer of `config.json` (with an internal write lock); the online-only CLI never writes config files, which removes the cross-process clobber hazard. +- `GlobalConfig` vs `TreemonConfig` — the machine-level `~/.treemon/config.json` and the per-worktree `.treemon.json` (`testCommand`, `baseBranch`, `upstreamRemote`) are deliberately separate stores in separate modules, named so the machine-vs-worktree scope is obvious and the two never collide. ## Related Specs From 3b986d8d6edd1a706dece579a02fd8c8475b4066 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Fri, 26 Jun 2026 16:27:56 +0200 Subject: [PATCH 6/9] tm-improvement-survey-l9e Harden updateConfigAtPath against a config path with no parent directory (defensive, Low) Added a ot (String.IsNullOrEmpty dir) guard so directory creation is skipped (rather than attempted-and-caught) when the config path has no parent directory. Trigger is unreachable for current callers; defensive hardening only per focused-review finding 2. --- src/Server/GlobalConfig.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Server/GlobalConfig.fs b/src/Server/GlobalConfig.fs index ea87a31..d5399d5 100644 --- a/src/Server/GlobalConfig.fs +++ b/src/Server/GlobalConfig.fs @@ -75,7 +75,7 @@ let internal updateConfigAtPath (configPath: string) (updates: (string * System. lock globalConfigLock (fun () -> try let dir = Path.GetDirectoryName(configPath) - if not (Directory.Exists(dir)) then Directory.CreateDirectory(dir) |> ignore + if not (String.IsNullOrEmpty dir) && not (Directory.Exists dir) then Directory.CreateDirectory dir |> ignore let root = if not (File.Exists(configPath)) then From 9a85421b3d1508cdd97c4821c359d419bce705c1 Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 29 Jun 2026 13:16:30 +0200 Subject: [PATCH 7/9] Drop volatile line-count figures from code-improvements backlog --- docs/spec/future/code-improvements.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/docs/spec/future/code-improvements.md b/docs/spec/future/code-improvements.md index d915d5d..13d13b2 100644 --- a/docs/spec/future/code-improvements.md +++ b/docs/spec/future/code-improvements.md @@ -49,10 +49,10 @@ its own worktree. This file is the entry point; detailed designs live in their o - **`GlobalConfig` store extraction** — lifted the machine-level `~/.treemon/config.json` read/modify/write (single-writer lock, atomic temp-file replace, missing-vs-empty `worktreeRoots` semantics, plus the canvas / collapsed-repos / last-viewed-hashes / editor - accessors) out of `WorktreeApi.fs` (870 → 614 L) into `src/Server/GlobalConfig.fs`, leaving the + accessors) out of `WorktreeApi.fs` into `src/Server/GlobalConfig.fs`, leaving the API module with just `IWorktreeApi` wiring + `DashboardResponse` assembly. Behavior-preserving; see `docs/spec/worktree-monitor.md` (Configuration Store). -- **App.fs view extraction** — `src/Client/App.fs` 1861 → 795 lines. Extracted +- **App.fs view extraction** — split `src/Client/App.fs` into smaller modules. Extracted `OverviewViews.fs`, `CardViews.fs` (with `CardViewProps`/`CardCallbacks` records), `MascotState.fs`/`MascotView.fs`, and `CanvasView.fs`; flat `Msg` + single `update` preserved. Branch `code-improvement`. From 78f747c0d7f1dada0db8a6db9ee667d90099392f Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 29 Jun 2026 13:59:25 +0200 Subject: [PATCH 8/9] Consolidate global config reads into GlobalConfig; flatten canvas tuple matches Move readIgnoreWorktreePatterns/buildIgnorePredicate into GlobalConfig (TREEMON_CONFIG_DIR-aware), delete the duplicate readers/path in TreemonConfig, and repoint WorktreeApi + RefreshScheduler + tests. Flatten nested matches in readCanvasPosition/readCanvasSize. --- src/Server/GlobalConfig.fs | 52 +++++++++++++++++++++++++--------- src/Server/RefreshScheduler.fs | 4 +-- src/Server/Server.fsproj | 2 +- src/Server/TreemonConfig.fs | 42 --------------------------- src/Server/WorktreeApi.fs | 2 +- src/Tests/SchedulerTests.fs | 22 +++++++------- 6 files changed, 54 insertions(+), 70 deletions(-) diff --git a/src/Server/GlobalConfig.fs b/src/Server/GlobalConfig.fs index 6b376b6..f1a42b0 100644 --- a/src/Server/GlobalConfig.fs +++ b/src/Server/GlobalConfig.fs @@ -2,6 +2,7 @@ module Server.GlobalConfig open System open System.IO +open System.Text.RegularExpressions open Shared open Shared.PathUtils @@ -53,6 +54,33 @@ let internal readCollapsedRepos () : Set = |> Set.ofSeq | _ -> Set.empty) +/// Reads `ignoreWorktreePatterns` from the machine-level config — the regexes for worktrees the +/// dashboard should hide. Lives here so all global-config reads share the one +/// `TREEMON_CONFIG_DIR`-aware path. +let readIgnoreWorktreePatterns () : string list = + withConfigDocument [] (fun root -> + match root.TryGetProperty("ignoreWorktreePatterns") with + | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.Array -> + prop.EnumerateArray() + |> Seq.choose (fun el -> + if el.ValueKind = System.Text.Json.JsonValueKind.String then Some (el.GetString()) + else None) + |> Seq.toList + | _ -> []) + +let buildIgnorePredicate (patterns: string list) : string -> bool = + let regexes = + patterns + |> List.filter (not << String.IsNullOrWhiteSpace) + |> List.choose (fun pattern -> + try Some (Regex($"^(?:{pattern})$", RegexOptions.Compiled)) + with :? ArgumentException -> + Log.log "Config" $"Invalid ignore worktree pattern: '{pattern}'" + None) + match regexes with + | [] -> fun _ -> false + | _ -> fun value -> regexes |> List.exists _.IsMatch(value) + /// Serializes every write to the machine-level `config.json`. All global-config writers /// (collapsedRepos, canvas state, lastViewedHashes, worktreeRoots) funnel through /// `updateConfigAtPath`, so this lock makes the server the single serialized writer and stops @@ -205,14 +233,13 @@ let internal writeCanvasPaneOpen (isOpen: bool) = let internal readCanvasPosition () : CanvasPosition = withConfigDocument CanvasPosition.Right (fun root -> - match root.TryGetProperty("canvasPosition") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.String -> - match prop.GetString() with - | "left" -> CanvasPosition.Left - | "right" -> CanvasPosition.Right - | "top" -> CanvasPosition.Top - | "bottom" -> CanvasPosition.Bottom - | _ -> CanvasPosition.Right + let found, prop = root.TryGetProperty("canvasPosition") + let s = if found && prop.ValueKind = System.Text.Json.JsonValueKind.String then prop.GetString() else "" + match found, s with + | true, "left" -> CanvasPosition.Left + | true, "right" -> CanvasPosition.Right + | true, "top" -> CanvasPosition.Top + | true, "bottom" -> CanvasPosition.Bottom | _ -> CanvasPosition.Right) let internal writeCanvasPosition (position: CanvasPosition) = @@ -226,11 +253,10 @@ let internal writeCanvasPosition (position: CanvasPosition) = let internal readCanvasSize () : CanvasSize = withConfigDocument CanvasSize.Ratio1To1 (fun root -> - match root.TryGetProperty("canvasSize") with - | true, prop when prop.ValueKind = System.Text.Json.JsonValueKind.String -> - match prop.GetString() with - | "2to1" -> CanvasSize.Ratio2To1 - | _ -> CanvasSize.Ratio1To1 + let found, prop = root.TryGetProperty("canvasSize") + let s = if found && prop.ValueKind = System.Text.Json.JsonValueKind.String then prop.GetString() else "" + match found, s with + | true, "2to1" -> CanvasSize.Ratio2To1 | _ -> CanvasSize.Ratio1To1) let internal writeCanvasSize (size: CanvasSize) = diff --git a/src/Server/RefreshScheduler.fs b/src/Server/RefreshScheduler.fs index b698df9..867936b 100644 --- a/src/Server/RefreshScheduler.fs +++ b/src/Server/RefreshScheduler.fs @@ -518,7 +518,7 @@ let runInitialBurst (agent: MailboxProcessor) (rootPaths: Map TreemonConfig.buildIgnorePredicate + let ignorePredicate = GlobalConfig.readIgnoreWorktreePatterns () |> GlobalConfig.buildIgnorePredicate let ignoredPaths = resolveIgnoredPaths ignorePredicate state.Repos let filters = { Archived = archivedPaths; Ignored = ignoredPaths } Log.log "Scheduler" "Starting initial burst — Phase 2 (local data + fetch)" @@ -694,7 +694,7 @@ let start (agent: MailboxProcessor) (worktreeRoots: string list) (ct: let archivedBranchSets = readArchivedBranchSets rootPaths let archivedPaths = resolveArchivedPaths archivedBranchSets repos - let ignorePredicate = TreemonConfig.readIgnoreWorktreePatterns () |> TreemonConfig.buildIgnorePredicate + let ignorePredicate = GlobalConfig.readIgnoreWorktreePatterns () |> GlobalConfig.buildIgnorePredicate let ignoredPaths = resolveIgnoredPaths ignorePredicate repos let tasks = buildTaskList { Archived = archivedPaths; Ignored = ignoredPaths } repos let now = DateTimeOffset.UtcNow diff --git a/src/Server/Server.fsproj b/src/Server/Server.fsproj index 4ce4fe8..9fd4ea8 100644 --- a/src/Server/Server.fsproj +++ b/src/Server/Server.fsproj @@ -18,6 +18,7 @@ + @@ -38,7 +39,6 @@ - diff --git a/src/Server/TreemonConfig.fs b/src/Server/TreemonConfig.fs index e77fa69..dc221ba 100644 --- a/src/Server/TreemonConfig.fs +++ b/src/Server/TreemonConfig.fs @@ -102,45 +102,3 @@ let readBaseBranch (repoRoot: string) : string = let readTestCommand (repoRoot: string) : string option = readStringConfig repoRoot "testCommand" - -let globalConfigPath () = - Path.Combine( - Environment.GetFolderPath(Environment.SpecialFolder.UserProfile), - ".treemon", - "config.json") - -let private withGlobalConfig (defaultValue: 'a) (f: JsonElement -> 'a) : 'a = - let path = globalConfigPath () - if not (File.Exists path) then defaultValue - else - try - let json = File.ReadAllText path - use doc = JsonDocument.Parse json - f doc.RootElement - with ex -> - Log.log "TreemonConfig" $"Failed to read global config: {ex.Message}" - defaultValue - -let readIgnoreWorktreePatterns () : string list = - withGlobalConfig [] (fun root -> - match root.TryGetProperty("ignoreWorktreePatterns") with - | true, prop when prop.ValueKind = JsonValueKind.Array -> - prop.EnumerateArray() - |> Seq.choose (fun el -> - if el.ValueKind = JsonValueKind.String then Some (el.GetString()) - else None) - |> Seq.toList - | _ -> []) - -let buildIgnorePredicate (patterns: string list) : string -> bool = - let regexes = - patterns - |> List.filter (not << String.IsNullOrWhiteSpace) - |> List.choose (fun pattern -> - try Some (Regex($"^(?:{pattern})$", RegexOptions.Compiled)) - with :? ArgumentException -> - Log.log "TreemonConfig" $"Invalid ignore worktree pattern: '{pattern}'" - None) - match regexes with - | [] -> fun _ -> false - | _ -> fun value -> regexes |> List.exists _.IsMatch(value) diff --git a/src/Server/WorktreeApi.fs b/src/Server/WorktreeApi.fs index 1b457b9..fd58f26 100644 --- a/src/Server/WorktreeApi.fs +++ b/src/Server/WorktreeApi.fs @@ -189,7 +189,7 @@ let getWorktrees let! activeSessions = SessionManager.getActiveSessions sessionAgent let activeSessionPaths = activeSessions |> Map.keys |> Set.ofSeq - let ignorePredicate = TreemonConfig.readIgnoreWorktreePatterns () |> TreemonConfig.buildIgnorePredicate + let ignorePredicate = GlobalConfig.readIgnoreWorktreePatterns () |> GlobalConfig.buildIgnorePredicate let repos = state.Repos diff --git a/src/Tests/SchedulerTests.fs b/src/Tests/SchedulerTests.fs index 5d83b60..5a79c4d 100644 --- a/src/Tests/SchedulerTests.fs +++ b/src/Tests/SchedulerTests.fs @@ -1041,7 +1041,7 @@ type ResolveIgnoredPathsTests() = [ RepoId "Repo1", makeRepo [ makeWorktree "/r1/main" "main"; makeWorktree "/r1/feat" "feature/abc" ] ] |> Map.ofList - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "feature/.*" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "feature/.*" ] let result = resolveIgnoredPaths predicate repos let ignored = result |> Map.find (RepoId "Repo1") @@ -1054,7 +1054,7 @@ type ResolveIgnoredPathsTests() = [ RepoId "Repo1", makeRepo [ makeWorktree "/r1/main" "main"; makeWorktree "/r1/archive-foo" "feature/abc" ] ] |> Map.ofList - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "archive-.*" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "archive-.*" ] let result = resolveIgnoredPaths predicate repos let ignored = result |> Map.find (RepoId "Repo1") @@ -1069,7 +1069,7 @@ type ResolveIgnoredPathsTests() = KnownPaths = Set.ofList [ "/r1/detached" ] } let repos = [ RepoId "Repo1", repo ] |> Map.ofList - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "detached" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "detached" ] let result = resolveIgnoredPaths predicate repos let ignored = result |> Map.find (RepoId "Repo1") @@ -1083,7 +1083,7 @@ type ResolveIgnoredPathsTests() = KnownPaths = Set.ofList [ "/r1/detached" ] } let repos = [ RepoId "Repo1", repo ] |> Map.ofList - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "archive-.*" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "archive-.*" ] let result = resolveIgnoredPaths predicate repos let ignored = result |> Map.find (RepoId "Repo1") @@ -1095,7 +1095,7 @@ type ResolveIgnoredPathsTests() = [ RepoId "Repo1", makeRepo [ makeWorktree "/r1/main" "main"; makeWorktree "/r1/feat" "feat" ] ] |> Map.ofList - let predicate = Server.TreemonConfig.buildIgnorePredicate [] + let predicate = Server.GlobalConfig.buildIgnorePredicate [] let result = resolveIgnoredPaths predicate repos let ignored = result |> Map.find (RepoId "Repo1") @@ -1109,13 +1109,13 @@ type BuildIgnorePredicateTests() = [] member _.``Empty patterns matches nothing``() = - let predicate = Server.TreemonConfig.buildIgnorePredicate [] + let predicate = Server.GlobalConfig.buildIgnorePredicate [] Assert.That(predicate "main", Is.False) Assert.That(predicate "feature/abc", Is.False) [] member _.``Regex pattern matches values``() = - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "feature/.*"; "hotfix/.*" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "feature/.*"; "hotfix/.*" ] Assert.That(predicate "feature/abc", Is.True) Assert.That(predicate "hotfix/urgent", Is.True) Assert.That(predicate "main", Is.False) @@ -1123,19 +1123,19 @@ type BuildIgnorePredicateTests() = [] member _.``Pattern is anchored``() = - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "feat" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "feat" ] Assert.That(predicate "feat", Is.True) Assert.That(predicate "feature", Is.False) Assert.That(predicate "my-feat", Is.False) [] member _.``Invalid regex is skipped``() = - let predicate = Server.TreemonConfig.buildIgnorePredicate [ "[invalid"; "main" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ "[invalid"; "main" ] Assert.That(predicate "main", Is.True) [] member _.``Whitespace-only patterns are skipped``() = - let predicate = Server.TreemonConfig.buildIgnorePredicate [ ""; " "; "main" ] + let predicate = Server.GlobalConfig.buildIgnorePredicate [ ""; " "; "main" ] Assert.That(predicate "main", Is.True) Assert.That(predicate "", Is.False) @@ -1244,4 +1244,4 @@ type ExpediteRefreshTests() = Assert.That(state2.ExpeditedRepos |> Set.contains repo1, Is.False) Assert.That(state2.ExpeditedRepos |> Set.contains repo2, Is.True) } - |> Async.RunSynchronously \ No newline at end of file + |> Async.RunSynchronously From afb68b63493b395a84aec03c3c565ecf0a18014f Mon Sep 17 00:00:00 2001 From: Petr Pokorny Date: Mon, 29 Jun 2026 17:15:44 +0200 Subject: [PATCH 9/9] Fix flaky demo-mode transition test by waiting a full cycle The demo loops every 24s (12 frames x 2s), but the test only waited 12s for a coding-tool dot transition. The auth card is the only toggling dot and stays Done for up to 14s across the cycle wrap, so the test could load in a phase where it never observed a change. Wait a full cycle plus buffer (26s) and correct the stale ~10s spec note to ~24s. --- docs/spec/worktree-monitor.md | 2 +- src/Tests/DemoModeTests.fs | 7 +++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/docs/spec/worktree-monitor.md b/docs/spec/worktree-monitor.md index e2cb31a..9fe37b8 100644 --- a/docs/spec/worktree-monitor.md +++ b/docs/spec/worktree-monitor.md @@ -161,7 +161,7 @@ Windows Terminal integration for spawning, tracking, and focusing terminal windo ### Demo Mode -`treemon.ps1 demo` launches the server with `--demo` flag, cycling through pre-built `FixtureData` frames (~10s loop) that cover all dashboard features. No client changes — same poll-based rendering. See `src/Server/DemoFixture.fs`. +`treemon.ps1 demo` launches the server with `--demo` flag, cycling through pre-built `FixtureData` frames (~24s loop) that cover all dashboard features. No client changes — same poll-based rendering. See `src/Server/DemoFixture.fs`. ### Resilience diff --git a/src/Tests/DemoModeTests.fs b/src/Tests/DemoModeTests.fs index acddc78..f36247c 100644 --- a/src/Tests/DemoModeTests.fs +++ b/src/Tests/DemoModeTests.fs @@ -234,8 +234,11 @@ type DemoModeTests() = TestContext.Out.WriteLine( $"Initial state - working: {initialWorking}, waiting: {initialWaiting}, done: {initialDone}") - // Wait for a state transition (up to 12s = full cycle + buffer) - let deadline = DateTime.UtcNow.AddSeconds(12.0) + // The demo loops every 24s (12 frames x 2s); the only coding-tool dot that toggles is + // the auth card (Done <-> Working), which stays in one state for up to 14s across the + // cycle wrap. Wait a full cycle plus buffer so the opposite state is observed no matter + // which phase the page loaded in. + let deadline = DateTime.UtcNow.AddSeconds(26.0) let mutable transitioned = false while DateTime.UtcNow < deadline && not transitioned do