diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 0000000..52b32f8 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,14 @@ +root = true + +[*] +charset = utf-8 +end_of_line = lf +insert_final_newline = true +trim_trailing_whitespace = true + +[*.rkt] +indent_style = space +indent_size = 2 + +[*.md] +trim_trailing_whitespace = false diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..33f401f --- /dev/null +++ b/.gitattributes @@ -0,0 +1,15 @@ +* text=auto eol=lf + +*.png binary +*.jpg binary +*.jpeg binary +*.gif binary +*.ico binary +*.icns binary +*.dll binary +*.exe binary +*.msi binary +*.dmg binary +*.zip binary +*.gz binary +*.AppImage binary diff --git a/.github/ISSUE_TEMPLATE/bug_report.yml b/.github/ISSUE_TEMPLATE/bug_report.yml new file mode 100644 index 0000000..4a2bb32 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/bug_report.yml @@ -0,0 +1,72 @@ +name: Bug report +description: Report a reproducible Glaze runtime, native integration, or packaging problem +title: "[bug] " +body: + - type: markdown + attributes: + value: | + Thanks for reporting a Glaze bug. Native and packaging behavior is platform-sensitive, so exact environment details are important. + - type: textarea + id: problem + attributes: + label: What happened? + description: Describe the observed behavior and what you expected instead. + validations: + required: true + - type: textarea + id: reproduce + attributes: + label: Minimal reproduction + description: Include the smallest Racket code or repository/commands that reproduce the problem. + placeholder: | + raco glaze init repro + cd repro + ... + validations: + required: true + - type: dropdown + id: os + attributes: + label: Operating system + options: + - Windows + - macOS + - Linux + - Other + validations: + required: true + - type: input + id: os-version + attributes: + label: OS version / architecture + placeholder: "macOS 15 arm64, Windows 11 x64, Ubuntu 24.04 x86_64" + validations: + required: true + - type: input + id: racket + attributes: + label: Racket version + placeholder: "8.12 CS / 9.3 CS" + validations: + required: true + - type: input + id: glaze + attributes: + label: Glaze version or commit + placeholder: "0.7 or commit SHA" + validations: + required: true + - type: textarea + id: logs + attributes: + label: Relevant logs / output + render: text + - type: checkboxes + id: checks + attributes: + label: Checks + options: + - label: I searched existing issues for the same problem. + required: true + - label: I removed secrets, license private keys, tokens, and customer data from the report. + required: true diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml new file mode 100644 index 0000000..55583e9 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -0,0 +1,5 @@ +blank_issues_enabled: true +contact_links: + - name: Security vulnerability + url: https://github.com/turinglambdaai/glaze/security/policy + about: Please use the private security reporting path described in SECURITY.md instead of a public issue. diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..e016fc8 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,9 @@ +version: 2 +updates: + - package-ecosystem: github-actions + directory: / + schedule: + interval: weekly + open-pull-requests-limit: 5 + labels: + - dependencies diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md new file mode 100644 index 0000000..198c184 --- /dev/null +++ b/.github/pull_request_template.md @@ -0,0 +1,16 @@ +## Summary + +Describe the user-visible or maintenance problem this PR solves. + +## Validation + +- [ ] `raco make glaze/main.rkt glaze-cli/cli.rkt` +- [ ] `raco test glaze-test/` +- [ ] Public API changes are documented, or this PR does not change the public API +- [ ] Platform-specific behavior is behind the existing dispatcher boundary +- [ ] Packaging changes were exercised on the affected platform(s) +- [ ] Security-sensitive changes avoid shell interpolation and keep loopback capability boundaries intact + +## Compatibility + +Call out any behavior change that existing Glaze applications may observe. Prefer additive changes during the 0.x stabilization period. diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 80e968b..1d93906 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -6,9 +6,22 @@ on: pull_request: branches: [main] +# CI only needs to read the repository. Keep the default GITHUB_TOKEN surface +# minimal so third-party actions and native packaging steps cannot write back. +permissions: + contents: read + +# A PR can receive many small stabilization commits. Only the newest SHA is +# useful; cancel stale runs so they do not consume the cross-platform runners +# or delay feedback for the current head. +concurrency: + group: ci-${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + jobs: test: runs-on: ${{ matrix.os }} + timeout-minutes: 20 strategy: fail-fast: false matrix: @@ -16,10 +29,10 @@ jobs: racket-version: ['8.12'] steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@fbc6f3992d24b796d5a048ff273f7fcc4a7b6c09 # v5.1.0 - name: Install Racket - uses: Bogdanp/setup-racket@v1.11 + uses: Bogdanp/setup-racket@2466913449df77df2bad149d1f2fc4e1ea4795dd # v1.15 with: version: ${{ matrix.racket-version }} @@ -27,12 +40,42 @@ jobs: shell: bash run: raco pkg install --auto --no-docs --link "$PWD" + - name: Compile public entrypoints + run: raco make glaze/main.rkt glaze-cli/cli.rkt scripts/package-entry-smoke.rkt + - name: Run tests run: raco test glaze-test/ - - name: Check formatting - run: raco fmt --check glaze/ glaze-cli/ glaze-test/ - continue-on-error: true + source-package: + # Release hygiene: prove the filtered source archive is independently + # installable. This job intentionally does not link the checkout first. + runs-on: ubuntu-latest + timeout-minutes: 20 + + steps: + - uses: actions/checkout@fbc6f3992d24b796d5a048ff273f7fcc4a7b6c09 # v5.1.0 + + - name: Install Racket + uses: Bogdanp/setup-racket@2466913449df77df2bad149d1f2fc4e1ea4795dd # v1.15 + with: + version: '8.12' + + - name: Create source package + shell: bash + run: | + cd .. + raco pkg create --source --format zip glaze + test -s glaze.zip + + - name: Install source package archive + shell: bash + run: raco pkg install --auto --no-docs ../glaze.zip + + - name: Verify installed facade and CLI + shell: bash + run: | + racket -e '(require glaze) (unless (procedure? run-app) (error "missing run-app"))' + raco glaze help webview-e2e: # Real-window WebView end-to-end on each OS: open -> load (title @@ -40,6 +83,7 @@ jobs: # nothing extra (WebView2 runtime is preinstalled); Linux runs under # Xvfb with the WebKitGTK packages. runs-on: ${{ matrix.os }} + timeout-minutes: 30 strategy: fail-fast: false matrix: @@ -47,10 +91,10 @@ jobs: racket-version: ['8.12'] steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@fbc6f3992d24b796d5a048ff273f7fcc4a7b6c09 # v5.1.0 - name: Install Racket - uses: Bogdanp/setup-racket@v1.11 + uses: Bogdanp/setup-racket@2466913449df77df2bad149d1f2fc4e1ea4795dd # v1.15 with: version: ${{ matrix.racket-version }} @@ -83,6 +127,7 @@ jobs: # Build a sample app with `raco glaze build --installer` on each platform # and upload the resulting distribution + installer as artifacts. runs-on: ${{ matrix.os }} + timeout-minutes: 45 strategy: fail-fast: false matrix: @@ -90,10 +135,10 @@ jobs: racket-version: ['8.12'] steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@fbc6f3992d24b796d5a048ff273f7fcc4a7b6c09 # v5.1.0 - name: Install Racket - uses: Bogdanp/setup-racket@v1.11 + uses: Bogdanp/setup-racket@2466913449df77df2bad149d1f2fc4e1ea4795dd # v1.15 with: version: ${{ matrix.racket-version }} @@ -101,31 +146,45 @@ jobs: shell: bash run: raco pkg install --auto --no-docs --link "$PWD" - - name: Install installer toolchain (Linux) + - name: Install packaging dependencies (Linux) if: runner.os == 'Linux' run: | sudo apt-get update sudo apt-get install -y libayatana-appindicator3-dev libgtk-3-dev - # AppImage tooling (optional; build falls back to tar.gz if missing) - sudo wget -q https://github.com/AppImage/AppImageKit/releases/download/continuous/appimagetool-x86_64.AppImage -O /usr/local/bin/appimagetool - sudo chmod +x /usr/local/bin/appimagetool + # Do not download and execute AppImageKit's mutable `continuous` + # release in CI. With no AppImage tool installed, Glaze deliberately + # exercises its portable tar.gz installer fallback instead. - name: Install installer toolchain (Windows) if: runner.os == 'Windows' + shell: pwsh run: | - # WiX Toolset v4 (build falls back to zip if missing) - dotnet tool install --global wix - echo "$HOME/.dotnet/tools" >> $GITHUB_PATH + # Glaze supports WiX v4 syntax, but GitHub's latest global `wix` + # tool is now v7 and requires an additional OSMF license flow. + # NSIS is the other supported native Windows installer backend. + choco install nsis -y --no-progress + $nsis = "C:\Program Files (x86)\NSIS" + if (Test-Path $nsis) { $nsis | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append } + + - name: Verify packaged entry executes + run: racket scripts/package-entry-smoke.rkt - name: Scaffold and build a sample app shell: bash run: | raco glaze init sampleapp cd sampleapp - # --sign - exercises the signing pipeline everywhere: macOS signs - # the bundle ad-hoc (verifiable without a cert); Windows/Linux - # degrade with a loud warning when no signing toolchain exists. - raco glaze build --name sampleapp --version 0.0.1 --out dist --installer --sign - + # Exercise signing where CI can do it without secrets. On macOS, + # ad-hoc signing is verifiable; Windows signing correctly requires a + # real certificate and is covered by argument/tool failure behavior. + if [ "$RUNNER_OS" = "macOS" ]; then + raco glaze build --name sampleapp --version 0.0.1 --out dist --installer --sign - + else + raco glaze build --name sampleapp --version 0.0.1 --out dist --installer + fi + if [ "$RUNNER_OS" = "Linux" ]; then + test -s dist.tar.gz + fi - name: Verify macOS bundle signature if: runner.os == 'macOS' run: | @@ -133,7 +192,7 @@ jobs: /usr/libexec/PlistBuddy -c "Print :CFBundleShortVersionString" sampleapp/dist/sampleapp.app/Contents/Info.plist | grep -qx "0.0.1" - name: Upload distribution - uses: actions/upload-artifact@v4 + uses: actions/upload-artifact@043fb46d1a93c77aae656e7c1c64a875d1fc6a0a # v7.0.1 with: name: glaze-${{ runner.os }}-dist path: | @@ -143,3 +202,25 @@ jobs: sampleapp/dist/*.msi sampleapp/dist/*.dmg sampleapp/dist/*.AppImage + + package-racket-9-3-macos: + # Regression coverage for the macOS/Racket 9.3 launcher failure reported + # in issue #1. This job executes the final packaged binary, not merely the + # build command. + runs-on: macOS-latest + timeout-minutes: 30 + + steps: + - uses: actions/checkout@fbc6f3992d24b796d5a048ff273f7fcc4a7b6c09 # v5.1.0 + + - name: Install Racket + uses: Bogdanp/setup-racket@2466913449df77df2bad149d1f2fc4e1ea4795dd # v1.15 + with: + version: '9.3' + + - name: Install Glaze package + shell: bash + run: raco pkg install --auto --no-docs --link "$PWD" + + - name: Verify packaged entry executes + run: racket scripts/package-entry-smoke.rkt diff --git a/.gitignore b/.gitignore index 8be1de1..28f04dc 100644 --- a/.gitignore +++ b/.gitignore @@ -20,6 +20,17 @@ dist/ # Build output build/ +dist.zip +dist.tar.gz +*.msi +*.dmg +*.AppImage +*-setup.exe + +# Local signing / license secrets +keys/private.pem +*.p12 +*.pfx # showcase runtime artifacts (generated at startup / by self-check) examples/showcase/public/manifest.json diff --git a/CHANGELOG.md b/CHANGELOG.md index bea648a..ca4130c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,29 @@ and this project adheres to [Semantic Versioning](https://semver.org/). ## [Unreleased] +### Changed +- `run-app` now enables a random API capability token by default; pass + `#:api-token #f` explicitly for an intentionally open local API. +- Update checks are non-blocking from the application lifecycle and enforce a + five-second fetch timeout, 2xx status, and a 1 MiB manifest limit. +- `raco glaze init` scaffolds the recommended `run-app` / `(require glaze)` + entry and refuses to overwrite non-empty project directories. + +### Fixed +- Packaging now compiles the user's real entry module, preserving + `(module+ main ...)` execution instead of producing launchers that could + exit successfully without running the application. +- Static-file serving rejects traversal outside `public/`, including resolved + symlinks, and Host validation correctly handles bracketed IPv6 loopback. +- API handler exceptions are reported to the trusted error callback but no + longer leak arbitrary exception text in 500 responses. +- Generated JavaScript API bindings safely escape route segments and no longer + use route parameter text as raw JavaScript identifiers. +- Shutdown is idempotent, single-instance listeners are retained for process + lifetime with deterministic cross-process ports, and tray operations dispatch + from each tray handle rather than process-global fallback state. + + ## [0.6.0] - 2026-09-15 ### Added diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index b18a565..da40e35 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,48 +1,87 @@ # Contributing to Glaze +Glaze is a pre-1.0 cross-platform desktop framework. Prefer small changes that preserve application-facing APIs and keep platform details behind the public dispatchers. + ## Development Setup ```bash git clone https://github.com/turinglambdaai/glaze.git cd glaze -raco pkg install --auto --link "$PWD" +raco pkg install --auto --no-docs --link "$PWD" ``` -(The repo root is one single Racket package — this installs the library, -the `raco glaze` CLI, and the docs in one step. `"$PWD"` is needed because -`raco pkg install` requires the source path to end in the package name. -After pulling changes, refresh with `raco pkg update --link "$PWD"`.) +The repository root is one installable Racket package using `collection 'multi`; the `glaze`, `glaze-cli`, `glaze-doc`, and `glaze-test` collections are installed together. + +## Before Opening a Pull Request -## Running Tests +Run the platform-independent suite and compile the public entrypoints: ```bash +raco make glaze/main.rkt glaze-cli/cli.rkt scripts/package-entry-smoke.rkt raco test glaze-test/ ``` +When your change touches WebView or packaging behavior, also run the relevant verification script on the affected operating system. CI exercises native WebView behavior and package construction on Windows, macOS, and Linux, including a macOS/Racket 9.3 packaging regression test. + +### macOS full-occlusion probe + +Changes to background WebView scheduling should also be checked from an interactive macOS desktop session: + +```bash +racket scripts/macos-occlusion-e2e.rkt +``` + +The probe opens a WebView with `#:background-active? #t`, covers it with a larger opaque native `NSWindow`, requires AppKit to report the target as fully occluded, and then checks that a JavaScript timer advances for 35 seconds while the cover remains in place. It deliberately fails if it cannot prove full occlusion. + +This probe is not part of GitHub Actions. On the hosted `macos-26-arm64` image, ordinary WebView load, capture, navigation, and close checks work, but two attempts to establish occlusion left both windows reporting the same undocumented `occlusionState` value (`8192`) even with an oversized higher-level cover. Because the runner cannot demonstrate the precondition, a green result there would not be a valid regression test for issue #2. Keep that issue open until this probe passes reliably in an environment whose WindowServer reports real occlusion. + +## Architecture Rules + +Read [`docs/architecture.md`](docs/architecture.md) before moving modules or adding a new capability. In particular: + +- normal applications should prefer `(require glaze)`; +- `glaze/main.rkt` is the compatibility-preserving application facade; +- platform-specific modules belong behind `webview/main.rkt`, `tray/main.rkt`, or `sys/main.rkt`; +- do not make platform backends depend on application-level orchestration; +- shared protocols should not be duplicated independently in each backend; +- avoid large directory migrations solely for aesthetics; +- new public behavior should have a platform-independent contract test when possible. + ## Code Style -- Follow standard Racket conventions -- Use `raco fmt` for formatting -- Add tests for new features -- Update Scribble documentation +Follow the dominant Racket style already present in the repository. The optional [`fmt`](https://pkgs.racket-lang.org/package/fmt) package can be installed with: + +```bash +raco pkg install fmt +``` + +Do not reformat unrelated files in a functional pull request. Formatting-only churn makes native and lifecycle changes harder to review. + +## Tests and Documentation + +A change is not complete when only the happy path works. Prefer small regression tests for: + +- public facade exports and argument validation; +- lifecycle and cleanup behavior; +- platform-independent protocol logic; +- security boundaries such as path containment and localhost API access; +- package artifacts that actually execute, not merely build successfully. + +Update Scribble/API documentation and user-facing examples when a public contract changes. Do not document features that are only planned. ## Pull Requests -1. Fork the repository -2. Create a feature branch -3. Make your changes -4. Run tests -5. Submit a PR with a clear description +Keep each PR focused enough to explain why every changed file is necessary. In the description include the problem, compatibility impact, tests run, and any platform behavior you could not verify locally. -## Package Structure +Security issues should follow [`SECURITY.md`](SECURITY.md) instead of being disclosed with exploit details in a public issue. -The repo root is a single installable package; each top-level directory is a -Racket collection: +## Package Structure | Directory | Purpose | -|-----------|---------| -| `glaze/` | Core implementation (collection `glaze`) | +|---|---| +| `glaze/` | Framework implementation and public facade | | `glaze-cli/` | `raco glaze` commands | | `glaze-doc/` | Scribble documentation | -| `glaze-test/` | Tests | -| `examples/` | Runnable examples (not compiled by setup) | +| `glaze-test/` | Regression and contract tests | +| `examples/` | Runnable examples | +| `scripts/` | CI and verification scripts | diff --git a/README.md b/README.md index 924bc06..2b2b1de 100644 --- a/README.md +++ b/README.md @@ -1,189 +1,63 @@ # Glaze -Build desktop apps with a [Racket](https://racket-lang.org/) backend and a web frontend. A [Tauri](https://tauri.app/)-like framework for Racket — write your app logic in Racket, build your UI with HTML/CSS/JS, and ship a desktop application. +A Lisp-native framework for building modern desktop applications with Racket. -[![CI](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml/badge.svg)](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml) ![Racket](https://img.shields.io/badge/Racket-9F1D20?logo=racket&logoColor=white) [![License](https://img.shields.io/badge/license-MIT-blue)](LICENSE) [![Release](https://img.shields.io/badge/release-0.7.0-C15F3C)](CHANGELOG.md) +Glaze lets you keep application logic in Racket, build the UI with normal web technologies, and connect that UI to native desktop capabilities such as WebView windows, system tray menus, clipboard access, notifications, dialogs, and application packaging. -**English** · [中文](README.zh-CN.md) - -

Glaze Showcase — every capability in one window

- -## Why Glaze? - -Racket's `racket/gui` works but is hard to style into a modern product-grade UI. Glaze takes a different approach: Racket serves the local application frontend and displays it inside a **native desktop window** backed by the OS WebView — WebView2 on Windows, WKWebView on macOS, and WebKitGTK on Linux. - -You get: - -- **Racket for logic** — the full power of Racket's macro system, contracts, pattern matching -- **Web for UI** — Tailwind, Svelte, React, or any web framework -- **Native desktop shell** — a real OS window with an embedded system WebView -- **JSON API bridge** — the page calls Racket with plain `fetch("/api/...")` - -Glaze is deliberately **GUI-first**. If the required native WebView runtime is missing or broken, startup fails with platform-specific installation/repair instructions. It does **not** silently turn the desktop app into a browser tab. +[![CI](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml/badge.svg)](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml) ![Racket](https://img.shields.io/badge/Racket-9F1D20?logo=racket&logoColor=white) [![License](https://img.shields.io/badge/license-MIT-blue)](LICENSE) -### How it compares +**English** · [中文](README.zh-CN.md) -| | Glaze | Tauri | Electron | wails | -|---|---|---|---|---| -| Backend language | Racket | Rust | JS/Node | Go | -| Native toolchain needed | **none** (pure FFI) | Rust + cargo | none | Go + WebView2 deps | -| Binary size | tiny (Racket exe + assets) | small | 100 MB+ | small | -| Frontend→backend | HTTP JSON routes (`fetch`) | `invoke()` IPC | Node APIs | bindings | -| WebView backends | WebView2 / WKWebView / WebKitGTK | system WebView | bundled Chromium | WebView2/WKWebView | -| Missing WebView behavior | **fail fast + install guidance** | prerequisite error | n/a (bundled) | prerequisite error | -| Agent-friendly UI verification (`title`/`url`/screenshot) | **built-in** | via WebDriver | via CDP | limited | +## Why Glaze -All three WebView backends pass the real-window CI e2e (open, load, capture, navigate, close, on-close). Remaining honest gaps: no typed IPC layer (plain JSON), Linux needs a desktop session or Xvfb. +Racket already has `racket/gui`, but Glaze targets a different style of desktop application: web UI on top of a Racket runtime. -## Platform status +Glaze is not an Electron clone. It does not bundle Chromium or introduce a Node runtime. Its current model is closer to Tauri in spirit: -| Capability | macOS | Windows | Linux | -|---|---|---|---| -| Local HTTP application server | ✅ | ✅ | ✅ | -| System tray | ✅ | ✅ | ✅ (CI-verified) | -| JSON API bridge | ✅ | ✅ | ✅ | -| Native WebView window | ✅ verified end-to-end | ✅ CI e2e (WebView2) | ✅ CI e2e (Xvfb + WebKitGTK) | -| `webview-title` / `webview-url` | ✅ | ✅ | ✅ | -| `webview-capture!` (screenshot) | ✅ | ✅ (PrintWindow + PowerShell PNG) | ✅ (gdk_pixbuf) | -| `#:devtools?` | ✅ (inspectable, macOS 13+) | ✅ (`OpenDevToolsWindow`) | ✅ (WebKitGTK inspector) | +```text +Web UI + | + | HTTP / JSON / SSE + v +Racket runtime + | + +-- WebView + +-- Tray + +-- System capabilities + +-- Packaging helpers + | +Native OS APIs +``` -Native WebView support is mandatory for application startup. `run-app` and `open-window` never open the system browser as a fallback. +The framework currently uses the operating system WebView through Racket FFI: -## Requirements +- Windows: WebView2 +- macOS: WKWebView +- Linux: WebKitGTK -| Platform | Runtime requirement | -|---|---| -| All | [Racket](https://racket-lang.org/) 7.0 or later (includes `raco`) | -| Windows | Microsoft Edge WebView2 Runtime (Evergreen). Glaze ships `WebView2Loader.dll`; install/repair the Runtime if startup says it is unavailable. | -| macOS | WKWebView is built into macOS; run inside a logged-in graphical session. | -| Linux | GTK 3 + WebKitGTK (`libwebkit2gtk-4.1-0` on current Debian/Ubuntu; distro equivalent elsewhere) and a graphical desktop session/Xvfb. | +Glaze is deliberately GUI-first. A working native WebView is required: when +the backend is missing or broken, startup fails with platform-specific +installation or repair guidance instead of silently opening a browser tab. -When startup cannot initialize the native backend, Glaze preserves the underlying backend error and adds actionable installation/repair guidance. Interactive desktop apps also attempt to show the same diagnosis in an OS-level error dialog, which matters for packaged Windows `--gui` executables that have no console. CI suppresses the dialog automatically; `GLAZE_NO_STARTUP_DIALOG=1` disables it explicitly. +The frontend/backend bridge today is intentionally simple: local HTTP JSON routes for requests and Server-Sent Events for backend-to-frontend events. A larger RPC or plugin system is not part of the current public architecture. ## Quick Start -### 1. Install +Install the package: ```bash raco pkg install --auto glaze ``` -A single Racket package: this installs the `glaze` library, the `raco glaze` CLI, and the documentation (browse it later with `raco docs`). - -### 2. Create a new project +Or link a checkout for development: ```bash -raco glaze init myapp -cd myapp +git clone https://github.com/turinglambdaai/glaze.git +cd glaze +raco pkg install --auto --no-docs --link "$PWD" ``` -### 3. Run - -```bash -racket main.rkt -# or -raco glaze dev -``` - -A native desktop window opens and hosts the frontend served by the local Racket server. If the required WebView runtime is missing, startup stops and tells you what to install instead of opening Chrome/Edge/Safari. - -> Prefer installing straight from a GitHub checkout instead of the catalog? -> ```bash -> git clone https://github.com/turinglambdaai/glaze.git -> cd glaze -> raco pkg install --auto --link "$PWD" -> ``` -> To work on Glaze itself, see [CONTRIBUTING.md](CONTRIBUTING.md). - -## CLI Commands - -```bash -raco glaze init # Create a native Glaze desktop project -raco glaze dev # Run this project's native desktop app -raco glaze build # Build a distributable (exe + bundled assets) -raco glaze keygen # Create an RSA keypair for license signing -raco glaze license # Sign or verify offline license files -raco glaze help # Show help -``` - -There is intentionally no browser-mode `dev`/`serve` command. Development and production use the same native WebView path so missing dependencies and native-backend failures cannot be hidden by a browser fallback. - -### `build` - -Package a Glaze project into a platform distribution (`raco exe` + `raco distribute`) with the frontend assets bundled alongside the executable. On macOS the distribution is a proper `.app` bundle with your `--version` stamped into `Info.plist`. - -```bash -raco glaze build --name myapp -raco glaze build --name myapp --version 1.2.0 --installer -``` - -Options: `--name`, `--version`, `--icon <.ico/.icns>`, `--entry ` (default `main.rkt`), `--out ` (default `dist`), `--embed-dlls` (Windows: single-file exe), `--installer`. - -> The installer step probes for the native packaging toolchain (WiX / NSIS on Windows, `create-dmg` / `hdiutil` on macOS, `appimagetool` / `linuxdeploy` on Linux) and **degrades gracefully** to a `.zip` / `.tar.gz` when that packaging toolchain is absent, printing a warning naming what to install. This packaging fallback is unrelated to application startup: the app itself still requires a native WebView. - -### Code signing & notarization - -Unsigned apps get blocked by macOS Gatekeeper and Windows SmartScreen. `build` drives the platform signer for you: - -```bash -# macOS — Developer ID identity, hardened runtime, notarize + staple: -raco glaze build --name myapp \ - --sign "Developer ID Application: Acme Inc (TEAMID)" \ - --notarize acme-notary --installer - -# macOS — ad-hoc (no cert; for local testing / CI): -raco glaze build --name myapp --sign - - -# Windows — signtool with a certificate thumbprint (RFC-3161 timestamped): -raco glaze build --name myapp --sign 40HEXCHARS --installer -``` - -Details: `--sign` takes a codesign identity (macOS) or a SHA-1 thumbprint / subject name for `signtool` (Windows). Hardened runtime is applied automatically on macOS unless `--no-hardened-runtime` is passed (and is skipped for ad-hoc, where its library validation would reject the app's own framework). `--notarize ` submits the built dmg via `notarytool`, waits, and staples the ticket. `--entitlements `, `--timestamp-url ` round it out. Signing failures abort the build; a *missing toolchain* degrades with a loud warning. - -### Licensing (paid apps) - -`glaze/license` ships an offline license-key scheme with zero native dependencies — RSA-2048/SHA-256 signatures via the system `openssl` CLI: - -```bash -raco glaze keygen --out keys -raco glaze license sign --key keys/private.pem --product "MyApp" \ - --subject "customer@example.com" --expiry 2027-12-31 --out app.license -raco glaze license verify --pub keys/public.pem --product "MyApp" app.license -``` - -```racket -(require glaze/license) - -(define r (validate-license "app.license" #:public-key "keys/public.pem" #:product "MyApp")) -(unless (hash-ref r 'valid) - (error 'myapp "license invalid: ~a" (hash-ref r 'reason))) - -(issue-license ... #:machine-id (machine-id)) -``` - -Failure reasons are stable tags (`missing-file`, `malformed`, `signature`, `product`, `expired`, `machine`, `openssl-unavailable`) suitable for UI messages. Honest scope: this defends against casual license sharing — a local attacker can always patch a binary; it is not tamper resistance. - -### Update integrity - -`check-update` passes through an optional `"sha256"` manifest field; verify a downloaded artifact before swapping it in: - -```racket -(define info (check-update manifest-url #:current-version "1.0.0")) -(verify-file-sha256 artifact (hash-ref info 'sha256)) -``` - -## Project Structure - -A new Glaze project looks like this: - -``` -myapp/ -├── main.rkt # Racket entry point -└── public/ - └── index.html # Frontend -``` - -`raco glaze init` generates a native-window entry point. The call is deliberately top-level so the same file also starts correctly when `raco glaze build` packages it through the generated wrapper: +A minimal application can use the single public facade: ```racket #lang racket/base @@ -194,173 +68,139 @@ myapp/ (define-runtime-path public "public") (run-app #:public-dir public - #:title "myapp") + #:title "Hello Glaze") ``` -`run-app` starts the local HTTP application server, opens the native WebView window, and shuts the server down when the window closes. A native-backend failure is fatal and includes dependency guidance. +Put an `index.html` file in `public/`, then run the Racket program. See [`examples/hello/`](examples/hello/) for the complete minimal example. -## Repository Structure +The CLI can also scaffold a project: -One installable package at the repo root; each top-level directory is a Racket collection: - -``` -glaze/ # repo root = the `glaze` package (info.rkt) -├── glaze/ # Library: server, API bridge, webview, tray, sys, build, app -├── glaze-cli/ # CLI tool (raco glaze init / dev / build) -├── glaze-doc/ # Documentation (Scribble) -├── glaze-test/ # Test suite -├── examples/ # Runnable examples -└── scripts/ # CI helper scripts (webview e2e) +```bash +raco glaze init myapp +cd myapp +racket main.rkt ``` -## API +## Features -### `run-app` +Implemented today: -The one-call entry: picks a free port, starts the server (static + JSON API), opens the native WebView window, and blocks until the window closes. +- native WebView windows with lifecycle, navigation, title/URL inspection, screenshots, window controls, and menu integration +- local static-file server with SPA fallback +- JSON API routes and generated browser client support +- Server-Sent Events for backend-to-frontend events +- system tray menus +- clipboard, notifications, open/reveal helpers, and single-instance support +- file dialogs, deep-link helpers, and autolaunch helpers +- application packaging through `raco glaze build` +- update and offline-license utilities +- actionable diagnostics when a required native WebView is unavailable -```racket -(run-app #:public-dir "public" - #:api (list (GET "api/ping" ...))) -;; window closes -> server stops -> (values 'webview shutdown) -``` - -If native WebView startup fails, `run-app` shuts down the local server and raises the same actionable startup error. There is no `#:fallback-browser?` option. +Glaze is implemented in Racket and uses FFI for native integrations; the core framework does not require a C compiler. -### `start-server` / `start-dev-server` - -Starts a local HTTP server serving static files with SPA fallback, plus optional JSON API routes. `start-dev-server` is a backward-compatible alias for the server primitive; it does not define Glaze's application UI mode. - -```racket -(start-server #:port 8080 - #:public-dir "public" - #:api (list (GET "api/ping" (lambda (req) (hasheq 'pong #t))))) -``` +## Platform Support -### `open-browser` +The repository CI tests Racket 8.12 on Windows, macOS, and Linux. Native WebView end-to-end tests run on all three platforms; Linux uses Xvfb plus WebKitGTK in CI. -Low-level utility for opening an external URL in the user's default browser (for example, product documentation or an OAuth page). `run-app` and `open-window` do not call it as a fallback. +| Capability | Windows | macOS | Linux | +|---|---|---|---| +| Local server / JSON API / SSE | Yes | Yes | Yes | +| Native WebView | WebView2 | WKWebView | WebKitGTK | +| System tray | Yes | Yes | Yes | +| System helpers | Yes | Yes | Yes | +| Packaging pipeline | Yes | Yes | Yes | -```racket -(open-browser "https://example.com/docs") -``` +Some native features depend on platform libraries or desktop-session availability. WebView startup failures are fatal and include platform-specific guidance; application code should not import a platform implementation directly. See [`docs/gui-first.md`](docs/gui-first.md) for runtime requirements and diagnostics. -## JavaScript Bridge +## Architecture -The embedded frontend calls Racket with plain `fetch("/api/...")` — Glaze's answer to Tauri's `invoke()`. The local HTTP bridge is easy to exercise independently with developer tools such as `curl`. +The current repository already has a useful boundary: applications can depend on `(require glaze)`, while WebView, tray, and system modules dispatch to platform backends internally. -```racket +```text +Application + | + v (require glaze) - -(GET "api/ping" (lambda (req) (hasheq 'pong #t))) -(POST "api/items/:id/bump" (lambda (req id) (hasheq 'id id 'bumped #t))) -(POST "api/echo" (lambda (req) - (define body (request-json-body req)) - (hasheq 'echo body))) +Public facade: glaze/main.rkt + | + +-------------------------------+ + | | | + v v v +Runtime Capabilities Tooling +app/server webview/main build/update +api/events tray/main CLI + sys/main + | | + +-------+-------+ + v +Platform backends +Windows / macOS / Linux / stub ``` -- Handlers take the request plus captured `:params`; return a jsexpr (auto-wrapped as JSON 200) or a full response. -- `request-json-body` parses the JSON body — Racket jsexpr parses JSON object keys as **symbols** (`(hash-ref body 'delta)`). -- A handler that raises becomes a 500 JSON error, never a broken connection. -- Unmatched requests fall through to static files (SPA `index.html` fallback). - -### Typed routes, one declaration — `define-api-routes` - -```racket -(define-api-routes api - [(POST "api/counter/bump") - (bump [delta exact-nonnegative-integer? 1]) - (hasheq 'count (add1 delta))]) -``` - -One clause defines a Racket procedure, a validated HTTP route, and a JS client entry exposed by `/glaze/api.js`. - -### Backend → frontend push (SSE) +This PR-sized architecture is deliberately smaller than the long-term vision. The next goal is to make dependency direction and lifecycle contracts clearer without moving every implementation file. -```racket -(define bus (make-event-bus)) -(start-server ... #:events bus) -(bus-broadcast! bus 'count-changed (hasheq 'count 42)) -``` +See [`docs/architecture.md`](docs/architecture.md) for the detailed boundary and dependency rules. -```js -glaze.on('count-changed', s => render(s.count)); -``` +## Packages and Collections -The event stream uses the same local origin as the embedded WebView frontend. +The repository root is one installable Racket package using `collection 'multi`. The main top-level collections are: -### Security +- `glaze/` — framework library and public facade +- `glaze-cli/` — `raco glaze` commands +- `glaze-doc/` — Scribble documentation +- `glaze-test/` — test suite +- `examples/` — runnable examples (excluded from package setup compilation) +- `scripts/` — CI and verification scripts -- Requests are only served for Host headers `127.0.0.1` / `localhost` / `[::1]`. -- API handler parameter errors become 400 JSON; handler exceptions become 500 JSON and reach `run-app`'s `#:on-error` hook. -- Optional `#:api-token` protects API routes and SSE. The native app window uses a one-time bootstrap URL to obtain an HttpOnly cookie; programmatic clients use `X-Glaze-Token`. -- Update checks remain opt-in through `run-app #:check-update ...`. +Inside `glaze/`, `webview/`, `tray/`, and `sys/` each contain a public dispatcher plus platform-specific backends. Applications should normally use `(require glaze)` instead of importing backend modules. -## System Integrations (`glaze/sys`) +## Examples -```racket -(require glaze/sys) -(clipboard-set! "hello") -(notify! "Download finished" "report.pdf is ready") -(open-path "/Users/me/report.pdf") -(reveal-path "/Users/me/report.pdf") -(unless (single-instance? "com.me.app") (exit 0)) -``` +Start with the small examples before the full showcase: -Window controls include `webview-set-title!`, `webview-set-size!`, `webview-set-fullscreen!`, and `webview-focus!`. +- [`examples/hello/`](examples/hello/) — minimal `run-app` application +- [`examples/tray/`](examples/tray/) — system tray and menu actions +- [`examples/events/`](examples/events/) — JSON request + SSE event push +- [`examples/counter/`](examples/counter/) — fuller JS/Racket bridge example +- [`examples/showcase/`](examples/showcase/) — integrated feature showcase +- [`examples/agent-verify.rkt`](examples/agent-verify.rkt) — programmatic WebView verification +- [`examples/webview-demo.rkt`](examples/webview-demo.rkt) — direct WebView lifecycle demo -## System Tray +## Project Status -Glaze provides a cross-platform system tray: +Glaze is a pre-1.0 project (`0.7` in package metadata). It already contains working cross-platform implementations and CI coverage, but API boundaries are still being stabilized. -- **Windows** — `Shell_NotifyIconW` -- **macOS** — `NSStatusItem` / `NSMenu` -- **Linux** — `libayatana-appindicator` + `libgtk-3` +For new applications, prefer the `glaze` facade and documented APIs. Direct imports of files such as `webview-windows.rkt`, `tray-macos.rkt`, or `sys-linux.rkt` are implementation details and should not be treated as stable application APIs. -The tray is an optional integration. If its backend is unavailable it may degrade to an inert stub; that is intentionally different from the mandatory main WebView. +Backward compatibility is preferred during the 0.x stabilization work; large rewrites and unnecessary file moves are intentionally avoided. -## App Platform APIs +## Roadmap -```racket -(require glaze) +See [`ROADMAP.md`](ROADMAP.md). The near-term focus is lifecycle, public API clarity, examples, tests, and documentation. IPC/event refinements and additional capabilities come later; a plugin SDK and hot reload are explicitly not part of the current stabilization pass. -(define f (pick-file #:title "Open report" #:filters '(("Reports" "*.rep" "*.csv")))) -(define dir (pick-folder #:title "Where?")) -(define out (save-file-dialog #:title "Save as" #:default-name "out.rep")) +## Documentation -(webview-set-menu! wv - (list (make-menu "File" - (list (make-menu-item "Open…" #:accel "CmdOrCtrl+O" - #:action open-doc) - menu-separator - (make-menu-item "Quit" #:action (lambda () (exit 0))))))) +- [`docs/architecture.md`](docs/architecture.md) — architecture and dependency rules +- [`ROADMAP.md`](ROADMAP.md) — small staged roadmap +- [`CONTRIBUTING.md`](CONTRIBUTING.md) — contributor workflow +- `raco docs glaze` / the `glaze-doc` collection — API reference -(ensure-url-scheme! "myapp") -(auto-launch-set! "MyApp" #t) -(auto-launch-enabled? "MyApp") +## Development -(for ([w (all-webviews)]) (webview-focus! w)) -(wait-for-webviews) +```bash +raco pkg install --auto --no-docs --link "$PWD" +raco make glaze/main.rkt glaze-cli/cli.rkt +raco test glaze-test/ ``` -## Examples +CI additionally runs native WebView end-to-end tests and a packaging smoke build on Windows, macOS, and Linux. -| Example | What it shows | -|---|---| -| [`examples/showcase/`](examples/showcase/) | **Kitchen sink (start here)** — every capability in one native window | -| [`examples/hello/`](examples/hello/) | Minimal native app — `run-app` in 8 lines | -| [`examples/counter/`](examples/counter/) | JS↔Racket bridge — `fetch` calls Racket state | -| [`examples/webview-demo.rkt`](examples/webview-demo.rkt) | Cross-platform native WebView lifecycle: load, navigate, close, verification APIs | -| [`examples/agent-verify.rkt`](examples/agent-verify.rkt) | Agent workflow: assert page state + screenshot with no human | -| [`examples/tray-demo.rkt`](examples/tray-demo.rkt) | Cross-platform system tray with a working menu | +## Contributing -## Roadmap +Contributions are welcome. Please keep changes small enough to review, preserve existing APIs where practical, add regression tests for behavior changes, and keep platform-specific code behind the dispatcher modules. -- [x] **Phase 1** — Local HTTP server + early browser prototype -- [x] **Phase 2** — Frontend asset bundling, system tray, app packaging -- [x] **Phase 3** — Native WebView embedding (WebView2 / WKWebView / WebKitGTK) — verified by the 3-OS CI e2e -- [x] **GUI-first contract** — native WebView required; actionable failure instead of browser fallback +See [`CONTRIBUTING.md`](CONTRIBUTING.md) for the repository workflow. ## License -Licensed under the [MIT License](LICENSE). +MIT — see [`LICENSE`](LICENSE). diff --git a/README.zh-CN.md b/README.zh-CN.md index 690c0f2..1c0e8be 100644 --- a/README.zh-CN.md +++ b/README.zh-CN.md @@ -1,295 +1,215 @@ # Glaze -用 [Racket](https://racket-lang.org/) 做后端、Web 技术做前端，构建桌面应用。一个 Racket 版的 [Tauri](https://tauri.app/) —— 用 Racket 写业务逻辑，用 HTML/CSS/JS 构建界面，最终运行在真正的桌面窗口中。 +一个用 Racket 构建现代桌面应用的 Lisp-native 框架。 -[![CI](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml/badge.svg)](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml) ![Racket](https://img.shields.io/badge/Racket-9F1D20?logo=racket&logoColor=white) [![License](https://img.shields.io/badge/license-MIT-blue)](LICENSE) [![Release](https://img.shields.io/badge/release-0.7.0-C15F3C)](CHANGELOG.md) +Glaze 让应用逻辑继续留在 Racket 中，界面使用普通 Web 技术，并通过统一 API 接入原生 WebView、系统托盘、剪贴板、通知、文件对话框和应用打包等桌面能力。 -[English](README.md) · **中文** - -

Glaze Showcase —— 全部能力一屏尽览

- -## 为什么选择 Glaze？ - -Racket 自带的 `racket/gui` 可以用，但很难做出现代化的产品级 UI。Glaze 采用不同的思路：Racket 在本机提供应用前端与 API，然后把 HTML/CSS/JS 渲染在**原生桌面窗口中的系统 WebView** 里：Windows 使用 WebView2，macOS 使用 WKWebView，Linux 使用 WebKitGTK。 - -你将获得： - -- **Racket 写逻辑** —— 完整的宏系统、contracts、模式匹配 -- **Web 写界面** —— Tailwind、Svelte、React 或任何 Web 框架 -- **真正的桌面外壳** —— 系统原生窗口 + 嵌入式 WebView -- **JSON API 桥接** —— 页面用普通 `fetch("/api/...")` 调用 Racket - -Glaze 明确采用 **GUI-first** 设计。原生 WebView 运行时缺失或初始化失败时，应用会直接启动失败，并给出当前平台的安装/修复指引；**不会再偷偷退化成 Chrome、Edge 或 Safari 里的一个网页。** - -### 横向对比 - -| | Glaze | Tauri | Electron | wails | -|---|---|---|---|---| -| 后端语言 | Racket | Rust | JS/Node | Go | -| 原生工具链 | **无需**（纯 FFI） | Rust + cargo | 无 | Go + WebView2 依赖 | -| 二进制体积 | 极小 | 小 | 100 MB+ | 小 | -| 前后端桥接 | HTTP JSON 路由（`fetch`） | `invoke()` IPC | Node API | 绑定层 | -| WebView 后端 | WebView2 / WKWebView / WebKitGTK | 系统 WebView | 自带 Chromium | WebView2/WKWebView | -| WebView 缺失时 | **明确失败 + 安装指引** | 前置依赖错误 | 不适用（自带） | 前置依赖错误 | -| Agent 友好的 UI 验证（title/url/截图） | **内置** | 需 WebDriver | 需 CDP | 有限 | - -三个平台的 WebView 后端均通过真窗口 CI e2e（open、加载、截图、导航、关闭、on-close）。剩余诚实差距：IPC 仍是纯 JSON、没有类型层；Linux 需要桌面会话或 Xvfb。 +[![CI](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml/badge.svg)](https://github.com/turinglambdaai/glaze/actions/workflows/ci.yml) ![Racket](https://img.shields.io/badge/Racket-9F1D20?logo=racket&logoColor=white) [![License](https://img.shields.io/badge/license-MIT-blue)](LICENSE) -## 平台支持状态 - -| 能力 | macOS | Windows | Linux | -|---|---|---|---| -| 本地应用 HTTP 服务 | ✅ | ✅ | ✅ | -| 系统托盘 | ✅ | ✅ | ✅（CI 验证） | -| JSON API 桥接 | ✅ | ✅ | ✅ | -| 原生 WebView 窗口 | ✅ 端到端验证 | ✅ CI e2e（WebView2） | ✅ CI e2e（Xvfb + WebKitGTK） | -| `webview-title` / `webview-url` | ✅ | ✅ | ✅ | -| `webview-capture!`（截图） | ✅ | ✅（PrintWindow + PowerShell 转 PNG） | ✅（gdk_pixbuf） | -| `#:devtools?` | ✅（inspectable，macOS 13+） | ✅（`OpenDevToolsWindow`） | ✅（WebKitGTK inspector） | - -原生 WebView 是应用启动的必要条件。`run-app` / `open-window` **不会**在失败时打开系统浏览器。 - -## 环境要求 +[English](README.md) · **中文** -| 平台 | 运行时要求 | -|---|---| -| 全平台 | [Racket](https://racket-lang.org/) 7.0 或更高版本（包含 `raco`） | -| Windows | Microsoft Edge WebView2 Runtime（Evergreen）。Glaze 已自带 `WebView2Loader.dll`；若启动提示运行时不可用，请安装或修复 WebView2 Runtime。 | -| macOS | WKWebView 随 macOS 自带；需要在已登录的图形桌面会话中运行。 | -| Linux | GTK 3 + WebKitGTK（当前 Debian/Ubuntu 通常是 `libwebkit2gtk-4.1-0`）以及图形桌面会话/Xvfb。 | +## 为什么是 Glaze -如果原生后端初始化失败，Glaze 会保留底层错误，并紧接着给出对应平台的安装命令或官方下载地址。交互式桌面程序还会尝试弹出系统错误对话框显示同一份诊断信息——这对 Windows `raco exe --gui` 打包出的无控制台程序尤其重要。CI 会自动禁用错误弹框；也可以通过 `GLAZE_NO_STARTUP_DIALOG=1` 显式关闭。 +Racket 已经提供 `racket/gui`，Glaze 面向的是另一类桌面应用：**Web UI + Racket Runtime + 原生桌面能力**。 -Windows 示例： +Glaze 不是 Electron 的复制品。它不内置 Chromium，也不额外引入 Node Runtime。当前设计理念更接近 Tauri： ```text -Windows requires Microsoft Edge WebView2 Runtime (Evergreen). -winget install --id Microsoft.EdgeWebView2Runtime -e -https://developer.microsoft.com/microsoft-edge/webview2/#download-section +Web UI + | + | HTTP / JSON / SSE + v +Racket Runtime + | + +-- WebView + +-- Tray + +-- System capabilities + +-- Packaging helpers + | +Native OS APIs ``` -Linux 示例： +当前通过 Racket FFI 使用系统 WebView： -```bash -# Debian / Ubuntu -sudo apt install libgtk-3-0 libwebkit2gtk-4.1-0 +- Windows：WebView2 +- macOS：WKWebView +- Linux：WebKitGTK -# Fedora -sudo dnf install gtk3 webkit2gtk4.1 +Glaze 明确采用 GUI-first 模式，运行时必须具备可用的原生 WebView。后端缺失或损坏时，启动会失败并给出对应平台的安装/修复指引，而不会静默改成浏览器标签页。 -# Arch -sudo pacman -S gtk3 webkit2gtk-4.1 -``` +当前前后端桥接有意保持简单：请求使用本地 HTTP JSON API，Racket 向前端推送事件使用 Server-Sent Events。完整 RPC 框架和插件系统还不是当前公共架构的一部分。 ## 快速开始 -### 1. 安装 +安装： ```bash raco pkg install --auto glaze ``` -### 2. 创建新项目 +开发仓库可以直接 link： ```bash -raco glaze init myapp -cd myapp +git clone https://github.com/turinglambdaai/glaze.git +cd glaze +raco pkg install --auto --no-docs --link "$PWD" ``` -### 3. 运行 +最小应用只需要统一公共入口： -```bash -racket main.rkt -# 或 -raco glaze dev -``` - -会打开一个真正的原生桌面窗口，由本地 Racket 服务驱动。如果缺少 WebView2 / WebKitGTK 等依赖，启动会停止并告诉你需要安装什么，绝不会改成浏览器页面继续运行。 - -> 想直接从 GitHub 检出安装而不走包索引？ -> ```bash -> git clone https://github.com/turinglambdaai/glaze.git -> cd glaze -> raco pkg install --auto --link "$PWD" -> ``` - -## CLI 命令 - -```bash -raco glaze init # 创建原生 Glaze 桌面项目 -raco glaze dev # 运行当前项目的原生桌面应用 -raco glaze build # 构建可分发包（exe + 内置资源） -raco glaze keygen # 生成用于许可证签名的 RSA 密钥对 -raco glaze license # 签发 / 校验离线许可证文件 -raco glaze help # 显示帮助 -``` - -Glaze **不提供浏览器模式的 `dev` / `serve` 命令**。开发和发布走同一条 Native WebView 路径，这样依赖缺失或原生后端故障会在开发阶段立即暴露，而不是被 browser fallback 隐藏。 +```racket +#lang racket/base -### `build` +(require racket/runtime-path + glaze) -把 Glaze 项目打包为平台分发产物（`raco exe` + `raco distribute`），前端资源随可执行文件一起分发。Windows GUI 构建使用 `raco exe --gui`；macOS 产出标准 `.app` bundle。 +(define-runtime-path public "public") -```bash -raco glaze build --name myapp -raco glaze build --name myapp --version 1.2.0 --installer +(run-app #:public-dir public + #:title "Hello Glaze") ``` -选项：`--name`、`--version`、`--icon <.ico/.icns>`、`--entry `（默认 `main.rkt`）、`--out `（默认 `dist`）、`--embed-dlls`（Windows：单文件 exe）、`--installer`。 - -> installer 步骤缺少 WiX / NSIS / create-dmg / appimagetool 等打包工具时，可以降级为 `.zip` / `.tar.gz` 并响亮告警。这里降级的是**分发格式**，不是应用 UI；应用启动本身没有浏览器 fallback。 +在 `public/` 中放置 `index.html` 后运行程序即可。完整最小示例见 [`examples/hello/`](examples/hello/)。 -### 代码签名与公证 +也可以使用 CLI 创建项目： ```bash -# macOS -raco glaze build --name myapp \ - --sign "Developer ID Application: Acme Inc (TEAMID)" \ - --notarize acme-notary --installer - -# Windows -raco glaze build --name myapp --sign 40HEXCHARS --installer +raco glaze init myapp +cd myapp +racket main.rkt ``` -签名失败会中止构建；缺失签名工具链时会明确告警。 - -### 许可证（收费应用） - -```bash -raco glaze keygen --out keys -raco glaze license sign --key keys/private.pem --product "MyApp" \ - --subject "customer@example.com" --expiry 2027-12-31 --out app.license -raco glaze license verify --pub keys/public.pem --product "MyApp" app.license -``` +## 已实现能力 -```racket -(require glaze/license) +当前仓库已经包含： -(define r (validate-license "app.license" #:public-key "keys/public.pem" #:product "MyApp")) -(unless (hash-ref r 'valid) - (error 'myapp "许可证无效：~a" (hash-ref r 'reason))) -``` +- 原生 WebView 窗口：生命周期、导航、标题/URL 查询、截图、窗口控制和菜单 +- 本地静态文件服务器与 SPA fallback +- JSON API 路由和自动生成的浏览器客户端 +- Racket → 前端的 SSE 事件推送 +- 系统托盘和菜单 +- 剪贴板、通知、打开/定位文件、单实例能力 +- 文件/目录对话框、Deep Link、开机自启动辅助能力 +- `raco glaze build` 应用打包 +- 更新检查和离线许可证工具 +- 原生 WebView 不可用时的可操作诊断信息 -## 项目结构 +Glaze 本身使用 Racket 实现，原生集成主要通过 FFI；核心框架不要求用户安装 C 编译器。 -一个新的 Glaze 项目结构如下： +## 平台支持 -``` -myapp/ -├── main.rkt # Racket 入口 -└── public/ - └── index.html # 前端页面 -``` +仓库 CI 使用 Racket 8.12 在 Windows、macOS、Linux 上运行测试，并在三个平台执行真实 WebView 端到端验证。Linux CI 使用 Xvfb + WebKitGTK。 -`raco glaze init` 现在生成的入口就是原生窗口应用。`run-app` 故意放在顶层，这样源码直接运行、`raco glaze dev` 和 `raco glaze build` 的打包 wrapper 都会启动同一套应用逻辑： +| 能力 | Windows | macOS | Linux | +|---|---|---|---| +| 本地 Server / JSON API / SSE | 支持 | 支持 | 支持 | +| 原生 WebView | WebView2 | WKWebView | WebKitGTK | +| 系统托盘 | 支持 | 支持 | 支持 | +| 系统能力封装 | 支持 | 支持 | 支持 | +| 打包流程 | 支持 | 支持 | 支持 | -```racket -#lang racket/base +部分原生能力依赖操作系统组件或桌面会话。WebView 启动失败属于致命错误，并会提供对应平台的处理指引；应用层不应该直接 require 某个平台 backend。运行要求和诊断说明见 [`docs/gui-first.md`](docs/gui-first.md)。 -(require racket/runtime-path - glaze) +## 架构 -(define-runtime-path public "public") +应用推荐只依赖 `(require glaze)`。WebView、Tray、Sys 模块在内部完成平台 backend 分发： -(run-app #:public-dir public - #:title "myapp") +```text +Application + | + v +(require glaze) +Public facade: glaze/main.rkt + | + +-------------------------------+ + | | | + v v v +Runtime Capabilities Tooling +app/server webview/main build/update +api/events tray/main CLI + sys/main + | | + +-------+-------+ + v +Platform backends +Windows / macOS / Linux / stub ``` -## API +当前目标不是为了“架构漂亮”而一次性移动全部文件，而是先稳定依赖方向、生命周期和公共 API 合约。 -### `run-app` +详细设计见 [`docs/architecture.md`](docs/architecture.md)。 -一键入口：自动挑空闲端口、启动服务器（静态 + JSON API）、打开原生 WebView 窗口、阻塞到窗口关闭。 +## 包与 Collection -```racket -(run-app #:public-dir "public" - #:api (list (GET "api/ping" ...))) -;; 窗口关闭 -> server 停止 -> (values 'webview shutdown) -``` +仓库根目录是一个 `collection 'multi` 的可安装 Racket package： -如果原生 WebView 启动失败，`run-app` 会先停止已经启动的本地 server，再把包含安装/修复指引的错误原样抛出。**不存在 `#:fallback-browser?` 参数。** +- `glaze/` —— 框架核心和公共 facade +- `glaze-cli/` —— `raco glaze` 命令 +- `glaze-doc/` —— Scribble API 文档 +- `glaze-test/` —— 测试套件 +- `examples/` —— 可运行示例 +- `scripts/` —— CI 和验证脚本 -### `start-server` / `start-dev-server` +`glaze/webview/`、`glaze/tray/`、`glaze/sys/` 内部包含公共 dispatcher 和平台实现。普通应用应优先 `(require glaze)`，而不是依赖 `webview-windows.rkt`、`tray-macos.rkt`、`sys-linux.rkt` 等实现文件。 -启动本地 HTTP 服务器：静态文件 + SPA 回退 + 可选 JSON API 路由。`start-dev-server` 只是底层 server API 的兼容别名，不代表另一套浏览器 UI 模式。 +## 示例 -### `open-browser` +建议按以下顺序阅读： -这是一个**低层外部链接工具函数**，例如打开产品文档或 OAuth 页面。`run-app` / `open-window` 不会把它当成 WebView 失败后的退路。 +- [`examples/hello/`](examples/hello/) —— 最小 `run-app` 应用 +- [`examples/tray/`](examples/tray/) —— 系统托盘与菜单 +- [`examples/events/`](examples/events/) —— JSON 请求 + SSE 推送 +- [`examples/counter/`](examples/counter/) —— 更完整的 JS/Racket bridge +- [`examples/showcase/`](examples/showcase/) —— 综合能力展示 +- [`examples/agent-verify.rkt`](examples/agent-verify.rkt) —— 程序化 WebView 验证 +- [`examples/webview-demo.rkt`](examples/webview-demo.rkt) —— 直接 WebView 生命周期示例 -```racket -(open-browser "https://example.com/docs") -``` +## 项目状态 -## JavaScript 桥接 +Glaze 当前仍是 pre-1.0 项目（package metadata 为 `0.7`）。跨平台实现、CI、打包链路已经存在，但公共 API 和生命周期仍处于稳定化阶段。 -嵌入式前端用普通 `fetch("/api/...")` 调 Racket。本地 HTTP 桥接也方便用 `curl` 等开发工具独立测试。 +0.x 阶段优先保持兼容：不会仅仅为了未来目录更漂亮而大规模移动 backend，也不会随意删除已有 API。对于新应用，建议只使用文档化的公共入口。 -```racket -(require glaze) +## 安全边界 -(GET "api/ping" (lambda (req) (hasheq 'pong #t))) -(POST "api/items/:id/bump" (lambda (req id) (hasheq 'id id 'bumped #t))) -``` +Glaze 的本地 HTTP bridge、静态文件服务、打包/签名、更新与原生 FFI 都属于安全敏感边界。安全问题请参考 [`SECURITY.md`](SECURITY.md)，不要在公开 issue 中直接发布利用细节或私钥等敏感信息。 -`define-api-routes` 一处声明同时产生 Racket procedure、validated route 和 `/glaze/api.js` 中的 JS client entry。 +## Roadmap -### 后端 → 前端推送（SSE） +见 [`ROADMAP.md`](ROADMAP.md)。近期重点是： -```racket -(define bus (make-event-bus)) -(start-server ... #:events bus) -(bus-broadcast! bus 'count-changed (hasheq 'count 42)) -``` +- 稳定 application lifecycle +- 明确 public API +- 完善跨平台测试与打包验证 +- 文档和示例 +- 收紧安全与错误处理边界 -SSE 与嵌入式 WebView 前端共享同一个本地 origin。 +IPC/event 模型的进一步演进、更多系统 capability 会放在后续阶段；插件 SDK、完整 hot reload 不属于当前稳定化工作的范围。 -### 安全 +## 文档 -- 仅服务 Host 为 `127.0.0.1` / `localhost` / `[::1]` 的请求； -- 参数问题返回 400 JSON，handler 异常返回 500 JSON； -- 可选 `#:api-token` 保护 API 路由与 SSE； -- 应用窗口通过一次性的 token bootstrap URL 获取 HttpOnly cookie。 +- [`docs/architecture.md`](docs/architecture.md) —— 架构与依赖规则 +- [`ROADMAP.md`](ROADMAP.md) —— 分阶段路线图 +- [`CONTRIBUTING.md`](CONTRIBUTING.md) —— 贡献流程 +- [`SECURITY.md`](SECURITY.md) —— 安全报告流程 +- `raco docs glaze` / `glaze-doc` —— API 文档 -## 系统集成 +## 开发 -```racket -(require glaze/sys) -(clipboard-set! "hello") -(notify! "下载完成" "report.pdf 已就绪") -(open-path "/Users/me/report.pdf") -(reveal-path "/Users/me/report.pdf") -(unless (single-instance? "com.me.app") (exit 0)) +```bash +raco pkg install --auto --no-docs --link "$PWD" +raco make glaze/main.rkt glaze-cli/cli.rkt +raco test glaze-test/ ``` -窗口控制：`webview-set-title!`、`webview-set-size!`、`webview-set-fullscreen!`、`webview-focus!`。 - -## 系统托盘 - -系统托盘是**可选能力**。tray backend 缺失时可以退化为 inert stub；这和主 WebView 必须成功启动是两种不同的产品语义。 +CI 还会在 Windows、macOS 和 Linux 上运行原生 WebView e2e、最终打包产物执行验证和安装器构建，并验证过滤后的 Racket source package 可以独立安装。 -- Windows：`Shell_NotifyIconW` -- macOS：`NSStatusItem` / `NSMenu` -- Linux：`libayatana-appindicator` + GTK +## 贡献 -## 示例 - -| 示例 | 内容 | -|---|---| -| [`examples/showcase/`](examples/showcase/) | 综合演示 —— 全部能力在一个原生窗口里 | -| [`examples/hello/`](examples/hello/) | 最小原生应用 | -| [`examples/counter/`](examples/counter/) | JS↔Racket 桥接 | -| [`examples/webview-demo.rkt`](examples/webview-demo.rkt) | 跨平台 Native WebView 生命周期 | -| [`examples/agent-verify.rkt`](examples/agent-verify.rkt) | 无人值守断言页面状态 + 截图 | -| [`examples/tray-demo.rkt`](examples/tray-demo.rkt) | 跨平台系统托盘 | - -## Roadmap +欢迎贡献。请优先提交范围清晰、能够单独审查的修改；在可行的情况下保持现有 API 兼容，并为行为修复增加 regression test。平台实现应继续位于公共 dispatcher 后面。 -- [x] **Phase 1** —— 本地 HTTP 服务 + 早期浏览器原型 -- [x] **Phase 2** —— 前端资源打包、系统托盘、应用打包 -- [x] **Phase 3** —— 原生 WebView（WebView2 / WKWebView / WebKitGTK），三平台 CI e2e -- [x] **GUI-first 契约** —— WebView 必须可用；失败给出可操作安装指引，不再 fallback 到浏览器 +详细流程见 [`CONTRIBUTING.md`](CONTRIBUTING.md)。 ## License -MIT License。 +MIT —— 见 [`LICENSE`](LICENSE)。 diff --git a/ROADMAP.md b/ROADMAP.md new file mode 100644 index 0000000..1e15855 --- /dev/null +++ b/ROADMAP.md @@ -0,0 +1,51 @@ +# Glaze Roadmap + +Glaze is a pre-1.0 project. This roadmap is intentionally small: it describes the next architectural steps without promising a large plugin ecosystem or a full desktop platform rewrite. + +## v0.x — Stabilize + +The current priority is to make the framework predictable for application authors and maintainers. + +- stabilize application lifecycle semantics around `run-app`, window close, browser fallback, and shutdown +- keep `(require glaze)` as the recommended application-facing facade +- document which modules are public, internal, platform-specific, or experimental +- tighten argument validation and error behavior where contracts are currently implicit +- keep examples minimal, runnable, and aligned with recommended APIs +- add regression tests around public API imports, platform-independent behavior, events, and lifecycle +- keep Windows, macOS, and Linux backend contracts aligned +- improve packaging and documentation without introducing avoidable breaking changes + +## Next + +Once the current lifecycle and API surface are better defined, the next layer of work can focus on communication and common desktop capabilities. + +- define a clearer JS/Racket message bridge on top of the existing HTTP/SSE model +- make the event model more explicit and consistent across runtime and UI integration +- add notification/storage capabilities behind the same public capability boundary +- improve packaging metadata, signing workflows, and project configuration +- continue consolidating generated/scaffolded applications around the public facade + +These changes should remain incremental. Existing HTTP JSON routes and SSE behavior should not be removed merely to introduce a new abstraction. + +## Later + +Possible longer-term work, after the core contracts are stable: + +- plugin SDK with explicit capability and version boundaries +- development-time hot reload +- richer project templates +- ecosystem integrations for additional native capabilities +- reusable capability packages such as filesystem, serial, CAN, or application-specific integrations + +These are directions, not commitments for the current release line. + +## Explicitly Not in the Current Stabilization Pass + +The current architecture work does not attempt to: + +- reproduce Electron feature-for-feature +- bundle a custom browser runtime +- introduce a large JavaScript build stack +- rewrite all native backends +- implement a complete RPC framework +- implement a plugin system before the public API and lifecycle are stable diff --git a/SECURITY.md b/SECURITY.md new file mode 100644 index 0000000..4a7544f --- /dev/null +++ b/SECURITY.md @@ -0,0 +1,36 @@ +# Security Policy + +Glaze embeds native desktop capabilities behind a local HTTP bridge, so security reports are treated as correctness issues, not feature requests. + +## Supported versions + +Glaze is currently pre-1.0. Security fixes are applied to the latest development/release line. Older 0.x releases may require upgrading rather than receiving a backport. + +## Reporting a vulnerability + +Please do not publish exploit details, credentials, private keys, license-signing material, or sensitive reproduction data in a public issue. + +Prefer GitHub's private **Report a vulnerability** / Security Advisory flow for this repository when it is available. If private reporting is not available, open a minimal public issue stating that you have a security report and need a private contact channel; do not include exploit details in that issue. + +A useful report includes: + +- affected Glaze version or commit; +- operating system and Racket version; +- affected capability (server/API, WebView, tray, sys, packaging, update, license, etc.); +- minimal reproduction steps; +- expected and observed behavior; +- impact and whether user interaction is required. + +## Security boundaries + +The project currently treats the following as security-sensitive boundaries: + +- the local HTTP API and SSE event stream are loopback-only and support capability-token protection; +- Host and Origin checks are used to reduce localhost/DNS-rebinding and cross-origin abuse; +- static files must remain contained inside the configured public directory; +- native backends must not accept unvalidated application data directly into shells or command strings; +- packaging/signing failures must fail closed rather than silently producing an artifact that claims to be signed; +- update manifests and downloaded artifacts must be treated as untrusted input and verified before replacement; +- offline licensing is a commercial policy mechanism, not a claim of tamper-proof DRM. + +Please report any case where implementation behavior violates these boundaries. diff --git a/docs/architecture.md b/docs/architecture.md new file mode 100644 index 0000000..cf713c2 --- /dev/null +++ b/docs/architecture.md @@ -0,0 +1,260 @@ +# Glaze Architecture + +Glaze is a Racket-first desktop application framework that combines a web UI with a Racket runtime and native desktop capabilities. + +This document describes the architecture that exists today and the direction the project should preserve while it evolves. It is not a proposal to rewrite the repository into a new directory structure. + +## Goals + +- keep the application-facing API small and easy to discover +- preserve a clear dependency direction from application code toward lower-level capabilities +- isolate Windows, macOS, and Linux implementation details behind dispatch modules +- keep native surface area small and explicit +- make behavior testable without requiring callers to understand backend internals +- preserve good Racket development ergonomics, including simple `require`, REPL use, macros, and ordinary modules +- prefer incremental compatibility-preserving changes over architecture-driven rewrites + +## Non-goals + +The current stabilization work is not trying to provide: + +- Electron feature parity +- a bundled browser runtime or custom renderer +- a complete typed RPC framework +- a large plugin ecosystem +- hot reload as a framework-level subsystem +- a large frontend toolchain +- a rewrite of all native backends + +Those may be explored later when the current public contracts are stable enough to support them. + +## Current Layers + +The repository is one Racket package with multiple collections. The runtime architecture can be understood as the following layers: + +```text +Application + | + v +Public API / Facade + | + v +Runtime and shared capabilities + | + v +Platform dispatch + | + v +Native backends +``` + +The mapping to existing code is: + +```text +Application + | + v +`glaze/main.rkt` +Public facade exported by `(require glaze)` + | + +---------------------------+ + | | | + v v v +Runtime Capabilities Tooling +`app.rkt` `webview/main` `build.rkt` +`server.rkt` `tray/main` `update.rkt` +`api.rkt` `sys/main` `glaze-cli/` +`events.rkt` dialogs/etc. + | | + +------+-----+ + v +Platform-specific backends +`webview/webview-{windows,macos,linux,stub}.rkt` +`tray/tray-{windows,macos,linux,stub}.rkt` +`sys/sys-{windows,macos,linux,stub}.rkt` +``` + +### Application + +Application code should normally depend on the `glaze` facade rather than individual implementation modules. + +Recommended: + +```racket +(require glaze) +``` + +Direct imports such as `glaze/webview/webview-windows` or `glaze/tray/tray-macos` couple an application to implementation details and are not the recommended application-level API. + +### Public API / Facade + +`glaze/main.rkt` is the current facade. It re-exports the major framework surfaces so applications can use one `require` path. + +The facade is intentionally compatibility-oriented today: it exports a broad set of existing APIs instead of hiding them immediately. During 0.x stabilization, narrowing the facade should happen only with deprecation and migration planning. + +### Runtime + +The runtime composes capabilities into an application lifecycle: + +- `app.rkt` owns the high-level `run-app` flow +- `server.rkt` serves static assets, JSON routes, and framework endpoints +- `api.rkt` and `api-macros.rkt` define request/response routing +- `events.rkt` provides backend-to-frontend event delivery over SSE + +`app.rkt` depends on the server, events, update support, and the public WebView dispatcher. This is an expected high-level dependency direction. + +### Capabilities + +Capability modules expose OS-facing functions without making application code select a backend: + +- `webview/main.rkt` +- `tray/main.rkt` +- `sys/main.rkt` +- `dialogs.rkt` +- `deeplink.rkt` +- `autolaunch.rkt` +- `browser.rkt` + +The WebView, tray, and sys modules already follow the same useful pattern: a platform-independent API dispatches lazily to the backend selected by `(system-type 'os)`. + +### Platform Backends + +Platform backend modules are implementation details. They use Racket FFI, Objective-C FFI, subprocesses, or operating-system APIs to satisfy the capability contract. + +These modules should not depend on `app.rkt` or other application-level orchestration modules. Backend modules may depend on small shared protocols or lower-level utilities needed to implement their contract. + +## Dependency Rules + +The project should evolve toward these rules without requiring a large file move: + +1. **Applications depend on the public facade.** + New examples and generated application templates should prefer `(require glaze)`. + +2. **The public facade may depend on runtime and capability modules.** + `glaze/main.rkt` is allowed to re-export stable application-facing functionality. + +3. **Runtime orchestration may depend on capabilities.** + For example, `run-app` may depend on `server.rkt`, `events.rkt`, and `webview/main.rkt`. + +4. **Capability dispatchers may depend on shared lower-level protocols, but not application orchestration.** + `webview/main.rkt` depending on the tray menu protocol is acceptable because the protocol is a shared data model used to build native menus. A dependency on `app.rkt` would reverse the intended direction. + +5. **Platform backends must not become application APIs.** + They should remain behind dispatcher modules and may change as native implementation details require. + +6. **Shared protocols belong below their consumers.** + If multiple capabilities need the same types or protocol definitions, they should live in a small lower-level module rather than one capability importing another capability's full implementation. + +7. **Avoid cycles.** + New code should not introduce cycles between runtime, capability dispatchers, and backend modules. If two modules need the same definition, extract only that shared definition rather than merging unrelated responsibilities. + +8. **Prefer facade and tests before file moves.** + When an internal/public boundary is unclear, first establish it in exports, documentation, tests, and comments. Move files only when the compatibility and maintenance benefit is clear. + +## Public vs Internal API + +The repository did not previously have a formal stability classification for every module. The following classification records the intended boundary for new development. + +### Public + +Preferred application-facing entry point: + +- `glaze` (`glaze/main.rkt`) + +The following module paths also expose useful APIs today and remain supported for compatibility, but application documentation should prefer the facade unless a focused import is useful: + +- `glaze/app` +- `glaze/server` +- `glaze/api` +- `glaze/api-macros` +- `glaze/events` +- `glaze/webview/main` +- `glaze/tray/main` +- `glaze/sys/main` +- `glaze/dialogs` +- `glaze/deeplink` +- `glaze/autolaunch` +- `glaze/browser` +- `glaze/build` +- `glaze/update` +- `glaze/license` + +This is a compatibility statement, not a promise that every exported binding already has a 1.0-stable contract. + +### Internal implementation + +Modules that implement framework mechanics but should not be imported by normal application code include platform backends and implementation-specific helper modules. + +Examples: + +- `glaze/webview/webview-windows` +- `glaze/webview/webview-macos` +- `glaze/webview/webview-linux` +- `glaze/webview/webview-stub` +- `glaze/tray/tray-windows` +- `glaze/tray/tray-macos` +- `glaze/tray/tray-linux` +- `glaze/tray/tray-stub` +- `glaze/sys/sys-windows` +- `glaze/sys/sys-macos` +- `glaze/sys/sys-linux` +- `glaze/sys/sys-stub` + +Tests may import these modules when they explicitly test a backend contract. Applications should not. + +### Shared protocol + +`glaze/tray/tray-protocol.rkt` is currently a shared protocol/data-model module rather than a native backend. WebView menu support reuses its menu definitions. Although it is re-exported through the tray public API, its main architectural role is lower-level shared data. + +If menu definitions later become a broader application-wide concept, they can be promoted into a neutral shared module in a separate compatibility-focused change. + +### Platform-specific + +Any module named for an operating system is platform-specific by definition. Its implementation and FFI details are free to differ as long as the public dispatcher contract remains consistent. + +### Experimental + +Glaze is pre-1.0, so newly introduced APIs may be marked experimental in documentation before they are made part of the stable facade. Experimental status should be explicit; it should not be inferred merely because an API lives in a separate file. + +## Current Dependency Observations + +The current WebView, tray, and sys implementations already have a sound dispatch shape: + +- the public dispatcher selects the backend lazily +- applications do not need to select an operating system implementation +- optional native capabilities can report `#f` or use a stub; the mandatory + application WebView instead fails fast with platform-specific guidance + +A small coupling exists where `webview/main.rkt` imports only `menu?` from `tray/tray-protocol.rkt`. This is not a cycle and does not pull in the tray backend, but it shows why shared protocol/types should remain lightweight. + +The repository therefore does not need a large platform-layer rewrite to make architectural progress. The higher-value near-term work is to stabilize lifecycle semantics, public contracts, tests, and documentation. + +## Testing Boundaries + +Tests should be divided conceptually into three groups: + +- **facade/API tests**: prove `(require glaze)` exposes the documented application surface +- **platform-independent tests**: routing, argument validation, events, lifecycle helpers, parsing, and other logic that can run on all hosts +- **backend/e2e tests**: validate the OS-specific implementation behind the dispatcher + +The existing CI already runs the test suite on Windows, macOS, and Linux and has a separate real-window WebView e2e job. That structure should be preserved. + +## Evolution Strategy + +Changes should normally follow this order: + +```text +Bug / correctness + > +API inconsistency + > +dependency problem + > +missing regression test + > +documentation gap + > +directory aesthetics +``` + +A future `private/` or `internal/` directory may be useful, but moving working FFI files solely for visual cleanliness is not a current priority. A documented boundary plus a tested facade gives the project most of the maintenance benefit with much lower compatibility risk. diff --git a/docs/releasing.md b/docs/releasing.md new file mode 100644 index 0000000..20063f6 --- /dev/null +++ b/docs/releasing.md @@ -0,0 +1,137 @@ +# Releasing Glaze + +This checklist keeps a Glaze release reproducible without putting signing credentials in the repository. + +Glaze is still pre-1.0, so releases should remain conservative: stabilize and verify existing public behavior before adding release-only features. + +## 1. Prepare the release commit + +Before tagging a release: + +1. update the root `info.rkt` version; +2. update `CHANGELOG.md` with user-visible changes and compatibility notes; +3. verify `README.md`, `README.zh-CN.md`, Scribble documentation, and examples describe behavior that actually exists; +4. make sure no private keys, certificates, notary profiles, generated installers, or customer license files are committed; +5. ensure the release commit is fully reviewed and CI is green. + +Racket version strings must follow the package manager's accepted version syntax; use the same value consistently in package metadata and release notes. + +## 2. Required CI gates + +The release commit should pass the repository CI without skipped failures: + +- compile public entrypoints on Windows, macOS, and Linux; +- run the full `glaze-test/` suite on all three platforms; +- run native WebView end-to-end tests on all three platforms; +- execute a final packaged application, not only the build command; +- build platform installers/distribution archives; +- verify the macOS bundle signature used by CI; +- run the dedicated macOS/Racket 9.3 packaging regression; +- create a filtered Racket source package, install that archive from scratch, and verify `(require glaze)` plus `raco glaze`. + +A passing checkout build is not sufficient if the source archive or packaged executable fails independently. + +## 3. Build commercial distribution artifacts + +The CI artifacts are smoke-test artifacts. Production releases should be rebuilt with the publisher's real signing identity where the platform supports signing. + +### macOS + +Use a Developer ID Application identity and hardened runtime: + +```bash +raco glaze build \ + --name MyApp \ + --version 1.2.3 \ + --installer \ + --sign "Developer ID Application: Example Corp (TEAMID)" \ + --notarize my-notary-profile +``` + +Then verify the result independently: + +```bash +codesign --verify --strict --verbose=2 dist/MyApp.app +spctl --assess --type execute --verbose=2 dist/MyApp.app +``` + +When a DMG is shipped, verify the notarization/stapling status of the final artifact as well as the app bundle. + +### Windows + +Use a real code-signing certificate through `signtool` and an RFC-3161 timestamp server: + +```bash +raco glaze build \ + --name MyApp \ + --version 1.2.3 \ + --installer \ + --sign +``` + +The current native installer backends are **NSIS** and **WiX Toolset v4**. Glaze's generated WiX source uses the v4 schema and command line; do not assume a newer WiX major version is compatible. For a predictable production build, install NSIS or pin WiX v4 in the release environment rather than relying on whatever `wix` happens to be on `PATH`. + +Verify both the executable and installer with the Windows signing tools before publication. Do not treat an unsigned fallback archive as equivalent to a signed commercial installer. + +### Linux + +Glaze can produce an AppImage when `appimagetool` is available, otherwise a portable archive fallback. Linux has no single universal code-signing mechanism in the current Glaze build API; distributors should use the signing/verification mechanism appropriate to their chosen channel. + +CI deliberately exercises the `.tar.gz` fallback instead of downloading and executing AppImageKit's mutable `continuous` release. If a production pipeline builds AppImages, provision `appimagetool` from a separately pinned and verified toolchain. + +## 4. Create the Racket source package + +Racket packages are normally distributed as source. From the checkout parent directory: + +```bash +raco pkg create --source --format zip glaze +``` + +Install the resulting archive in a clean Racket environment before publishing it: + +```bash +raco pkg install --auto --no-docs glaze.zip +racket -e '(require glaze)' +raco glaze help +``` + +CI performs the equivalent source-package smoke test so repository-only files or local links cannot accidentally become hidden release dependencies. + +## 5. Security review + +Before publishing, re-check the boundaries documented in [`../SECURITY.md`](../SECURITY.md): + +- localhost API/SSE authentication and origin/host checks; +- static-file containment; +- command/subprocess argument construction; +- update artifact verification; +- signing/notarization failure behavior; +- accidental logging or packaging of tokens, credentials, private keys, or customer data. + +Any unresolved vulnerability with material impact should block the release. + +## 6. Publish + +After the exact release commit passes all gates: + +1. create the release tag from that commit; +2. publish release notes from `CHANGELOG.md`; +3. attach only verified artifacts; +4. update the Racket package catalog/source reference as appropriate; +5. verify installation from the public release source on a clean machine or clean Racket installation; +6. keep the previous known-good release available for rollback. + +Do not rebuild an artifact after tagging and publish it under the same version without documenting that the bits changed. A release version should identify one reproducible source state. + +## 7. Post-release smoke checks + +After publication, perform at least one clean install per supported desktop platform and verify: + +- application startup; +- native WebView creation; +- JSON API + SSE bridge; +- shutdown/cleanup; +- one native capability such as tray or clipboard; +- the published package/installer launches without depending on the source checkout. + +Record any platform-specific release regression as an issue with the release version, OS version, Racket version, and reproduction steps. diff --git a/examples/README.md b/examples/README.md index 4c80b67..307750d 100644 --- a/examples/README.md +++ b/examples/README.md @@ -1,22 +1,31 @@ -# Glaze Examples — 功能索引 +# Glaze Examples -| 示例 | 一句话 | 展示的能力 | +Start with the smallest examples. They use the public `(require glaze)` facade and show the recommended application-facing APIs without exposing platform backend modules. + +| Example | Purpose | Main capabilities | |---|---|---| -| [`showcase/`](showcase/) | **一屏看尽全部能力（推荐先看）** | 宏路由全形态（类型校验/400/:path/500）、SSE 事件流 + 后端错误回流（on-error）、系统功能（剪贴板/通知/Finder/窗口控制）、Agent 验证（title/url/capture + 截图回传）、API token（401 演示）、更新检查、托盘、单实例 | -| [`hello/`](hello/) | 8 行最小应用 | run-app 一键入口、原生窗口、静态页面 | -| [`counter/`](counter/) | JS↔Racket 桥接主打 | define-api-routes、SSE 广播驱动 UI、api.js 生成客户端、模块可组合（provide api/bus） | -| [`webview-demo.rkt`](webview-demo.rkt) | 跨平台 WebView 生命周期 | 原生窗口、加载/导航/关闭/on-close/验证 API 实时打印、看门狗 | -| [`agent-verify.rkt`](agent-verify.rkt) | 无人值守验证 | agent 工作流：轮询断言 + 截图 + 退出码 | -| [`tray-demo.rkt`](tray-demo.rkt) | 跨平台托盘 | make-tray/菜单/tooltip 动态更新 | +| [`hello/`](hello/) | Minimal desktop application | `run-app`, static assets, required native WebView | +| [`tray/`](tray/) | Minimal system tray application | `make-tray`, menu items, tray lifecycle | +| [`events/`](events/) | Minimal JS/Racket communication | JSON request route + Server-Sent Events push | +| [`counter/`](counter/) | Fuller bridge example | `define-api-routes`, generated client support, event bus, shared state | +| [`showcase/`](showcase/) | Integrated feature showcase | API validation, events, system capabilities, WebView controls, tray, update checks | +| [`webview-demo.rkt`](webview-demo.rkt) | Direct WebView lifecycle | open, navigate, inspect, capture, close | +| [`agent-verify.rkt`](agent-verify.rkt) | Programmatic UI verification | polling assertions, title/URL inspection, screenshot, exit status | +| [`tray-demo.rkt`](tray-demo.rkt) | Legacy single-file tray demo | tray menu and tooltip updates | -## 快速开始 +## Quick Start ```bash -racket examples/showcase/main.rkt # 综合演示（单实例锁定） -racket examples/counter/main.rkt # 桥接 + 事件 -racket examples/hello/main.rkt # 最小应用 +racket examples/hello/main.rkt +racket examples/events/main.rkt +racket examples/tray/main.rkt ``` -Glaze 示例只走原生桌面 WebView，不会退回系统浏览器。若 WebView2 / WebKitGTK 等运行时依赖缺失，启动会直接失败并打印对应平台的安装/修复指引。 +Then move to the fuller examples: + +```bash +racket examples/counter/main.rkt +racket examples/showcase/main.rkt +``` -所有示例均可 `raco glaze build` 打包为独立应用。 +The examples intentionally use public modules. Backend-specific modules under `glaze/webview/`, `glaze/tray/`, and `glaze/sys/` are implementation details unless you are working on Glaze itself. diff --git a/examples/events/main.rkt b/examples/events/main.rkt new file mode 100644 index 0000000..7941b56 --- /dev/null +++ b/examples/events/main.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +;; Minimal request + event example using Glaze's existing HTTP/SSE bridge. +;; Run: racket examples/events/main.rkt + +(require racket/runtime-path + glaze) + +(define-runtime-path public "public") +(define bus (make-event-bus)) + +(define-api-routes api + [(POST "api/ping") + (ping) + (begin + (bus-broadcast! bus 'pong (hasheq 'message "pong from Racket")) + (hasheq 'ok #t))]) + +(module+ main + (run-app #:public-dir public + #:api api + #:events bus + #:title "Glaze Events")) diff --git a/examples/events/public/index.html b/examples/events/public/index.html new file mode 100644 index 0000000..a59d7be --- /dev/null +++ b/examples/events/public/index.html @@ -0,0 +1,33 @@ + + + + + + Glaze Events + + + +

Glaze Events

+

Click the button to call Racket over HTTP. Racket broadcasts the response back over Server-Sent Events.

+ + 
Waiting for an event…
+ + + + diff --git a/examples/info.rkt b/examples/info.rkt index 438c890..118d2e6 100644 --- a/examples/info.rkt +++ b/examples/info.rkt @@ -7,6 +7,8 @@ '("showcase" "hello" "counter" + "events" + "tray" "agent-verify.rkt" "tray-demo.rkt" "webview-demo.rkt")) diff --git a/examples/tray/main.rkt b/examples/tray/main.rkt new file mode 100644 index 0000000..cdf7a5f --- /dev/null +++ b/examples/tray/main.rkt @@ -0,0 +1,27 @@ +#lang racket/base + +;; Minimal system tray example using only the public Glaze facade. +;; Run: racket examples/tray/main.rkt + +(require glaze) + +(define tray + (make-tray + #:icon #f + #:tooltip "Glaze Tray" + #:menu + (list + (make-menu-item "Hello" + #:action (lambda () + (displayln "Hello from the Glaze tray"))) + (menu-separator) + (make-menu-item "Quit" + #:action (lambda () + (tray-close tray) + (exit 0)))))) + +(displayln "Glaze tray example is running. Use the tray menu to quit.") + +(let loop () + (sleep 1) + (loop)) diff --git a/glaze-cli/cli.rkt b/glaze-cli/cli.rkt index d42cd22..60e7376 100644 --- a/glaze-cli/cli.rkt +++ b/glaze-cli/cli.rkt @@ -9,20 +9,27 @@ glaze/license) (define (init-project name) + (unless (and (string? name) (non-empty-string? (string-trim name))) + (raise-argument-error 'init "non-empty-string?" name)) + (define target (path->complete-path name)) + (when (file-exists? target) + (error 'init "target exists and is a file: ~a" target)) + (when (and (directory-exists? target) + (pair? (directory-list target))) + (error 'init "target directory is not empty: ~a" target)) (printf "Creating Glaze project: ~a\n" name) - (make-directory* name) - (make-directory* (build-path name "public")) + (make-directory* target) + (make-directory* (build-path target "public")) + (write-file (build-path target "main.rkt") + (string-append "#lang racket/base\n\n" + "(require racket/runtime-path\n" + " glaze)\n\n" + "(define-runtime-path public \"public\")\n\n" + "(module+ main\n" + " (run-app #:public-dir public\n" + " #:title \"Glaze App\"))\n")) (write-file - (build-path name "main.rkt") - (string-append - "#lang racket/base\n\n" - "(require racket/runtime-path\n" - " glaze)\n\n" - "(define-runtime-path public \"public\")\n\n" - "(run-app #:public-dir public\n" - (format " #:title ~s)\n" name))) - (write-file - (build-path name "public" "index.html") + (build-path target "public" "index.html") #" @@ -52,9 +59,8 @@ (printf "Done! Run:\n cd ~a\n racket main.rkt\n\nOr use:\n cd ~a\n raco glaze dev\n" name name)) -;; `dev` runs the project's real entry point, so routes/events/window options -;; in main.rkt are preserved. Glaze development follows the same native GUI -;; path as the shipped application; there is no browser-mode escape hatch. +;; Run the project's real entry point so development exercises the same native +;; GUI path, routes, events, and window options as the shipped application. (define (dev-app) (define entry (build-path (current-directory) "main.rkt")) (unless (file-exists? entry) @@ -68,22 +74,13 @@ (unless (zero? code) (exit code))) -;; Parse the rest args for `build`. Recognized flags: -;; --name app/bundle name (default: project dir name) -;; --version app version (Info.plist / MSI ProductVersion) -;; --icon .ico (Windows) / .icns (macOS) -;; --entry entry file (default: main.rkt) -;; --out output directory (default: dist) -;; --embed-dlls Windows: embed DLLs into a single .exe -;; --installer also build a platform installer -;; --sign code-signing identity (macOS: codesign identity, -;; "-" = ad-hoc; Windows: cert SHA-1 thumbprint or -;; subject name for signtool) -;; --entitlements

macOS: path to a .entitlements plist -;; --no-hardened-runtime macOS: disable hardened runtime -;; --timestamp-url Windows: RFC-3161 timestamp server for signtool -;; --notarize macOS: notarytool keychain profile -;; --url-scheme deep-link URL scheme (repeatable) +;; ---- build ---- + +(define build-value-options + '("--name" "--version" "--icon" "--entry" "--out" + "--sign" "--entitlements" "--timestamp-url" "--notarize" + "--url-scheme")) + (define (parse-build-opts rest) (let loop ([args rest] [name #f] @@ -103,19 +100,21 @@ [(null? args) (values name version icon entry out embed installer sign entitlements no-hardened ts-url notarize (reverse schemes))] - [(and (equal? (car args) "--name") (pair? (cdr args))) + [(and (member (car args) build-value-options) (null? (cdr args))) + (error 'build "missing value for option: ~a" (car args))] + [(equal? (car args) "--name") (loop (cddr args) (cadr args) version icon entry out embed installer sign entitlements no-hardened ts-url notarize schemes)] - [(and (equal? (car args) "--version") (pair? (cdr args))) + [(equal? (car args) "--version") (loop (cddr args) name (cadr args) icon entry out embed installer sign entitlements no-hardened ts-url notarize schemes)] - [(and (equal? (car args) "--icon") (pair? (cdr args))) + [(equal? (car args) "--icon") (loop (cddr args) name version (cadr args) entry out embed installer sign entitlements no-hardened ts-url notarize schemes)] - [(and (equal? (car args) "--entry") (pair? (cdr args))) + [(equal? (car args) "--entry") (loop (cddr args) name version icon (cadr args) out embed installer sign entitlements no-hardened ts-url notarize schemes)] - [(and (equal? (car args) "--out") (pair? (cdr args))) + [(equal? (car args) "--out") (loop (cddr args) name version icon entry (cadr args) embed installer sign entitlements no-hardened ts-url notarize schemes)] [(equal? (car args) "--embed-dlls") @@ -124,35 +123,34 @@ [(equal? (car args) "--installer") (loop (cdr args) name version icon entry out embed #t sign entitlements no-hardened ts-url notarize schemes)] - [(and (equal? (car args) "--sign") (pair? (cdr args))) + [(equal? (car args) "--sign") (loop (cddr args) name version icon entry out embed installer (cadr args) entitlements no-hardened ts-url notarize schemes)] - [(and (equal? (car args) "--entitlements") (pair? (cdr args))) + [(equal? (car args) "--entitlements") (loop (cddr args) name version icon entry out embed installer sign (cadr args) no-hardened ts-url notarize schemes)] [(equal? (car args) "--no-hardened-runtime") (loop (cdr args) name version icon entry out embed installer sign entitlements #t ts-url notarize schemes)] - [(and (equal? (car args) "--timestamp-url") (pair? (cdr args))) + [(equal? (car args) "--timestamp-url") (loop (cddr args) name version icon entry out embed installer sign entitlements no-hardened (cadr args) notarize schemes)] - [(and (equal? (car args) "--notarize") (pair? (cdr args))) + [(equal? (car args) "--notarize") (loop (cddr args) name version icon entry out embed installer sign entitlements no-hardened ts-url (cadr args) schemes)] - [(and (equal? (car args) "--url-scheme") (pair? (cdr args))) + [(equal? (car args) "--url-scheme") (loop (cddr args) name version icon entry out embed installer sign entitlements no-hardened ts-url notarize (cons (cadr args) schemes))] [else - (printf "Warning: ignoring unknown build argument: ~a\n" (car args)) - (loop (cdr args) name version icon entry out embed installer - sign entitlements no-hardened ts-url notarize schemes)]))) + (error 'build "unknown build argument: ~a" (car args))]))) (define (build-command rest) (define-values (name version icon entry out embed installer sign entitlements no-hardened ts-url notarize schemes) (parse-build-opts rest)) - (printf "Building Glaze app (entry=~a, name=~a)...\n" entry (or name "")) + (printf "Building Glaze app (entry=~a, name=~a)...\n" + entry (or name "")) (define dist-path (build-app #:entry entry #:name name @@ -191,30 +189,31 @@ (displayln " --entry entry file (default: main.rkt)") (displayln " --out

output directory (default: dist)") (displayln " --embed-dlls Windows: embed DLLs into a single .exe") - (displayln " --installer Also build a platform installer (msi/dmg/AppImage);") - (displayln " falls back to zip/tar.gz when the toolchain is absent") - (displayln " --sign Code-sign the app (macOS: codesign identity, \"-\" =") - (displayln " ad-hoc; Windows: signtool cert SHA-1 or subject)") + (displayln " --installer Also build a platform installer") + (displayln " --sign Code-sign app (macOS identity / Windows cert)") (displayln " --entitlements

macOS: .entitlements plist for codesign") - (displayln " --no-hardened-runtime macOS: skip hardened runtime (notarization needs it)") - (displayln " --timestamp-url Windows: RFC-3161 timestamp server for signtool") - (displayln " --notarize macOS: notarize + staple via notarytool keychain profile") - (displayln " --url-scheme Deep-link URL scheme (repeatable): macOS gets") - (displayln " Info.plist entries; call (ensure-url-scheme! ...)") - (displayln " at app start on Windows/Linux)")) + (displayln " --no-hardened-runtime macOS: skip hardened runtime") + (displayln " --timestamp-url Windows: RFC-3161 timestamp server") + (displayln " --notarize macOS: notarize + staple via notarytool") + (displayln " --url-scheme Deep-link URL scheme (repeatable)")) (define (write-file path content) - (call-with-output-file path (lambda (out) (display content out)) #:exists 'replace)) + (call-with-output-file path + (lambda (out) (display content out)) + #:exists 'replace)) -;; ---- keygen: create an RSA keypair for license signing ---- +;; ---- keygen ---- (define (parse-keygen-opts rest) (let loop ([args rest] [out "keys"]) (cond [(null? args) out] - [(and (equal? (car args) "--out") (pair? (cdr args))) + [(equal? (car args) "--out") + (when (null? (cdr args)) + (error 'keygen "missing value for --out")) (loop (cddr args) (cadr args))] - [else (loop (cdr args) out)]))) + [else + (error 'keygen "unknown argument: ~a" (car args))]))) (define (keygen-command rest) (define out (parse-keygen-opts rest)) @@ -224,6 +223,12 @@ (make-directory* out) (define priv (build-path out "private.pem")) (define pub (build-path out "public.pem")) + ;; Never overwrite signing keys silently. A typo in --out must not destroy a + ;; production private key. + (when (or (file-exists? priv) (file-exists? pub)) + (error 'keygen + "refusing to overwrite existing private.pem/public.pem in ~a" + out)) (printf "Generating RSA-2048 keypair in ~a/...\n" out) (unless (zero? (system*/exit-code openssl "genpkey" "-algorithm" "RSA" "-pkeyopt" "rsa_keygen_bits:2048" @@ -231,11 +236,21 @@ (error 'keygen "openssl genpkey failed")) (unless (zero? (system*/exit-code openssl "pkey" "-in" (path->string priv) "-pubout" "-out" (path->string pub))) + (when (file-exists? priv) (delete-file priv)) + (when (file-exists? pub) (delete-file pub)) (error 'keygen "openssl pkey -pubout failed")) + (when (memq (system-type 'os) '(unix macosx)) + (file-or-directory-permissions priv #o600)) (printf "Done.\n private: ~a (keep secret — signs licenses)\n public: ~a (ship with the app — verifies licenses)\n" priv pub)) -;; ---- license: sign / verify license files ---- +;; ---- license ---- + +(define license-value-options + '("--key" "--pub" "--product" "--subject" "--expiry" "--out")) + +(define (option-token? s) + (and (string? s) (string-prefix? s "--"))) (define (parse-license-opts rest) (let loop ([args rest] @@ -245,25 +260,38 @@ [positional '()]) (cond [(null? args) - (values sub key pub product subject expiry machine out (reverse positional))] + (values sub key pub product subject expiry machine out + (reverse positional))] [(and (not sub) (member (car args) '("sign" "verify"))) (loop (cdr args) (car args) key pub product subject expiry machine out positional)] - [(and (equal? (car args) "--key") (pair? (cdr args))) - (loop (cddr args) sub (cadr args) pub product subject expiry machine out positional)] - [(and (equal? (car args) "--pub") (pair? (cdr args))) - (loop (cddr args) sub key (cadr args) product subject expiry machine out positional)] - [(and (equal? (car args) "--product") (pair? (cdr args))) - (loop (cddr args) sub key pub (cadr args) subject expiry machine out positional)] - [(and (equal? (car args) "--subject") (pair? (cdr args))) - (loop (cddr args) sub key pub product (cadr args) expiry machine out positional)] - [(and (equal? (car args) "--expiry") (pair? (cdr args))) - (loop (cddr args) sub key pub product subject (cadr args) machine out positional)] - [(and (equal? (car args) "--machine-id") (pair? (cdr args))) - (loop (cddr args) sub key pub product subject expiry (cadr args) out positional)] + [(member (car args) license-value-options) + (when (or (null? (cdr args)) (option-token? (cadr args))) + (error 'license "missing value for option: ~a" (car args))) + (define option (car args)) + (define value (cadr args)) + (cond + [(equal? option "--key") + (loop (cddr args) sub value pub product subject expiry machine out positional)] + [(equal? option "--pub") + (loop (cddr args) sub key value product subject expiry machine out positional)] + [(equal? option "--product") + (loop (cddr args) sub key pub value subject expiry machine out positional)] + [(equal? option "--subject") + (loop (cddr args) sub key pub product value expiry machine out positional)] + [(equal? option "--expiry") + (loop (cddr args) sub key pub product subject value machine out positional)] + [else + (loop (cddr args) sub key pub product subject expiry machine value positional)])] [(equal? (car args) "--machine-id") - (loop (cdr args) sub key pub product subject expiry (machine-id) out positional)] - [(and (equal? (car args) "--out") (pair? (cdr args))) - (loop (cddr args) sub key pub product subject expiry machine (cadr args) positional)] + (cond + [(and (pair? (cdr args)) (not (option-token? (cadr args)))) + (loop (cddr args) sub key pub product subject expiry + (cadr args) out positional)] + [else + (loop (cdr args) sub key pub product subject expiry + (machine-id) out positional)])] + [(option-token? (car args)) + (error 'license "unknown option: ~a" (car args))] [else (loop (cdr args) sub key pub product subject expiry machine out (cons (car args) positional))]))) @@ -274,7 +302,12 @@ (case sub [("sign") (unless (and key product subject) - (error 'license "usage: raco glaze license sign --key --product --subject [--expiry YYYY-MM-DD] [--machine-id] --out ")) + (error 'license + "usage: raco glaze license sign --key --product --subject [--expiry YYYY-MM-DD] [--machine-id] --out ")) + (unless (null? positional) + (error 'license "unexpected positional argument for sign: ~a" (car positional))) + (when pub + (error 'license "--pub applies to license verify, not sign")) (issue-license #:private-key key #:product product #:subject subject @@ -283,24 +316,32 @@ #:out out) (printf "License written: ~a\n" out)] [("verify") - (unless (and pub product (pair? positional)) - (error 'license "usage: raco glaze license verify --pub --product ")) - (define r (validate-license (last positional) #:public-key pub #:product product)) + (unless (and pub product (= (length positional) 1)) + (error 'license + "usage: raco glaze license verify --pub --product [--machine-id ] ")) + (when key + (error 'license "--key applies to license sign, not verify")) + (define r + (if machine + (validate-license (car positional) + #:public-key pub + #:product product + #:machine-id machine) + (validate-license (car positional) + #:public-key pub + #:product product))) (if (hash-ref r 'valid) - (begin - (printf "VALID\n subject: ~a\n expiry: ~a\n machine-id: ~a\n" - (hash-ref r 'subject) - (or (hash-ref r 'expiry) "(no expiry)") - (or (hash-ref r 'machine-id) "(not machine-bound)"))) + (printf "VALID\n subject: ~a\n expiry: ~a\n machine-id: ~a\n" + (hash-ref r 'subject) + (or (hash-ref r 'expiry) "(no expiry)") + (or (hash-ref r 'machine-id) "(not machine-bound)")) (printf "INVALID (reason: ~a)\n" (hash-ref r 'reason))) (unless (hash-ref r 'valid) (exit 1))] [else - (displayln "usage: raco glaze license sign|verify [options]") - (displayln " sign: --key --product --subject ") - (displayln " [--expiry YYYY-MM-DD] [--machine-id | --machine-id ] --out ") - (displayln " verify: --pub --product ")])) + (error 'license "expected subcommand sign or verify")])) + +;; ---- dispatch ---- -;; Dispatch CLI commands (define args (vector->list (current-command-line-arguments))) (cond [(null? args) (print-help)] @@ -309,14 +350,19 @@ (define rest (cdr args)) (match cmd ["init" - (init-project (if (null? rest) - "myapp" - (car rest)))] - ["dev" (dev-app)] + (when (> (length rest) 1) + (error 'init "expected at most one project path")) + (init-project (if (null? rest) "myapp" (car rest)))] + ["dev" + (unless (null? rest) (error 'dev "unexpected arguments: ~a" rest)) + (dev-app)] ["build" (build-command rest)] ["keygen" (keygen-command rest)] ["license" (license-command rest)] - ["help" (print-help)] + ["help" + (unless (null? rest) (error 'help "unexpected arguments: ~a" rest)) + (print-help)] [_ - (printf "Unknown command: ~a\n" cmd) - (print-help)])]) + (eprintf "Unknown command: ~a\n" cmd) + (print-help) + (exit 2)])]) diff --git a/glaze-cli/info.rkt b/glaze-cli/info.rkt index 261e7bd..8cde413 100644 --- a/glaze-cli/info.rkt +++ b/glaze-cli/info.rkt @@ -1,11 +1,10 @@ #lang info +;; Collection metadata only. Package dependencies belong to the repository +;; root info.rkt because Glaze ships as one multi-collection package. (define collection "glaze-cli") -(define deps - '(["base" #:version "8.0"] - "glaze-lib")) (define pkg-desc "CLI tools for Glaze — raco glaze commands") (define pkg-authors '(turinglambdaai)) (define license 'MIT) (define raco-commands - '(("glaze" glaze-cli/cli "create and serve Glaze apps" 100))) + '(("glaze" glaze-cli/cli "create, develop, and package Glaze apps" 100))) diff --git a/glaze-doc/scribblings/glaze.scrbl b/glaze-doc/scribblings/glaze.scrbl index b613b4f..50c93f5 100644 --- a/glaze-doc/scribblings/glaze.scrbl +++ b/glaze-doc/scribblings/glaze.scrbl @@ -3,9 +3,7 @@ @title{Glaze} @author{turinglambdaai} -Glaze builds desktop applications with a Racket backend and a Web frontend -rendered inside a native OS window. Windows uses WebView2, macOS uses -WKWebView, and Linux uses WebKitGTK. +Build desktop apps with Racket backend and web frontend. @section{Quick Start} @@ -14,370 +12,634 @@ WKWebView, and Linux uses WebKitGTK. $ raco glaze init myapp $ cd myapp $ racket main.rkt - # or: raco glaze dev } -A Glaze application is @bold{native-GUI only}. If its native WebView cannot -start, application startup fails with platform-specific installation or repair -guidance. Glaze never substitutes a system-browser tab for the desktop window. - -@section{Application Lifecycle} +@section{Core API} @defmodule[glaze/app] @defproc[(run-app [#:public-dir public-dir (or/c string? path?) "public"] [#:api api (listof route?) '()] - [#:port port (or/c #f exact-nonnegative-integer?) #f] + [#:port port (or/c #f (integer-in 1 65535)) #f] [#:title title string? "Glaze"] [#:width width exact-positive-integer? 1024] [#:height height exact-positive-integer? 768] + [#:background-active? background-active? boolean? #f] [#:events events (or/c #f event-bus?) #f] - [#:api-token api-token (or/c #f string? #t) #f] + [#:api-token api-token (or/c #f string? #t) #t] [#:on-close on-close (-> any) (lambda () (void))] - [#:on-error on-error (or/c #f procedure?) #f] + [#:on-error on-error (or/c #f (exn? string? . -> . any)) #f] [#:check-update check-update (or/c #f string?) #f] [#:current-version current-version string? "0.0.0"] - [#:on-ready on-ready procedure? (lambda (wv url) (void))]) + [#:on-ready on-ready (-> webview? string? any) + (lambda (wv url) (void))]) (values 'webview procedure?)]{ -The one-call application entry point. It selects a free loopback port unless -@racket[#:port] is supplied, starts the static/API server, opens the native -WebView window, invokes @racket[on-ready] with the @racket[webview?] handle and -clean application URL, and blocks until the window closes. - -When the native window closes, the local server is stopped and the procedure -returns @racket[(values 'webview shutdown)]. If native WebView startup fails, -Glaze first stops the local server and then propagates an actionable startup -error. There is intentionally no browser-fallback option. - -@racket[#:api-token] may be a string or @racket[#t]. With @racket[#t], Glaze -generates a random capability token and uses a one-time bootstrap URL to set an -HttpOnly cookie for the embedded frontend. @racket[#:on-error] receives API -handler failures. @racket[#:check-update] wires an update manifest into the -application lifecycle. +The one-call entry: picks a free port (unless @racket[#:port] is given), +starts the server (static + JSON API, optional SSE event bus and API token), +opens the native webview window, and blocks until the window closes. +@racket[on-ready] receives the webview handle and URL as soon as the window +is up — the hook agents use for verification. @racket[on-error], when given, +receives every API-handler failure (the 500 path) for crash reporting. +By default @racket[#:api-token] is @racket[#t], so a random token is generated +(@racket[make-api-token]). The token is not printed; the WebView receives +it through the bootstrap URL and trusted Racket callbacks can read it through +@racket[current-api-token]. Pass @racket[#f] explicitly only when an open local +API is intended. +When @racket[#:check-update] is a manifest URL, a background check runs +(see @secref["update-checks"]). + +Returns @racket['webview] after a window-driven shutdown (server already +stopped). A native WebView is mandatory. If startup fails, the server is +stopped and an actionable platform-specific diagnostic is raised; Glaze does +not open the system browser as a fallback. } -@defproc[(make-api-token) string?]{ -Returns a random 32-hex-character capability token. -} +@defproc[(make-api-token) string?]{ A random 32-hex-character capability +token (CSPRNG) for use with @racket[#:api-token]. } @defparam[current-api-token token string?]{ -Bound by @racket[run-app] so callbacks can read the active API token; the value -is the empty string when API-token protection is disabled. +Bound by @racket[run-app] so callbacks can read the active token (empty when +the API is open). } -@section{Local Server} - @defmodule[glaze/server] @defproc[(start-server - [#:port port exact-nonnegative-integer? 8080] + [#:port port (integer-in 1 65535) 8080] [#:public-dir public-dir (or/c string? path?) "public"] [#:api api (listof route?) '()] [#:events events (or/c #f event-bus?) #f] [#:api-token api-token (or/c #f string?) #f] [#:serve-api-client? serve-api-client? boolean? #t]) (values exact-nonnegative-integer? procedure?)]{ -Starts the loopback HTTP server that powers the embedded frontend. Static -resources, SPA index fallback, JSON routes, generated API client, and optional -SSE event stream share the same origin. The return values are the actual port -and a shutdown procedure. @racket[start-dev-server] remains a compatibility -alias for this low-level server primitive; it does not define a browser-based -application mode. +Starts a local HTTP server on @racket[127.0.0.1] serving static files from +@racket[public-dir] (SPA index.html fallback) with optional JSON API routes +(see @secref["js-bridge"]). Verifies the listener is accepting before +returning. Returns the port and a shutdown procedure. + +@racket[#:events] mounts the SSE endpoint @litchar{GET /glaze/events} +(see @secref["events"]). @racket[#:api-token] guards the API routes and the +SSE stream (see @secref["security"]). @racket[#:serve-api-client?] controls +the generated JS client at @litchar{GET /glaze/api.js}. +@racket[start-dev-server] is a backward-compatible alias. } -@defproc[(stop-server [shutdown-proc procedure?]) void?]{Stops the server.} +@defproc[(stop-server [shutdown-proc procedure?]) void?]{ +Stops the server. +} + +@defparam[current-glaze-error-reporter reporter + (exn? string? . -> . any)]{ +Receives API-handler failures (the 500 path). Defaults to logging on stderr; +@racket[run-app] parameterizes this to its @racket[#:on-error] callback. +} @defmodule[glaze/browser] @defproc[(open-browser [url string?]) void?]{ -Explicitly opens an external URL in the user's default browser. This helper is -appropriate for documentation, OAuth, support pages, and similar external -resources. @racket[run-app], @racket[open-window], and @racket[open-webview] -do not use it as a fallback. +Opens the system browser to the given external URL. This low-level utility is +not used as an application fallback by @racket[run-app] or @racket[open-window]. } @section[#:tag "js-bridge"]{JavaScript Bridge} @defmodule[glaze/api] -The embedded frontend calls Racket through ordinary same-origin HTTP requests. -This keeps the bridge easy to inspect and test with normal developer tools. +The embedded page calls Racket with plain @litchar{fetch("/api/...")}; Racket +answers JSON. The same endpoints remain easy to exercise from developer tools +such as curl. @defproc[(GET [path string?] [handler procedure?]) route?]{} @defproc[(POST [path string?] [handler procedure?]) route?]{} @defproc[(PUT [path string?] [handler procedure?]) route?]{} -@defproc[(DELETE [path string?] [handler procedure?]) route?]{} - -A route handler receives the web-server request followed by any captured -@litchar{:param} path values. Returning a jsexpr produces a JSON 200 response; -a full response value may also be returned. +@defproc[(DELETE [path string?] [handler procedure?]) route?]{ +Build a route for @racket[path]. @litchar{":x"} segments capture the +request path segment as a string. The handler receives the web-server +request followed by the captured values and returns a jsexpr (auto-wrapped +as a 200 JSON response) or a full response. +} @defproc[(request-json-body [req request?]) jsexpr?]{ -Parses a JSON request body. Missing, empty, or malformed input yields an empty -hash so route validation can produce a clean client error. JSON object keys in -Racket jsexprs are symbols, for example @racket[(hash-ref body 'delta)]. +Parses the request body as JSON; a missing, empty, or invalid body yields +the empty hash so optional parameters fall back to defaults and required +ones report a clean 400. Racket jsexpr parses JSON object keys as +@bold{symbols}: @racket[(hash-ref body 'delta)]. } -@defproc[(json-response [data jsexpr?]) response?]{} -@defproc[(api-response [data jsexpr?]) response?]{} -@defproc[(error-response [status exact-nonnegative-integer?] - [message string?]) response?]{} +@defproc[(json-response [data jsexpr?]) response?]{ A 200 JSON response. } +@defproc[(api-response [data jsexpr?]) response?]{ Same as @racket[json-response]. } +@defproc[(error-response [status exact-nonnegative-integer?] [msg string?]) + response?]{ A JSON error response with the given status code. } + +@defproc[(exn:fail:glaze:bad-param? [v any/c]) boolean?]{ +Raised by @racket[define-api-routes] argument checking; the server maps it +to a 400 naming the parameter. A plain @racket[exn:fail] from a handler +stays a 500. +} + +@codeblock|{ +#lang racket/base +(require glaze) +(run-app + #:public-dir "public" + #:api (list + (POST "api/counter/bump" + (lambda (req) + (define body (request-json-body req)) + (bump! (hash-ref body 'delta 1)))))) +}| + +@subsection[#:tag "typed-routes"]{Typed Routes: @racket[define-api-routes]} @defmodule[glaze/api-macros] @defform[(define-api-routes id clause ...)]{ -Declares a callable Racket procedure, a validated HTTP route, and a generated -JavaScript client entry from one route clause. +Each @racket[clause] has the shape @racketblock[ +[(METHOD _path) + (_proc _param ...) + _body ...+]] + +and defines @bold{three} things from one declaration: + +@itemlist[ + @item{a Racket procedure @racket[_proc], callable directly (tests + included);} + @item{a route added to @racket[id] — JSON body keys and @litchar{":x"} path + captures become the procedure's arguments;} + @item{a JS client entry served at @litchar{/glaze/api.js} (see below).}] + +Parameter forms: plain @racket[_id] (required, any value), +@racket[[_id predicate]] (required, checked), or +@racket[[_id predicate default]] (optional with default). Bad input raises +a 400 naming the parameter; handler exceptions stay 500. + +@codeblock|{ +#lang racket/base +(require glaze) (define-api-routes api [(POST "api/counter/bump") (bump [delta exact-nonnegative-integer? 1]) - (hasheq 'count (add1 delta))])] - -The generated @litchar{/glaze/api.js} exposes route-specific functions plus -@litchar{glaze.call(...)} and @litchar{glaze.on(...)}. + (begin (bump! delta) (hasheq 'count (count)))] + [(GET "api/items/:id") + (item id) + (hasheq 'id id)]) +(run-app #:public-dir "public" #:api api) +}| } -@section[#:tag "events"]{Event Push} - -@defmodule[glaze/events] - -Glaze uses same-origin Server-Sent Events for backend-to-frontend push. +@subsection[#:tag "js-client"]{The Generated JS Client} -@defproc[(make-event-bus) event-bus?]{Creates a broadcast event bus.} -@defproc[(bus-broadcast! [bus event-bus?] - [name (or/c symbol? string?)] - [data jsexpr?]) void?]{ -Broadcasts an event without blocking the producer; a full per-subscriber -backlog drops that event for the slow subscriber only. -} -@defproc[(bus-subscribe! [bus event-bus?]) async-channel?]{} -@defproc[(bus-unsubscribe! [bus event-bus?] [channel async-channel?]) void?]{} -@defproc[(bus-wait [channel async-channel?] [seconds real? 10]) any/c]{} +With routes registered, @litchar{GET /glaze/api.js} serves a client derived +from them: each route becomes a @litchar{glaze.api.*} function (path +params become arguments), plus the generic +@litchar{glaze.call(method, path, body)} and +@litchar{glaze.on(name, fn)} (an EventSource wrapper over +@litchar{/glaze/events}). Disable with +@racket[#:serve-api-client? #f]. -@section{Native WebView} +@verbatim|{ +const s = await glaze.api.counterBump({delta: 5}); +glaze.on('count-changed', s => render(s.count)); +}| -@defmodule[glaze/webview/main] +@section[#:tag "events"]{Event Push (SSE)} -The native WebView is an application prerequisite, not an optional rendering -mode. The backends are WebView2 on Windows, WKWebView on macOS, and WebKitGTK -on Linux. +@defmodule[glaze/events] -@defproc[(open-window - [url string?] - [#:title title string? "Glaze"] - [#:width width exact-positive-integer? 1024] - [#:height height exact-positive-integer? 768] - [#:devtools? devtools? boolean? #f] - [#:on-close on-close (-> any) (lambda () (void))]) - webview?]{ -Opens a native desktop window and loads @racket[url]. If the backend or its -runtime dependency is unavailable, this procedure raises. Before raising in -an interactive desktop process, Glaze also attempts to show an OS-level error -dialog so packaged GUI applications without a console still give the user an -actionable explanation. CI environments suppress the dialog and retain the -exception text in logs. +Backend-to-frontend push — Glaze's answer to Tauri's @litchar{emit()} and +Eel's websocket push — over plain Server-Sent Events on the same origin as the +embedded frontend. -There is no @racket[#:fallback-browser?] keyword. -} +@defproc[(make-event-bus) event-bus?]{ A broadcast bus. Pass it to +@racket[start-server]/@racket[run-app] via @racket[#:events] to mount +@litchar{GET /glaze/events} (15s keepalive; per-subscriber bounded backlog +with drop-on-overflow; disconnect cleanup). } -@defproc[(open-webview - [url string?] - [#:title title string? "Glaze"] - [#:width width exact-positive-integer? 1024] - [#:height height exact-positive-integer? 768] - [#:devtools? devtools? boolean? #f] - [#:on-close on-close (-> any) (lambda () (void))]) - webview?]{ -Lower-level synonym of @racket[open-window] with the same fail-fast contract. +@defproc[(bus-broadcast! [bus event-bus?] [name (or/c symbol? string?)] + [data jsexpr?]) void?]{ +Deliver @racket[(list name data)] to every subscriber, from any thread. +Non-blocking: a full backlog drops the event for that subscriber only. } -@defproc[(webview-supported?) boolean?]{ -Non-throwing capability probe for the current platform backend. Actual window -creation remains the authoritative runtime check. +@defproc[(bus-subscribe! [bus event-bus?]) async-channel?]{ +Register a new subscriber; returns an asynchronous channel of +@racket[(list name data)] pairs (for non-SSE consumers). } -@defproc[(webview-last-error) any/c]{Returns the most recent backend probe/startup error.} -@defproc[(webview-install-guidance) string?]{ -Returns platform-specific dependency guidance. Windows guidance names the -Microsoft Edge WebView2 Evergreen Runtime; Linux guidance names GTK 3 and -WebKitGTK packages; macOS explains that WKWebView is part of the OS. -} -@defproc[(webview-diagnostic) string?]{Formats the current error and guidance.} - -@defproc[(webview-navigate [wv webview?] [url string?]) void?]{} -@defproc[(webview-close [wv webview?]) void?]{} -@defproc[(webview-title [wv webview?]) (or/c #f string?)]{} -@defproc[(webview-url [wv webview?]) (or/c #f string?)]{} -@defproc[(webview-capture! [wv webview?] - [dest (or/c #f string? path?) #f]) - (or/c #f path?)]{} -@defproc[(webview-set-title! [wv webview?] [title string?]) void?]{} -@defproc[(webview-set-size! [wv webview?] - [width exact-positive-integer?] - [height exact-positive-integer?]) void?]{} -@defproc[(webview-set-fullscreen! [wv webview?] [on? boolean?]) void?]{} -@defproc[(webview-focus! [wv webview?]) void?]{} -@defproc[(webview-set-menu! [wv webview?] [menus list?]) void?]{} -@defproc[(webview-closed? [wv webview?]) boolean?]{} -@defproc[(all-webviews) (listof webview?)]{} -@defproc[(close-all-webviews!) void?]{} -@defproc[(wait-for-webviews [timeout-seconds (or/c #f real?) #f]) boolean?]{} +@defproc[(bus-unsubscribe! [bus event-bus?] [ch async-channel?]) void?]{} -@subsection{Startup Dependency Feedback} +@defproc[(bus-wait [ch async-channel?] [secs real? 10]) + (or/c (list/c symbol? jsexpr?) 'timeout)]{ +Blocking receive with timeout — for tests and non-SSE consumers. +} -When native startup fails, Glaze reports the backend error and remediation. -Typical guidance includes: +In the page: -@itemlist[ - @item{Windows: install or repair Microsoft Edge WebView2 Runtime (Evergreen), - with a @exec{winget} command and Microsoft's official download page.} - @item{Debian/Ubuntu: @exec{sudo apt install libgtk-3-0 libwebkit2gtk-4.1-0}.} - @item{Fedora: @exec{sudo dnf install gtk3 webkit2gtk4.1}.} - @item{Arch: @exec{sudo pacman -S gtk3 webkit2gtk-4.1}.} - @item{macOS: WKWebView is built in; use a logged-in graphical session and - report the preserved backend error if initialization still fails.}] - -Set environment variable @envvar{GLAZE_NO_STARTUP_DIALOG} to @litchar{1} to -suppress the interactive error dialog while retaining the exception. Dialogs -are also suppressed automatically under common CI environments. +@verbatim|{ +const es = new EventSource('/glaze/events'); +es.addEventListener('count-changed', e => render(JSON.parse(e.data).count)); +}| @section{System Integrations} @defmodule[glaze/sys] -@defproc[(sys-supported?) boolean?]{} -@defproc[(clipboard-set! [text string?]) boolean?]{} -@defproc[(clipboard-get) string?]{} -@defproc[(notify! [title string?] - [body string? ""] - [#:subtitle subtitle string? ""]) boolean?]{} -@defproc[(open-path [path-or-url (or/c path? string?)]) boolean?]{} -@defproc[(reveal-path [path (or/c path? string?)]) boolean?]{} -@defproc[(single-instance? [app-id any/c]) boolean?]{} - -These helpers are best-effort integrations. Their failure semantics are -separate from the WebView startup contract: the WebView is required for the -application itself, while an optional integration may report failure without -changing the application's rendering model. +Desktop-system integrations beyond the tray, with the same platform +dispatch (and no-op degradation) as @racket[glaze/tray]. All procedures are +best-effort and never raise for environmental reasons. -@section{System Tray} +@defproc[(sys-supported?) boolean?]{ Whether the current platform backend +loaded its native libraries. } -@defmodule[glaze/tray] +@defproc[(clipboard-set! [text string?]) boolean?]{ Places text on the +system clipboard. } -@defproc[(tray-supported?) boolean?]{} -@defproc[(make-tray [#:icon icon any/c] - [#:tooltip tooltip string?] - [#:menu menu list?] - [#:on-event on-event procedure? (lambda (e) (void))]) - tray?]{} -@defproc[(tray-set-tooltip! [tray tray?] [tooltip string?]) void?]{} -@defproc[(tray-set-icon! [tray tray?] [icon any/c]) void?]{} -@defproc[(tray-set-menu! [tray tray?] [menu list?]) void?]{} -@defproc[(tray-close [tray tray?]) void?]{} - -The tray remains an optional capability. If its native backend is unavailable, -Glaze may use an inert tray stub; this does not weaken the mandatory native -WebView contract for the main window. +@defproc[(clipboard-get) string?]{ Reads text from the system clipboard +(@litchar{""} when empty or unavailable). } -@section[#:tag "security"]{Security} +@defproc[(notify! [title string?] [body string? ""] + [#:subtitle subtitle string? ""]) boolean?]{ +Shows a desktop notification; delivery itself is best-effort (OS settings +may suppress it). +} + +@defproc[(open-path [p (or/c path? string?)]) boolean?]{ +Opens a path or URL with the OS default handler. +} -The local server binds to loopback and validates Host headers against -@litchar{127.0.0.1}, @litchar{localhost}, and @litchar{[::1]} to reduce DNS -rebinding risk. +@defproc[(reveal-path [p (or/c path? string?)]) boolean?]{ +Reveals a file in Finder / Explorer / the file manager, selecting it. +} -With @racket[#:api-token], API routes and the SSE stream require a capability. -@racket[run-app] opens the native WebView at a one-time bootstrap URL; the -server exchanges the token for an HttpOnly cookie and redirects to the clean -path. Programmatic clients may use the @litchar{X-Glaze-Token} header. +@defproc[(single-instance? [app-id string?]) boolean?]{ +Adjudicates @litchar{"am I the first instance?"} without leaving files +behind: derives a deterministic TCP port from the id and holds a listener on +it for the process lifetime. The second instance's bind fails and gets +@racket[#f]. (A firewall prompt is possible on first run on some systems.) +} -This is defense in depth against casual local callers, not isolation from -other processes running as the same OS user. +Window controls live in @racket[glaze/webview]: @racket[webview-set-title!], +@racket[webview-set-size!], @racket[webview-set-fullscreen!], +@racket[webview-focus!]. @section[#:tag "update-checks"]{Update Checks} @defmodule[glaze/update] +Glaze deliberately stops at @emph{notification} — downloading and replacing +a running app is a per-distribution decision (notarized DMG, MSI upgrade, +AppImage overwrite); the app decides what an @litchar{update-available} +event means. + @defproc[(check-update [manifest-url string?] - [#:current-version current-version string? "0.0.0"]) + [#:current-version current string? "0.0.0"]) (or/c #f hash?)]{ -Checks a JSON manifest for a newer version. An optional @litchar{sha256} field -is passed through for artifact verification. +Fetches a JSON manifest @litchar|{{"version","url","notes"}}| (5s timeout, +2xx responses only, 1 MiB maximum body; HTTPS needs the @racket[openssl] +collection) and compares versions +numerically (@litchar{"1.10"} > @litchar{"1.9"}). Returns +@racket[(hasheq 'version _ 'url _ 'notes _ 'sha256 _)] when a newer version +exists, @racket[#f] otherwise. The manifest may carry an optional +@litchar{"sha256"} field (hex digest of the artifact at @racket[_url]); +it is passed through untouched. } + @defproc[(newer-version? [candidate string?] [current string?]) boolean?]{} -@defproc[(verify-file-sha256 [path (or/c string? path?)] - [expected-hex string?]) boolean?]{ -Returns @racket[#t] only for a verified digest; @racket[#f] also covers cases -where verification could not be performed. + +@defproc[(verify-file-sha256 [path (or/c string? path?)] [expected-hex string?]) boolean?]{ +True when the file at @racket[path] has the given SHA-256 digest +(case-insensitive). @racket[#f] means @emph{cannot verify} (missing +openssl, unreadable file) — never treat @racket[#f] as verified. Use it +after downloading an update artifact, before swapping it in. } -@section{Licensing} +@racket[run-app]'s @racket[#:check-update] and @racket[#:current-version] +wire this up: the result is printed to stderr and broadcast as +@litchar{update-available} on the event bus (when @racket[#:events] is +given). + +@section[#:tag "licensing"]{Licensing (Paid Apps)} @defmodule[glaze/license] -Glaze includes an offline RSA-2048/SHA-256 licensing helper backed by the -system @exec{openssl} command. +An offline license-key scheme with no bundled native crypto library: +RSA-2048 / SHA-256 signatures are computed by the system @racket[openssl] CLI (present on +macOS and Linux out of the box; Git for Windows ships it too). A license +file is JSON claims (@racket[product], @racket[subject], optional +@racket[expiry] and @racket[machine-id]) plus a base64 @racket[signature]. + +Vendor workflow: + +@verbatim{ + $ raco glaze keygen --out keys ; once: private.pem + public.pem + $ raco glaze license sign --key keys/private.pem --product "MyApp" \\ + --subject "Acme Corp" --expiry 2027-12-31 --out app.license + $ raco glaze license verify --pub keys/public.pem --product "MyApp" app.license +} @defproc[(issue-license [#:private-key private-key path-string?] [#:product product string?] [#:subject subject string?] [#:expiry expiry (or/c #f string?) #f] - [#:machine-id machine-id (or/c #f string?) #f] - [#:out output (or/c string? path?) "app.license"]) - path?]{} + [#:machine-id machine (or/c #f string?) #f] + [#:out out (or/c string? path?) "app.license"]) + path?]{ +Signs and writes a license file; returns its path. +} + @defproc[(validate-license [license-file (or/c string? path?)] [#:public-key public-key path-string?] [#:product product string?] - [#:machine-id machine-id string? (machine-id)]) - hash?]{} + [#:machine-id machine string? (machine-id)]) + hash?]{ +Returns @racket[(hasheq 'valid #t 'subject _ 'expiry _ 'machine-id _)] on +success, or @racket[(hasheq 'valid #f 'reason _)] with a stable reason tag: +@racket["missing-file"], @racket["malformed"], @racket["signature"], +@racket["product"], @racket["expired"], @racket["machine"], +@racket["openssl-unavailable"]. +} + @defproc[(license-valid? [license-file (or/c string? path?)] [#:public-key public-key path-string?] [#:product product string?] - [#:machine-id machine-id string? (machine-id)]) + [#:machine-id machine string? (machine-id)]) boolean?]{} -@defproc[(machine-id) string?]{} -@defproc[(days-until-expiry [expiry string?]) exact-integer?]{} -@section{File Dialogs} +@defproc[(machine-id) string?]{ +A stable per-machine digest (64 lowercase hex chars) of the OS machine +identifier — IOPlatformUUID (macOS), @filepath{/etc/machine-id} (Linux), +MachineGuid (Windows) — with a username+hostname fallback. The raw OS +identifier never leaves the function. Honest scope: machine binding is a +courtesy check against casual license sharing, not tamper resistance. +} + +@defproc[(days-until-expiry [expiry string?]) exact-integer?]{ +Days until an @litchar{"YYYY-MM-DD"} date (expiry day inclusive); negative +when past. Raises on a malformed date. +} + +@section[#:tag "dialogs"]{File Dialogs} @defmodule[glaze/dialogs] -@defproc[(dialog-supported?) boolean?]{} +Native open/save dialogs: @racket[NSOpenPanel]/@racket[NSSavePanel] +(macOS), @racket[GetOpenFileNameW]/@racket[GetSaveFileNameW] (Windows), +@exec{zenity}/@exec{kdialog} (Linux). Dialogs block the calling thread. + @defproc[(pick-file [#:title title (or/c #f string?) #f] [#:directory directory (or/c #f path-string?) #f] [#:filters filters list? '()]) - (or/c #f path?)]{} + (or/c #f path?)]{ +Opens one file. @racket[filters] is a list of +@racket[(list "Human name" "*.txt" "*.md")]. @racket[#f] = cancelled. +} + @defproc[(pick-files [#:title title (or/c #f string?) #f] [#:directory directory (or/c #f path-string?) #f] [#:filters filters list? '()]) - (listof path?)]{} + (listof path?)]{ +Multi-select; empty list = cancelled. +} + @defproc[(pick-folder [#:title title (or/c #f string?) #f] [#:directory directory (or/c #f path-string?) #f]) (or/c #f path?)]{} + @defproc[(save-file-dialog [#:title title (or/c #f string?) #f] [#:default-name default-name (or/c #f string?) #f] [#:directory directory (or/c #f path-string?) #f] [#:filters filters list? '()]) - (or/c #f path?)]{} + (or/c #f path?)]{ +The overwrite prompt is the dialog's; no file is created here. +} + +@defproc[(dialog-supported?) boolean?]{@racket[#f] when no dialog backend +exists on this platform (open/save then raise).} + +@section[#:tag "menus"]{Menu Bar} -@section{Deep Links and Launch at Login} +@defmodule[glaze/webview] + +@defproc[(webview-set-menu! [wv webview?] [menus (listof menu?)]) void?]{ +Replaces the custom section of the application menu bar. Menus are +declared with the tray protocol vocabulary: +@racket[(list (make-menu "File" (list (make-menu-item "Open…" #:accel +"CmdOrCtrl+O" #:action open-doc) menu-separator)))]. Accelerator +keystrokes fire for real on macOS; on Windows/Linux they are displayed +next to the label (v1). The platform-standard menus (Edit/Window on macOS) +are preserved. +} + +@defproc[(webview-closed? [wv webview?]) boolean?]{True once the window is +closed — by @racket[webview-close] or the OS chrome.} + +@defproc[(all-webviews) (listof webview?)]{Every window this process +opened that is not yet garbage collected.} + +@defproc[(close-all-webviews!) void?]{Closes every open window (each +delivers its @racket[#:on-close]).} + +@defproc[(wait-for-webviews [timeout-secs (or/c #f real?) #f]) boolean?]{ +Blocks until every open window closes; @racket[#f] on timeout. +} + +@section[#:tag "deeplink-autolaunch"]{Deep Links & Launch at Login} @defmodule[glaze/deeplink] @defproc[(ensure-url-scheme! [scheme string?] [#:app-name app-name string? scheme]) - any/c]{ -Windows registers a user-scope URL protocol, Linux writes a desktop entry and -uses @exec{xdg-mime} when available, and macOS URL schemes are declared in the -bundle at build time. + symbol?]{ +Registers @racket[scheme]:// for this executable, idempotently. Windows: +HKCU registry entries. Linux: a desktop entry plus @exec{xdg-mime default}. +macOS: handlers are declared in the packaged Info.plist — pass +@racket[#:url-schemes] to @racket[build-app] (or +@exec{raco glaze build --url-scheme}); the runtime call returns +@racket['build-time]. Receiving the URL is the established +single-instance + argv pattern: the OS launches the executable with the +URL as an argument. } @defmodule[glaze/autolaunch] @defproc[(auto-launch-set! [name string?] [enabled? boolean?]) void?]{} -@defproc[(auto-launch-enabled? [name string?]) any/c]{} + +@defproc[(auto-launch-enabled? [name string?]) + (or/c boolean? 'requires-approval 'not-registered)]{ +macOS uses SMAppService (macOS 13+, packaged .app, no permission prompt); +Windows the HKCU Run key; Linux autostart desktop entries. +} + +@section[#:tag "signing"]{Code Signing & Notarization} + +Unsigned apps are blocked by macOS Gatekeeper and Windows SmartScreen. +@racket[build-app] and @racket[raco glaze build] drive the platform +signer: + +@itemlist[ + @item{macOS: @exec{codesign} with an identity (@litchar{"-"} = ad-hoc); + nested code (the bundled Racket framework) is signed first, then the + bundle. @racket[#:notarize-profile] submits the built dmg via + @exec{xcrun notarytool}, waits, and staples the ticket.} + @item{Windows: @exec{signtool} with a SHA-1 thumbprint or subject name, + RFC-3161 timestamped by default so signatures outlive the certificate.} +] + +Signing @emph{failures} abort the build; a @emph{missing toolchain} +degrades with a loud warning. On macOS, hardened runtime +(@racket[#:no-hardened-runtime?] disables it) is applied unless the +identity is ad-hoc — its library validation would reject the app's own +ad-hoc-signed framework. + +@section{System Tray} + +@defmodule[glaze/tray] + +Glaze provides a cross-platform system tray backed by pure Racket FFI +(Windows @racket[Shell_NotifyIconW], macOS @racket[NSStatusItem], Linux +@racket[libayatana-appindicator]). When a platform's native libraries are +unavailable, the tray degrades to a no-op stub. + +@defproc[(make-tray + [#:icon icon (or/c #f path?)] + [#:tooltip tooltip string?] + [#:menu items (listof menu-item?)]) + tray?]{ +Creates a system tray icon with the given tooltip and menu. Returns a tray +handle. Never raises for environmental reasons — callers always get a usable +(possibly inert) handle. +} + +@defproc[(tray-set-tooltip! [t tray?] [tooltip string?]) void?]{} +@defproc[(tray-set-icon! [t tray?] [icon path?]) void?]{} +@defproc[(tray-set-menu! [t tray?] [items (listof menu-item?)]) void?]{} +@defproc[(tray-close [t tray?]) void?]{} + +@defproc[(make-menu-item + [label string?] + [#:id id any/c label] + [#:action action (-> any) void] + [#:enabled? enabled? boolean? #t] + [#:checked? checked? boolean? #f]) + menu-item?]{} +@defproc[(menu-separator) menu-item?]{} + +@section{Native WebView} + +@defmodule[glaze/webview/main] + +Opens a native OS window with an embedded WebView pointing at a URL +(typically the local HTTP server Glaze started). Backends: macOS +(@racket[NSWindow] + @racket[WKWebView] via objc FFI), Windows (WebView2 +via COM FFI), Linux (@racket[GtkWindow] + WebKitGTK via FFI) — all three +pass the real-window CI e2e (open, load, capture, navigate, close, +on-close). Native GUI is the application contract: when the backend is +unavailable, @racket[open-window] raises with platform-specific installation +or repair guidance and may also show that diagnosis in an OS-level dialog. + +@defproc[(open-window + [url string?] + [#:title title string? "Glaze"] + [#:width width exact-positive-integer? 1024] + [#:height height exact-positive-integer? 768] + [#:devtools? devtools? boolean? #f] + [#:background-active? background-active? boolean? #f] + [#:on-close on-close (-> any) (lambda () (void))]) + webview?]{ +Opens the window and loads @racket[url]. @racket[on-close] runs when the +window closes (programmatic @racket[webview-close] or the user closing it). +@racket[#:devtools?] opens the platform inspector (macOS: inspectable, +13+; Windows: @litchar{OpenDevToolsWindow}; Linux: WebKitGTK inspector). +On macOS 14+, WebKit inactive-view suspension is disabled for Glaze windows. +For monitoring applications that must keep timers active while backgrounded, +@racket[#:background-active? #t] additionally uses the public +@racket[NSProcessInfo] activity API to suppress App Nap while the window is +alive; it is opt-in because it can increase power use. Other backends accept +the option as a portable no-op. Backend startup failure raises an actionable +error instead of returning @racket[#f]. +@racket[open-webview] is a synonym. +} + +@defproc[(webview-supported?) boolean?]{ +Whether the current platform backend is available. +} + +@defproc[(webview-last-error) any/c]{ +Returns the most recent backend startup error, or @racket[#f] when none has +been recorded. +} + +@defproc[(webview-install-guidance) string?]{ +Returns platform-specific native WebView installation and repair guidance. +} + +@defproc[(webview-diagnostic [error any/c (webview-last-error)]) string?]{ +Combines the backend error with the platform guidance used for fail-fast +startup reporting. +} + +@defproc[(webview-navigate [wv webview?] [url string?]) void?]{ +Loads a new URL into an open webview. +} + +@defproc[(webview-close [wv webview?]) void?]{ +Closes the window and stops its event pump. +} + +@defproc[(webview-title [wv webview?]) (or/c #f string?)]{ +Current page title once the first navigation has committed; @racket[#f] +before that or when the backend cannot provide it. +} + +@defproc[(webview-url [wv webview?]) (or/c #f string?)]{ +Current page URL once the first navigation has committed. +} + +@defproc[(webview-capture! + [wv webview?] + [dest (or/c #f string? path?) #f]) + (or/c #f path?)]{ +Captures the window contents as a PNG to @racket[dest] (a fresh temp file by +default). Returns the path, or @racket[#f] when the window is closed or not +currently capturable. Together with @racket[webview-title] and +@racket[webview-url], this lets automated callers — including AI agents — +verify what the UI is showing without a human at the screen. +} + +@defproc[(webview-set-title! [wv webview?] [title string?]) void?]{} +@defproc[(webview-set-size! [wv webview?] + [width exact-positive-integer?] + [height exact-positive-integer?]) void?]{} +@defproc[(webview-set-fullscreen! [wv webview?] [on? boolean?]) void?]{} +@defproc[(webview-focus! [wv webview?]) void?]{} + +@section[#:tag "security"]{Security} + +The server binds to @racket[127.0.0.1] only, and every request passes a +Host-header check: the server must be addressed as @litchar{127.0.0.1} / +@litchar{localhost} / @litchar{[::1]} (with or without port). This closes +the DNS-rebinding hole where a malicious page resolves its own domain to +loopback to reach the app's API; hostile origins get 403. + +The API token (@racket[#:api-token]) guards @emph{capabilities} — +API routes and the SSE stream (401 otherwise) — not resources: static files +and the api.js bootstrap stay open. @racket[run-app] opens the window at a +one-time capability URL, @litchar{/?glaze-token=...}: the server exchanges +the token for an @litchar{HttpOnly} @litchar{glaze_token} cookie and +redirects to the clean path (EventSource cannot set headers, but +same-origin requests carry cookies). @racket[run-app] enables a random token +by default; pass @racket[#f] explicitly to opt out. The lower-level +@racket[start-server] keeps its historical @racket[#f] default for development +and custom server composition. api.js deliberately hands out nothing, so a +caller that can only read openly-served endpoints cannot mint credentials. +Programmatic clients send @litchar{X-Glaze-Token}. + +@bold{Honest scope:} this raises the bar against casual local callers; a +process running as the same user can still read the token from process +memory — full local-process isolation is not achievable over plain HTTP. @section{Packaging} @@ -387,37 +649,36 @@ bundle at build time. [#:entry entry (or/c string? path?) "main.rkt"] [#:name name (or/c #f string?) #f] [#:version version (or/c #f string?) #f] - [#:icon icon any/c #f] + [#:icon icon (or/c #f path?) #f] [#:out-dir out-dir (or/c string? path?) "dist"] [#:embed-dlls? embed-dlls? boolean? #f] [#:installer? installer? boolean? #f] [#:sign sign (or/c #f string?) #f] - [#:entitlements entitlements any/c #f] + [#:entitlements entitlements (or/c #f path?) #f] [#:no-hardened-runtime? no-hardened-runtime? boolean? #f] [#:timestamp-url timestamp-url (or/c #f string?) #f] - [#:notarize-profile notarize-profile (or/c #f string?) #f] - [#:url-schemes url-schemes list? '()]) + [#:notarize-profile notarize-profile (or/c #f string?) #f]) path?]{ -Builds and distributes the application with @exec{raco exe} and -@exec{raco distribute}. Windows GUI builds use @exec{raco exe --gui}, so they -may not have a visible console; this is why native WebView startup failures -also attempt an OS-level error dialog. - -Installer-toolchain absence may degrade an installer request to an archive -with a loud warning. That packaging fallback is unrelated to runtime startup: -the built application still requires its native WebView. +Builds a Glaze project into a distributable via @racket[raco exe] + +@racket[raco distribute], bundling the project's @racket[public/] with the +executable. On macOS assembles a canonical @tt{.app} bundle (with +@racket[version] stamped into @tt{Info.plist}) and, when +@racket[installer?] is true, produces a dmg (msi on Windows, AppImage on +Linux), falling back to a zip / tar.gz when the native toolchain is +absent. @racket[sign] is a codesign identity on macOS (@litchar{"-"} = +ad-hoc) or a signtool certificate SHA-1 thumbprint / subject on Windows; +@racket[notarize-profile] adds notarization + stapling. See +@secref["signing"]. Signing failures abort the build; a missing toolchain +degrades with a warning. } @section{CLI Commands} @verbatim{ - raco glaze init Create a native desktop project - raco glaze dev Run the project's native main.rkt - raco glaze build Build a distributable / installer + raco glaze init Create a new project + raco glaze dev Start dev server + raco glaze build Build a distributable (+ optional + installer, signing, notarization) raco glaze keygen [--out

] Create an RSA keypair for licenses raco glaze license sign|verify Sign or verify license files - raco glaze help Show help } - -There is intentionally no browser-mode @exec{dev} or @exec{serve} command. -Development and production use the same native WebView startup path. diff --git a/glaze-test/api-contract-test.rkt b/glaze-test/api-contract-test.rkt new file mode 100644 index 0000000..30ab9d6 --- /dev/null +++ b/glaze-test/api-contract-test.rkt @@ -0,0 +1,30 @@ +#lang racket/base + +(require rackunit + glaze/api) + +;; Leading/trailing slashes are normalized. +(define normalized + (GET "/api/items/:id/" (lambda (req id) id))) +(check-equal? (route-match normalized 'GET '("api" "items" "42")) '("42")) + +;; Invalid route declarations fail during application setup rather than on the +;; first request. +(check-exn exn:fail? + (lambda () (GET "" (lambda (req) #f)))) +(check-exn exn:fail? + (lambda () (GET "api/:" (lambda (req x) x)))) +(check-exn exn:fail? + (lambda () (GET "api/../secret" (lambda (req) #f)))) +(check-exn exn:fail? + (lambda () (GET "api/:id" (lambda (req) #f)))) + +;; Public response helpers have deterministic contracts. +(check-exn exn:fail:contract? + (lambda () (api-response (lambda () #t)))) +(check-exn exn:fail:contract? + (lambda () (error-response 99 "bad"))) +(check-exn exn:fail:contract? + (lambda () (error-response 500 'bad))) +(check-exn exn:fail:contract? + (lambda () (route-match 'not-a-route 'GET '("api")))) diff --git a/glaze-test/api-test.rkt b/glaze-test/api-test.rkt index 7804c8f..9bfd39d 100644 --- a/glaze-test/api-test.rkt +++ b/glaze-test/api-test.rkt @@ -36,7 +36,11 @@ (define body (request-json-body req)) (hasheq 'echo (and (hash? body) (hash-ref body 'x 'miss))))) (GET "api/boom" (lambda (req) (raise-user-error 'boom "handler exploded"))) - (GET "api/raw" (lambda (req) (json-response (hasheq 'raw #t))))))) + (GET "api/raw" (lambda (req) (json-response (hasheq 'raw #t)))) + ;; Non-JavaScript identifier characters in route params/static + ;; segments must still produce a valid generated client. + (GET "api/users/:user-id" (lambda (req user-id) (hasheq 'id user-id))) + (GET "api/o'hare/:id" (lambda (req id) (hasheq 'id id)))))) (define (call method path [data #f]) (define-values (status headers in) @@ -75,6 +79,18 @@ (check-true (string-contains? st "200") "raw response passthrough") (check-equal? (hash-ref (bytes->jsexpr body) 'raw) #t)) +;; Generated client must not embed route parameter names as raw JavaScript +;; identifiers or static path text as raw single-quoted source. +(let-values ([(st body) (call "GET" "/glaze/api.js")]) + (define js (bytes->string/utf-8 body)) + (check-true (string-contains? st "200") "generated api client served") + (check-true (string-contains? js "\"usersUserId\": function(p0, body)") + "hyphenated path param uses safe positional JS argument") + (check-false (string-contains? js "function(user-id") + "raw route parameter is never emitted as JS identifier") + (check-true (string-contains? js "\"o'hare\"") + "static route segment is emitted as an escaped JS string literal")) + ;; Method mismatch (GET on a POST route) falls through to static SPA fallback. (let-values ([(st body) (call "GET" "/api/bump/5")]) (check-true (string-contains? st "200") "method mismatch -> static fallback") diff --git a/glaze-test/appapi-test.rkt b/glaze-test/appapi-test.rkt index cce4cf8..ed05ac7 100644 --- a/glaze-test/appapi-test.rkt +++ b/glaze-test/appapi-test.rkt @@ -19,6 +19,11 @@ glaze/tray/tray-protocol glaze/webview/main) +;; Racket 8.12's putenv contract accepts strings only. Restoring an absent +;; variable to "" keeps cleanup portable across the supported Racket range. +(define (restore-env! name old-value) + (putenv name (or old-value ""))) + ;; ---- menu protocol (shared with the tray) ---- (define mi (make-menu-item "Open…" #:action (lambda () 'opened) @@ -54,6 +59,33 @@ (check-equal? (ensure-url-scheme! "glaze-test-scheme") 'build-time "macOS defers registration to the packaged Info.plist")) +(when (eq? (system-type 'os) 'unix) + (define tmp-data (make-temporary-file "glaze-deeplink-~a" 'directory)) + (define old-data (getenv "XDG_DATA_HOME")) + (define old-path (getenv "PATH")) + (dynamic-wind + (lambda () + (putenv "XDG_DATA_HOME" (path->string tmp-data)) + ;; Keep the test a pure file-write exercise; do not let xdg-mime modify + ;; the runner's desktop defaults. + (putenv "PATH" "")) + (lambda () + (check-equal? + (ensure-url-scheme! "glaze-test-scheme" #:app-name "Glaze\nInjected=bad") + 'desktop + "Linux deep-link registration follows the documented symbol contract") + (define desktop + (build-path tmp-data "applications" "glaze-glaze-test-scheme.desktop")) + (define text (file->string desktop)) + (check-true (string-contains? text "Name=Glaze\\nInjected=bad") + "desktop entry escapes newlines in app name") + (check-false (string-contains? text (string-append "Name=Glaze" "\n" "Injected=bad")) + "desktop entry contains no injected key")) + (lambda () + (restore-env! "XDG_DATA_HOME" old-data) + (restore-env! "PATH" old-path) + (delete-directory/files tmp-data)))) + ;; ---- auto-launch state queries ---- (define state (auto-launch-enabled? "glaze-api-test")) @@ -64,21 +96,31 @@ ;; overridden XDG_CONFIG_HOME so the test never touches real user state. (when (eq? (system-type 'os) 'unix) (define tmp-cfg (make-temporary-file "glaze-autostart-~a" 'directory)) - (putenv "XDG_CONFIG_HOME" (path->string tmp-cfg)) - (check-false (auto-launch-enabled? "glaze-api-test") "linux: not registered initially") - (auto-launch-set! "glaze-api-test" #t) - (check-true (auto-launch-enabled? "glaze-api-test") "linux: registered") - (check-true (string-contains? (file->string (build-path tmp-cfg "autostart" "glaze-api-test.desktop")) - "X-GNOME-Autostart-enabled=true") - "linux: desktop entry written") - (auto-launch-set! "glaze-api-test" #f) - (check-false (auto-launch-enabled? "glaze-api-test") "linux: unregistered") - (delete-directory/files tmp-cfg)) + (define old-config (getenv "XDG_CONFIG_HOME")) + (dynamic-wind + (lambda () + (putenv "XDG_CONFIG_HOME" (path->string tmp-cfg))) + (lambda () + (check-false (auto-launch-enabled? "glaze-api-test") "linux: not registered initially") + (auto-launch-set! "glaze-api-test" #t) + (check-true (auto-launch-enabled? "glaze-api-test") "linux: registered") + (check-true (string-contains? (file->string (build-path tmp-cfg "autostart" "glaze-api-test.desktop")) + "X-GNOME-Autostart-enabled=true") + "linux: desktop entry written") + (auto-launch-set! "glaze-api-test" #f) + (check-false (auto-launch-enabled? "glaze-api-test") "linux: unregistered")) + (lambda () + (restore-env! "XDG_CONFIG_HOME" old-config) + (delete-directory/files tmp-cfg)))) ;; ---- macOS real-window menu e2e ---- ;; open -> set custom menu -> poll page load -> perform the native menu ;; action (the same dispatch a real click takes) -> marker file appears -> ;; close -> wait-for-webviews. +;; +;; This test deliberately uses AppKit/Objective-C calls to synthesize the +;; native menu click, so it must never run merely because another platform's +;; WebView backend is available. (when (and (eq? (system-type 'os) 'macosx) (webview-supported?)) diff --git a/glaze-test/cli-contract-test.rkt b/glaze-test/cli-contract-test.rkt new file mode 100644 index 0000000..0922fb5 --- /dev/null +++ b/glaze-test/cli-contract-test.rkt @@ -0,0 +1,55 @@ +#lang racket/base + +(require rackunit + racket/file + racket/path + racket/port + racket/string + racket/system) + +(define raco + (or (find-executable-path + (if (eq? (system-type 'os) 'windows) "raco.exe" "raco") + #f) + (error 'cli-test "raco not found"))) + +(define (run-glaze . args) + ;; Keep expected CLI error diagnostics out of the test runner's output while + ;; still checking the real registered raco command in a subprocess. + (define out (open-output-string)) + (define err (open-output-string)) + (define code + (parameterize ([current-output-port out] + [current-error-port err]) + (apply system*/exit-code raco "glaze" args))) + (values code (get-output-string out) (get-output-string err))) + +(let-values ([(code _out _err) (run-glaze "build" "--name")]) + (check-not-equal? code 0 "missing build option value fails")) + +(let-values ([(code _out _err) (run-glaze "build" "--definitely-unknown")]) + (check-not-equal? code 0 "unknown build option fails")) + +(let-values ([(code _out _err) (run-glaze "keygen" "--unknown")]) + (check-not-equal? code 0 "unknown keygen option fails")) + +(let-values ([(code _out _err) + (run-glaze "license" "verify" "--pub" "x.pem" + "--product" "X" "--unknown")]) + (check-not-equal? code 0 "unknown license option fails")) + +(let-values ([(code _out _err) (run-glaze "init" "one" "two")]) + (check-not-equal? code 0 "init rejects extra project paths")) + +;; Scaffold a real project and make sure the generated entry follows the +;; recommended run-app/module+ main path rather than the historical browser +;; server template. +(define tmp (make-temporary-file "glaze-cli-~a" 'directory)) +(define project (build-path tmp "sample")) +(let-values ([(code _out err) (run-glaze "init" (path->string project))]) + (check-equal? code 0 (format "init succeeds: ~a" err))) +(define main-text (file->string (build-path project "main.rkt"))) +(check-true (string-contains? main-text "(module+ main")) +(check-true (string-contains? main-text "(run-app")) +(check-false (string-contains? main-text "start-dev-server")) +(delete-directory/files tmp) diff --git a/glaze-test/dialog-contract-test.rkt b/glaze-test/dialog-contract-test.rkt new file mode 100644 index 0000000..91f08c3 --- /dev/null +++ b/glaze-test/dialog-contract-test.rkt @@ -0,0 +1,29 @@ +#lang racket/base + +(require rackunit + glaze/dialogs) + +;; OPENFILENAMEW multi-select buffers are directory\0name1\0name2\0\0 in +;; UTF-16. Keep this pure so it runs on every CI host. +(define multi + (bytes-append (wstr "C:\\work") + (wstr "one.txt") + (wstr "two.txt") + (bytes 0 0))) +(check-equal? (wstr-parts multi) + (list "C:\\work" "one.txt" "two.txt") + "UTF-16 multi-string preserves every selected filename") + +;; A code unit whose low byte is NUL must not be mistaken for a terminator. +(check-equal? (wstr-parts (wstr "a\u0100b")) + (list "a\u0100b")) + +;; Public argument contracts run before backend availability checks. +(check-exn exn:fail:contract? + (lambda () (pick-file #:title 42))) +(check-exn exn:fail:contract? + (lambda () (pick-file #:directory 42))) +(check-exn exn:fail:contract? + (lambda () (pick-file #:filters (list (list "Text" 42))))) +(check-exn exn:fail:contract? + (lambda () (save-file-dialog #:default-name 42))) diff --git a/glaze-test/events-test.rkt b/glaze-test/events-test.rkt index cb47732..0e4795e 100644 --- a/glaze-test/events-test.rkt +++ b/glaze-test/events-test.rkt @@ -85,11 +85,12 @@ (let-values ([(_st b) (call "GET" "/glaze/api.js")]) (define js (bytes->string/utf-8 b)) (check-true (string-contains? js "glaze.call") "client has call wrapper") - (check-true (string-contains? js "counterBump: function(body)") "route -> counterBump()") - (check-true (string-contains? js "itemsId:") "path param -> itemsId()") + (check-true (string-contains? js "\"counterBump\": function(body)") + "route -> counterBump()") + (check-true (string-contains? js "\"itemsId\": function(p0, body)") + "path param -> itemsId() with safe positional argument") (check-true (string-contains? js "EventSource('/glaze/events')") "SSE endpoint")) -;; ---- SSE over HTTP ---- ;; ---- SSE over HTTP (curl as a real streaming client) ---- (define out-path (make-temporary-file "sse-out-~a.txt")) (define curl-exe (or (find-executable-path "curl.exe" #f) @@ -113,3 +114,16 @@ (check-true (string-contains? sse-text "\"msg\":\"world\"") "SSE payload delivered") (delete-directory/files dir) + +;; ---- event input hardening ---- +(let () + (define bus (make-event-bus)) + (check-exn exn:fail:contract? + (lambda () (bus-broadcast! bus "bad\nevent" (hasheq 'ok #t))) + "SSE event names cannot inject new protocol lines") + (check-exn exn:fail:contract? + (lambda () (bus-broadcast! bus 'not-json (lambda () #t))) + "event payload must be JSON-serializable") + (check-exn exn:fail:contract? + (lambda () (bus-wait (bus-subscribe! bus) -1)) + "event wait timeout must be nonnegative")) diff --git a/glaze-test/hardening-test.rkt b/glaze-test/hardening-test.rkt index 46e1350..5098d47 100644 --- a/glaze-test/hardening-test.rkt +++ b/glaze-test/hardening-test.rkt @@ -20,6 +20,7 @@ ;; ---- token ---- (define token (make-api-token)) +(define bootstrap (make-api-token)) (check-true (regexp-match? #px"^[0-9a-f]{32}$" token) "token is 32 hex chars") (check-false (string=? (make-api-token) token) "tokens are random") @@ -27,7 +28,8 @@ (start-server #:port 18995 #:public-dir "/tmp" #:api (list (GET "api/ping" (lambda (req) (hasheq 'pong #t)))) - #:api-token token)) + #:api-token token + #:bootstrap-token bootstrap)) (define (call path #:headers [headers '()] #:port [p 18995]) (define-values (st h in) @@ -57,15 +59,20 @@ (check-false (string-contains? (bytes->string/utf-8 b4) token) "api.js body does not contain the token")) -;; one-time bootstrap: ?glaze-token= exchanges the token for an HttpOnly -;; cookie and redirects to the clean path -(let*-values ([(_s5 h5 _b5) (call (format "/?glaze-token=~a" token))]) +;; one-time bootstrap: a short-lived nonce distinct from the API token is +;; exchanged for an HttpOnly API-token cookie and then consumed. +(let*-values ([(_s5 h5 _b5) (call (format "/?glaze-token=~a" bootstrap))]) (check-true (string-contains? _s5 "302") "bootstrap redirects") (check-true (for/or ([hh (in-list h5)]) (string-contains? (string-downcase (bytes->string/latin-1 hh)) (format "glaze_token=~a" token))) - "bootstrap sets glaze_token cookie") + "bootstrap sets API token cookie, not bootstrap nonce") + (check-false + (for/or ([hh (in-list h5)]) + (string-contains? (bytes->string/latin-1 hh) + (format "glaze_token=~a" bootstrap))) + "bootstrap nonce is never stored as the capability cookie") (check-true (for/or ([hh (in-list h5)]) (define s (string-downcase (bytes->string/latin-1 hh))) @@ -77,6 +84,27 @@ #:headers (list (format "Cookie: glaze_token=~a" token)))]) (check-true (string-contains? _s6 "200") "cookie token -> 200"))) +;; Bootstrap nonce is consumed: replaying it cannot mint another cookie. +(let*-values ([(_sr hr _br) (call (format "/?glaze-token=~a" bootstrap))]) + (check-false + (for/or ([hh (in-list hr)]) + (string-prefix? (string-downcase (bytes->string/latin-1 hh)) "set-cookie:")) + "bootstrap nonce cannot be replayed")) + +;; Browser-origin capability requests are pinned to this exact local port. +(let*-values ([(_so _ho _bo) + (call "/api/ping" + #:headers + (list (format "X-Glaze-Token: ~a" token) + "Origin: http://127.0.0.1:19999"))]) + (check-true (string-contains? _so "403") "foreign localhost origin -> 403")) +(let*-values ([(_ss _hs _bs) + (call "/api/ping" + #:headers + (list (format "X-Glaze-Token: ~a" token) + "Origin: http://127.0.0.1:18995"))]) + (check-true (string-contains? _ss "200") "same-origin API request -> 200")) + ;; wrong token in the query never mints anything (let*-values ([(_s7 h7 _b7) (call "/?glaze-token=wrong")]) (check-false @@ -96,11 +124,27 @@ #:api (list (GET "api/boom" (lambda (req) (raise-user-error 'kaboom "x"))))))) (let*-values ([(_s6 _h6 _b6) (call "/api/boom" #:port 18996)]) - (check-true (string-contains? _s6 "500") "boom still answers 500")) + (check-true (string-contains? _s6 "500") "boom still answers 500") + (check-false (string-contains? (bytes->string/utf-8 _b6) "kaboom") + "500 response does not leak handler exception text") + (check-true (string-contains? (bytes->string/utf-8 _b6) "internal server error") + "500 response uses generic client message")) (check-equal? (second reported) "api/boom" "reporter sees the URI") (check-true (string-contains? (first reported) "kaboom") "reporter sees the exn") (stop2)) +;; An events-only server must still enforce the capability token even when it +;; has zero API routes (regression for a previous `(pair? api-routes)` guard). +(define sse-bus (make-event-bus)) +(define-values (_sse-port stop-sse) + (start-server #:port 18998 + #:public-dir "/tmp" + #:events sse-bus + #:api-token token)) +(let*-values ([(_se _he _be) (call "/glaze/events" #:port 18998)]) + (check-true (string-contains? _se "401") "SSE-only server requires token")) +(stop-sse) + (shutdown) ;; ---- update checking ---- @@ -109,6 +153,22 @@ (check-true (newer-version? "2.0" "1.9.9") "shorter version pads with zeros") (check-false (newer-version? "1.2" "1.2.1") "older is not newer") +;; SHA verification accepts both path and string path inputs and rejects an +;; invalid digest shape before invoking openssl. +(define hash-file (make-temporary-file "glaze-sha-test-~a")) +(call-with-output-file hash-file + (lambda (o) (display "abc" o)) + #:exists 'replace) +(when (find-executable-path "openssl" #f) + (check-true + (verify-file-sha256 + (path->string hash-file) + "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad") + "sha256 verifier accepts string paths")) +(check-false (verify-file-sha256 hash-file "not-a-digest") + "sha256 verifier rejects malformed digest") +(delete-file hash-file) + (define dir (make-temporary-file "upd-~a" 'directory)) (call-with-output-file (build-path dir "manifest.json") (lambda (o) diff --git a/glaze-test/license-test.rkt b/glaze-test/license-test.rkt index 10c724b..9e17467 100644 --- a/glaze-test/license-test.rkt +++ b/glaze-test/license-test.rkt @@ -27,6 +27,7 @@ (check-true (> (days-until-expiry "2099-01-01") 0) "future expiry is positive") (check-true (< (days-until-expiry "2000-01-01") 0) "past expiry is negative") (check-exn exn:fail? (lambda () (days-until-expiry "not-a-date")) "malformed date raises") +(check-exn exn:fail? (lambda () (days-until-expiry "2026-02-31")) "impossible date raises") ;; ---- openssl presence gate ---- @@ -60,6 +61,20 @@ #:machine-id mid #:out license-path)) "issuing a license runs") + ;; JSON control characters in customer-facing claims must be escaped by the + ;; canonical signer and round-trip without corrupting the license JSON. + (define control-path (build-path dir "control.license")) + (define control-subject (string-append "Acme" (string (integer->char 1)) " Corp")) + (issue-license #:private-key priv + #:product "TestApp" + #:subject control-subject + #:out control-path) + (define control-ok + (validate-license control-path #:public-key pub #:product "TestApp")) + (check-true (hash-ref control-ok 'valid) "control-char claim license validates") + (check-equal? (hash-ref control-ok 'subject) control-subject + "control-char claim round-trips") + (define ok (validate-license license-path #:public-key pub #:product "TestApp")) (check-true (hash-ref ok 'valid) "license validates") (check-equal? (hash-ref ok 'subject) "customer@example.com" "subject round-trips") diff --git a/glaze-test/lifecycle-test.rkt b/glaze-test/lifecycle-test.rkt new file mode 100644 index 0000000..eb04802 --- /dev/null +++ b/glaze-test/lifecycle-test.rkt @@ -0,0 +1,60 @@ +#lang racket/base + +(require rackunit + glaze/app + (submod glaze/app test-support)) + +;; shutdown is part of run-app's returned lifecycle contract: callers are free +;; to call it even after run-app already stopped the server on window close. +(define calls 0) +(define shutdown + (make-idempotent-shutdown + (lambda () + (set! calls (add1 calls))))) + +(shutdown) +(shutdown) +(shutdown) +(check-equal? calls 1 "underlying shutdown runs at most once") + +;; Concurrent callers must also collapse to one underlying shutdown. +(define concurrent-calls 0) +(define concurrent-shutdown + (make-idempotent-shutdown + (lambda () + (sleep 0.02) + (set! concurrent-calls (add1 concurrent-calls))))) +(define workers + (for/list ([i (in-range 8)]) + (thread concurrent-shutdown))) +(for-each thread-wait workers) +(check-equal? concurrent-calls 1 "concurrent shutdown calls are serialized and idempotent") + +;; A failed underlying shutdown is not recorded as complete, so a caller may +;; retry rather than being left with a permanently half-stopped runtime. +(define attempts 0) +(define retryable-shutdown + (make-idempotent-shutdown + (lambda () + (set! attempts (add1 attempts)) + (when (= attempts 1) + (error 'test "first shutdown attempt fails"))))) +(check-exn exn:fail? retryable-shutdown) +(check-not-exn retryable-shutdown) +(retryable-shutdown) +(check-equal? attempts 2 "successful retry becomes the final shutdown") + + +;; Public lifecycle arguments fail before any server/window side effects. +(check-exn exn:fail:contract? + (lambda () (run-app #:port 0)) + "port zero is rejected") +(check-exn exn:fail:contract? + (lambda () (run-app #:width 0)) + "non-positive window width is rejected") +(check-exn exn:fail:contract? + (lambda () (run-app #:api-token 'not-a-token)) + "invalid api-token mode is rejected") +(check-exn exn:fail:contract? + (lambda () (run-app #:on-ready 42)) + "on-ready must be a procedure") diff --git a/glaze-test/menu-contract-test.rkt b/glaze-test/menu-contract-test.rkt new file mode 100644 index 0000000..d7eeb1a --- /dev/null +++ b/glaze-test/menu-contract-test.rkt @@ -0,0 +1,25 @@ +#lang racket/base + +(require rackunit + glaze/tray/tray-protocol) + +(check-exn exn:fail:contract? + (lambda () (make-menu-item 42))) +(check-exn exn:fail:contract? + (lambda () (make-menu-item "Open" #:id 'open))) +(check-exn exn:fail:contract? + (lambda () (make-menu-item "Open" #:action (lambda (x) x)))) +(check-exn exn:fail:contract? + (lambda () (make-menu-item "Open" #:enabled? 'yes))) +(check-exn exn:fail:contract? + (lambda () (make-menu-item "Open" #:accel 42))) +(check-exn exn:fail:contract? + (lambda () (make-menu 42 '()))) +(check-exn exn:fail:contract? + (lambda () (make-menu "File" '(not-an-item)))) + +(define alloc (make-id-allocator)) +(check-exn exn:fail:contract? + (lambda () (id-allocator-register! alloc (lambda (x) x)))) +(check-exn exn:fail:contract? + (lambda () (id-allocator-lookup alloc 0))) diff --git a/glaze-test/public-api-test.rkt b/glaze-test/public-api-test.rkt new file mode 100644 index 0000000..77b4348 --- /dev/null +++ b/glaze-test/public-api-test.rkt @@ -0,0 +1,29 @@ +#lang racket/base + +(require rackunit + glaze) + +;; The application-facing contract is that normal Glaze apps can start from a +;; single `(require glaze)`. Keep this test intentionally shallow: subsystem +;; behavior belongs in focused tests; this file protects the facade itself. + +(check-true (procedure? run-app) "glaze exports run-app") +(check-true (procedure? start-server) "glaze exports start-server") +(check-true (procedure? open-window) "glaze exports open-window") +(check-true (procedure? make-tray) "glaze exports make-tray") +(check-true (procedure? make-event-bus) "glaze exports make-event-bus") +(check-true (procedure? bus-broadcast!) "glaze exports bus-broadcast!") +(check-true (procedure? clipboard-set!) "glaze exports system capabilities") +(check-true (procedure? build-app) "glaze exports packaging helpers") + +;; Platform-independent smoke behavior through the facade. +(define bus (make-event-bus)) +(define subscriber (bus-subscribe! bus)) +(bus-broadcast! bus 'facade-smoke (hasheq 'ok #t)) +(check-equal? (bus-wait subscriber 1) + (list 'facade-smoke (hasheq 'ok #t))) +(bus-unsubscribe! bus subscriber) + +;; Public argument validation should remain visible through the facade. +(check-exn exn:fail:contract? + (lambda () (bus-broadcast! bus 42 (hasheq)))) diff --git a/glaze-test/security-test.rkt b/glaze-test/security-test.rkt new file mode 100644 index 0000000..6dae974 --- /dev/null +++ b/glaze-test/security-test.rkt @@ -0,0 +1,41 @@ +#lang racket/base + +(require rackunit + racket/file + (submod glaze/server test-support)) + +;; DNS-rebinding guard: loopback hosts are accepted with ordinary port forms, +;; including bracketed IPv6. Other hosts must stay rejected. +(for ([host (in-list '("127.0.0.1" + "127.0.0.1:8080" + "localhost" + "LOCALHOST:8080" + "[::1]" + "[::1]:8080" + "::1"))]) + (check-true (host-string-allowed? host) (format "loopback Host accepted: ~a" host))) + +(for ([host (in-list '("example.com" + "localhost.example.com" + "127.0.0.2" + "[::2]" + "[::1].example.com"))]) + (check-false (host-string-allowed? host) (format "non-loopback Host rejected: ~a" host))) + +;; Static serving must never resolve a request outside public-dir. +(define parent (make-temporary-file "glaze-static-security-~a" 'directory)) +(define public (build-path parent "public")) +(make-directory public) +(define inside (build-path public "index.html")) +(define outside (build-path parent "secret.txt")) +(call-with-output-file inside (lambda (out) (display "public" out)) #:exists 'replace) +(call-with-output-file outside (lambda (out) (display "secret" out)) #:exists 'replace) + +(check-not-false (safe-public-candidate public '("index.html")) + "normal public file resolves") +(check-false (safe-public-candidate public '(".." "secret.txt")) + "parent traversal is rejected") +(check-false (safe-public-candidate public '("sub" ".." ".." "secret.txt")) + "normalized traversal is rejected") + +(delete-directory/files parent) diff --git a/glaze-test/streaming-static-test.rkt b/glaze-test/streaming-static-test.rkt new file mode 100644 index 0000000..2507ccc --- /dev/null +++ b/glaze-test/streaming-static-test.rkt @@ -0,0 +1,46 @@ +#lang racket/base + +(require rackunit + racket/file + racket/port + racket/string + net/http-client + glaze/server) + +;; Serve a multi-megabyte binary asset through the real HTTP stack. The test +;; locks down status, content type, and byte-for-byte behavior so the server can +;; stream static files without changing the public response contract. +(define public-dir (make-temporary-file "glaze-static-stream-~a" 'directory)) +(define payload-path (build-path public-dir "payload.wasm")) +(define payload + (bytes-append + (make-bytes (* 2 1024 1024) #xA5) + (make-bytes (* 2 1024 1024) #x5A))) + +(call-with-output-file payload-path + (lambda (out) (write-bytes payload out)) + #:exists 'replace + #:mode 'binary) + +(define shutdown #f) +(dynamic-wind + (lambda () + (define-values (_port stop) + (start-server #:port 18997 #:public-dir public-dir)) + (set! shutdown stop)) + (lambda () + (define-values (status headers in) + (http-sendrecv "127.0.0.1" "/payload.wasm" #:port 18997 #:ssl? #f)) + (define actual (port->bytes in)) + (close-input-port in) + (check-true (string-contains? (bytes->string/latin-1 status) "200")) + (check-true + (for/or ([h (in-list headers)]) + (string-contains? (string-downcase (bytes->string/latin-1 h)) + "content-type: application/wasm"))) + (check-equal? (bytes-length actual) (bytes-length payload)) + (check-equal? actual payload)) + (lambda () + (when shutdown (shutdown)) + (when (directory-exists? public-dir) + (delete-directory/files public-dir)))) diff --git a/glaze-test/sys-contract-test.rkt b/glaze-test/sys-contract-test.rkt new file mode 100644 index 0000000..839fa8f --- /dev/null +++ b/glaze-test/sys-contract-test.rkt @@ -0,0 +1,19 @@ +#lang racket/base + +(require rackunit + glaze/sys/main) + +(check-exn exn:fail:contract? + (lambda () (clipboard-set! 42))) +(check-exn exn:fail:contract? + (lambda () (notify! 42))) +(check-exn exn:fail:contract? + (lambda () (notify! "title" 42))) +(check-exn exn:fail:contract? + (lambda () (notify! "title" "body" #:subtitle 42))) +(check-exn exn:fail:contract? + (lambda () (open-path 42))) +(check-exn exn:fail:contract? + (lambda () (reveal-path 42))) +(check-exn exn:fail:contract? + (lambda () (single-instance? ""))) diff --git a/glaze-test/tray-contract-test.rkt b/glaze-test/tray-contract-test.rkt new file mode 100644 index 0000000..e9de8e3 --- /dev/null +++ b/glaze-test/tray-contract-test.rkt @@ -0,0 +1,18 @@ +#lang racket/base + +(require rackunit + glaze/tray/main) + +(check-exn exn:fail:contract? + (lambda () (make-tray #:icon 42 #:tooltip "x" #:menu '()))) +(check-exn exn:fail:contract? + (lambda () (make-tray #:icon #f #:tooltip 42 #:menu '()))) +(check-exn exn:fail:contract? + (lambda () (make-tray #:icon #f #:tooltip "x" #:menu '(bad)))) +(check-exn exn:fail:contract? + (lambda () (make-tray #:icon #f #:tooltip "x" #:menu '() + #:on-event (lambda () #t)))) +(check-exn exn:fail:contract? + (lambda () (tray-close 'not-a-tray))) +(check-exn exn:fail:contract? + (lambda () (tray-set-tooltip! 'not-a-tray "x"))) diff --git a/glaze-test/update-contract-test.rkt b/glaze-test/update-contract-test.rkt new file mode 100644 index 0000000..414b8ab --- /dev/null +++ b/glaze-test/update-contract-test.rkt @@ -0,0 +1,52 @@ +#lang racket/base + +(require rackunit + racket/file + glaze/server + glaze/update) + +(check-exn exn:fail:contract? + (lambda () (newer-version? "1.beta" "1.0"))) +(check-exn exn:fail:contract? + (lambda () (newer-version? "1.0" "current"))) +(check-exn exn:fail:contract? + (lambda () (check-update 42 #:current-version "1.0"))) +(check-exn exn:fail:contract? + (lambda () (check-update "http://127.0.0.1/manifest.json" + #:current-version "1.beta"))) + +(define dir (make-temporary-file "glaze-update-contract-~a" 'directory)) +(define (write-manifest name content) + (call-with-output-file (build-path dir name) + (lambda (out) (display content out)) + #:exists 'replace)) + +(write-manifest "bad-version.json" + "{\"version\":\"2.beta\",\"url\":\"https://example.invalid/a\"}") +(write-manifest "missing-url.json" + "{\"version\":\"2.0\"}") +(write-manifest "bad-sha.json" + "{\"version\":\"2.0\",\"url\":\"https://example.invalid/a\",\"sha256\":\"oops\"}") +(write-manifest "good.json" + "{\"version\":\"2.0\",\"url\":\"https://example.invalid/a\",\"notes\":\"ok\"}") + +(define-values (port stop) + (start-server #:port 18998 #:public-dir dir)) +(define base (format "http://127.0.0.1:~a/" port)) + +(check-false (check-update (string-append base "bad-version.json") + #:current-version "1.0") + "malformed remote version is ignored") +(check-false (check-update (string-append base "missing-url.json") + #:current-version "1.0") + "manifest without artifact URL is ignored") +(check-false (check-update (string-append base "bad-sha.json") + #:current-version "1.0") + "malformed digest is ignored") +(define info (check-update (string-append base "good.json") + #:current-version "1.0")) +(check-equal? (hash-ref info 'version) "2.0") +(check-equal? (hash-ref info 'notes) "ok") + +(stop) +(delete-directory/files dir) diff --git a/glaze-test/webview-contract-test.rkt b/glaze-test/webview-contract-test.rkt new file mode 100644 index 0000000..d26e23f --- /dev/null +++ b/glaze-test/webview-contract-test.rkt @@ -0,0 +1,34 @@ +#lang racket/base + +(require rackunit + glaze/webview/main) + +;; These checks must fail before any platform backend is loaded, so callers get +;; the same public contract on Windows, macOS, Linux, and headless hosts. +(check-exn exn:fail:contract? + (lambda () (open-window 42))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:title 42))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:width 0))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:height -1))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:devtools? 'yes))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:background-active? 'yes))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:on-close 42))) +(check-exn exn:fail:contract? + (lambda () (open-window "about:blank" #:fallback-browser? 'yes))) + +(check-exn exn:fail:contract? + (lambda () (webview-close 'not-a-webview))) +(check-exn exn:fail:contract? + (lambda () (webview-navigate 'not-a-webview "about:blank"))) +(check-exn exn:fail:contract? + (lambda () (webview-title 'not-a-webview))) +(check-exn exn:fail:contract? + (lambda () (webview-set-size! 'not-a-webview 640 480))) +(check-exn exn:fail:contract? + (lambda () (wait-for-webviews -1))) diff --git a/glaze/api.rkt b/glaze/api.rkt index 5d55135..41f5193 100644 --- a/glaze/api.rkt +++ b/glaze/api.rkt @@ -2,21 +2,9 @@ ;; JSON API routes for the frontend <-> Racket bridge. ;; -;; The page calls `fetch("/api/...")`; Racket answers JSON. This is Glaze's -;; answer to Tauri's invoke(): plain HTTP on the same local server that serves -;; the embedded WebView frontend. The endpoints are also easy to exercise from -;; tests and developer tools such as curl. -;; -;; Routes are ordinary values: -;; -;; (GET "api/ping" (lambda (req) (hasheq 'pong #t))) -;; (POST "api/items/:id/bump" (lambda (req id) ...)) -;; -;; A handler takes the web-server request followed by the captured :params. -;; It returns a jsexpr (auto-wrapped as a 200 JSON response) or a full -;; response (e.g. via json-response with your own status). request-json-body -;; parses the JSON request body. Handlers that raise produce a 500 JSON -;; error, never a half-written response. +;; The page calls `fetch("/api/...")`; Racket answers JSON. Routes are +;; ordinary values and remain usable in the embedded WebView, tests, and +;; direct HTTP clients. (require json racket/list @@ -46,36 +34,67 @@ (struct route (method segments handler) #:transparent) (struct param (id) #:transparent) -;; Raised by define-api-routes argument checking; the server maps it to a -;; 400 (plain exn:fail from a handler stays a 500). (struct exn:fail:glaze:bad-param exn:fail ()) -;; "api/items/:id" -> '("api" "items" (param id)) +;; "api/items/:id" -> '("api" "items" (param "id")). Leading/trailing +;; slashes are normalized because users naturally write both "api/x" and +;; "/api/x/". Empty parameter names are rejected at route construction. (define (parse-path path) (unless (string? path) - (raise-argument-error 'api-route "path string with :params" path)) - (for/list ([seg (in-list (string-split path "/" #:trim? #f))]) - (if (string-prefix? seg ":") (param (substring seg 1)) seg))) + (raise-argument-error 'api-route "string?" path)) + (define segments + (filter non-empty-string? (string-split path "/" #:trim? #f))) + (when (null? segments) + (raise-argument-error 'api-route "non-empty route path" path)) + (for/list ([seg (in-list segments)]) + (cond + [(string-prefix? seg ":") + (define id (substring seg 1)) + (when (string=? id "") + (raise-arguments-error 'api-route + "path parameter name cannot be empty" + "path" path)) + (param id)] + [(member seg '("." "..")) + (raise-arguments-error 'api-route + "route path cannot contain . or .. segments" + "path" path)] + [else seg]))) (define ((make-route-method method) path handler) (unless (procedure? handler) (raise-argument-error 'api-route "procedure?" handler)) - (route method (parse-path path) handler)) + (define segments (parse-path path)) + (define capture-count + (for/sum ([seg (in-list segments)]) (if (param? seg) 1 0))) + ;; Handlers receive the request plus one argument per :param. Catch an + ;; accidental arity mismatch while the application starts, not on the first + ;; customer request. + (unless (procedure-arity-includes? handler (add1 capture-count)) + (raise-arguments-error 'api-route + "handler arity does not accept request plus captured path parameters" + "path" path + "expected positional arguments" (add1 capture-count))) + (route method segments handler)) (define GET (make-route-method 'GET)) (define POST (make-route-method 'POST)) (define PUT (make-route-method 'PUT)) (define DELETE (make-route-method 'DELETE)) -;; URL path segments (already filtered of empties) as strings. (define (path->segments req) - (map path/param-path (url-path (request-uri req)))) + (unless (request? req) + (raise-argument-error 'path->segments "request?" req)) + (filter non-empty-string? + (map path/param-path (url-path (request-uri req))))) -;; Match a request (method symbol + path segments) against a route. Returns -;; the list of captured :param values on match, #f otherwise. All segments -;; must match; ":x" captures a string. The caller applies -;; (apply (route-handler r) req captured). (define (route-match r method segments) + (unless (route? r) + (raise-argument-error 'route-match "route?" r)) + (unless (symbol? method) + (raise-argument-error 'route-match "symbol?" method)) + (unless (and (list? segments) (andmap string? segments)) + (raise-argument-error 'route-match "(listof string?)" segments)) (and (eq? (route-method r) method) (= (length segments) (length (route-segments r))) (let loop ([segs segments] [pats (route-segments r)] [args '()]) @@ -89,20 +108,23 @@ [(string=? seg pat) (loop (rest segs) (rest pats) args)] [else #f])])))) -;; jsexpr -> JSON response (200). `json-response` keeps the historical name. (define (json-response data) (api-response data)) (define (api-response data) + (unless (jsexpr? data) + (raise-argument-error 'api-response "jsexpr?" data)) (define json-bytes (string->bytes/utf-8 (jsexpr->string data))) (response/full 200 #"OK" (current-seconds) #"application/json; charset=utf-8" '() (list json-bytes))) -;; Parse the request body as JSON. Missing/empty/invalid body -> the empty -;; hash, so optional parameters fall back to their defaults and required -;; ones report a clean 400 instead of an internal type error. +;; Missing/empty/invalid body intentionally yields the empty hash so optional +;; typed-route parameters can use defaults and required parameters report a +;; clean 400 instead of a JSON-parser exception. (define (request-json-body req) + (unless (request? req) + (raise-argument-error 'request-json-body "request?" req)) (define raw (request-post-data/raw req)) (define bs (cond @@ -116,6 +138,11 @@ (if (eof-object? parsed) (hasheq) parsed)) (define (error-response status msg) + (unless (and (exact-integer? status) (<= 100 status 599)) + (raise-argument-error 'error-response "exact-integer? in [100, 599]" status)) + (unless (string? msg) + (raise-argument-error 'error-response "string?" msg)) (response/full status #"Error" (current-seconds) #"application/json; charset=utf-8" '() - (list (string->bytes/utf-8 (jsexpr->string (hasheq 'error msg)))))) + (list (string->bytes/utf-8 + (jsexpr->string (hasheq 'error msg)))))) diff --git a/glaze/app.rkt b/glaze/app.rkt index 7afbcc6..a3ddee1 100644 --- a/glaze/app.rkt +++ b/glaze/app.rkt @@ -5,13 +5,11 @@ ;; (run-app #:public-dir "public" #:api (list (GET "api/ping" ...))) ;; ;; picks a free port, starts the server (static + JSON API), opens the native -;; WebView window, calls #:on-ready with the handle, and blocks until the -;; window closes. Returns (values 'webview shutdown); shutdown is a no-op if -;; called again after the normal window-close path. -;; -;; Native GUI is the application contract. If the platform WebView cannot -;; start, run-app stops the local server and propagates the actionable startup -;; error from glaze/webview. It never opens the system browser as a fallback. +;; webview window, calls #:on-ready with the handle, and blocks until the +;; window closes. A native WebView is mandatory; startup fails with actionable +;; guidance when the backend is unavailable. Returns (values 'webview shutdown) +;; after the window closes and the server has stopped. The returned shutdown +;; procedure is a no-op if called again. (require racket/random "server.rkt" @@ -39,7 +37,8 @@ (define (start-server-on-free-port #:public-dir public-dir #:api api-routes #:events [event-bus #f] - #:api-token [api-token #f]) + #:api-token [api-token #f] + #:bootstrap-token [bootstrap-token #f]) (let loop ([attempts 0]) (define candidate (+ 20000 (random 45000))) (with-handlers ([exn:fail:network? (lambda (e) @@ -50,7 +49,31 @@ #:public-dir public-dir #:api api-routes #:events event-bus - #:api-token api-token)))) + #:api-token api-token + #:bootstrap-token bootstrap-token)))) + +;; Serialize shutdown and execute the underlying server shutdown at most once. +;; The previous implementation used call-with-semaphore but did not remember +;; completion, so every later call invoked raw-shutdown again despite the +;; documented idempotent contract. +(define (make-idempotent-shutdown raw-shutdown) + (define lock (make-semaphore 1)) + (define stopped? #f) + (lambda () + (call-with-semaphore + lock + (lambda () + (unless stopped? + (raw-shutdown) + (set! stopped? #t)))))) + +;; Close a window during exceptional unwinding without replacing the original +;; exception with a secondary native-backend error. +(define (close-webview/safely wv) + (when wv + (with-handlers ([exn? void]) + (unless (webview-closed? wv) + (webview-close wv))))) (define (run-app #:public-dir [public-dir "public"] #:api [api-routes '()] @@ -58,70 +81,113 @@ #:title [title "Glaze"] #:width [width 1024] #:height [height 768] + #:background-active? [background-active? #f] #:events [event-bus #f] - #:api-token [api-token #f] + #:api-token [api-token #t] #:on-close [user-on-close (lambda () (void))] #:on-error [on-error #f] #:check-update [check-update #f] #:current-version [current-version "0.0.0"] #:on-ready [on-ready (lambda (wv url) (void))]) + (when (and port + (not (and (exact-integer? port) (<= 1 port 65535)))) + (raise-argument-error 'run-app "(or/c #f exact-integer? in [1, 65535])" port)) + (unless (string? title) + (raise-argument-error 'run-app "string?" title)) + (unless (exact-positive-integer? width) + (raise-argument-error 'run-app "exact-positive-integer?" width)) + (unless (exact-positive-integer? height) + (raise-argument-error 'run-app "exact-positive-integer?" height)) + (unless (boolean? background-active?) + (raise-argument-error 'run-app "boolean?" background-active?)) + (unless (or (eq? api-token #t) (eq? api-token #f) (string? api-token)) + (raise-argument-error 'run-app "(or/c #t #f string?)" api-token)) + (unless (procedure? user-on-close) + (raise-argument-error 'run-app "procedure?" user-on-close)) + (unless (or (not on-error) (procedure? on-error)) + (raise-argument-error 'run-app "(or/c #f procedure?)" on-error)) + (unless (or (not check-update) (string? check-update)) + (raise-argument-error 'run-app "(or/c #f string?)" check-update)) + (unless (string? current-version) + (raise-argument-error 'run-app "string?" current-version)) + (unless (procedure? on-ready) + (raise-argument-error 'run-app "procedure?" on-ready)) + (define token (cond [(eq? api-token #t) (make-api-token)] [(string? api-token) api-token] [else #f])) + (define bootstrap-token (and token (make-api-token))) (define-values (actual-port raw-shutdown) (if port (start-server #:port port #:public-dir public-dir #:api api-routes #:events event-bus - #:api-token token) + #:api-token token + #:bootstrap-token bootstrap-token) (start-server-on-free-port #:public-dir public-dir #:api api-routes #:events event-bus - #:api-token token))) + #:api-token token + #:bootstrap-token bootstrap-token))) (define url (format "http://127.0.0.1:~a/" actual-port)) - ;; Capability URL: the one-time ?glaze-token= bootstrap exchanges the token - ;; for an HttpOnly cookie and redirects to the clean URL. Without it the - ;; page would have no way to receive the token (api.js deliberately no - ;; longer hands it out); programmatic clients use the X-Glaze-Token header. + ;; A short-lived bootstrap nonce, distinct from the API token, is carried in + ;; the initial URL exactly once. The server consumes it and mints the + ;; HttpOnly API-token cookie, then redirects to the clean URL. (define open-url - (if token (format "~a?glaze-token=~a" url token) url)) - ;; Once-guard so callers may always call shutdown, even after run-app - ;; already stopped the server on window close. - (define once (make-semaphore 1)) - (define (shutdown) - (call-with-semaphore once (lambda () (raw-shutdown)))) + (if bootstrap-token + (format "~a?glaze-token=~a" url bootstrap-token) + url)) + (define shutdown (make-idempotent-shutdown raw-shutdown)) (define closed (make-semaphore 0)) - (parameterize ([current-api-token (or token "")] - [current-glaze-error-reporter - (or on-error (current-glaze-error-reporter))]) - (when check-update - (define info (do-check-update check-update - #:current-version current-version)) - (when info - (printf "[glaze] update available: ~a (current ~a) — ~a~n" - (hash-ref info 'version #f) - current-version - (hash-ref info 'url #f)) - (when event-bus - (bus-broadcast! event-bus 'update-available info)))) - ;; If native GUI startup fails, never leave the local HTTP server behind. - ;; open-window's exception contains the platform-specific install/repair - ;; instructions; preserve it unchanged for the caller/user. - (define wv - (with-handlers ([exn:fail? (lambda (e) - (shutdown) - (raise e))]) + (define active-wv #f) + + ;; Once the server exists, every exceptional exit from setup/runtime must + ;; release it. If a native window was already created, close that too. + (with-handlers ([exn? + (lambda (e) + (close-webview/safely active-wv) + (with-handlers ([exn? void]) (shutdown)) + (raise e))]) + (parameterize ([current-api-token (or token "")] + [current-glaze-error-reporter + (or on-error (current-glaze-error-reporter))]) + (define (start-update-check!) + (when check-update + (thread + (lambda () + (define info + (do-check-update check-update #:current-version current-version)) + (when info + (printf "[glaze] update available: ~a (current ~a) — ~a~n" + (hash-ref info 'version #f) + current-version + (hash-ref info 'url #f)) + (when event-bus + (bus-broadcast! event-bus 'update-available info))))))) + (define wv (open-window open-url #:title title #:width width #:height height - #:on-close (lambda () - (user-on-close) - (semaphore-post closed))))) - (on-ready wv url) - (sync closed) - (shutdown) - (values 'webview shutdown))) + #:background-active? background-active? + #:on-close + (lambda () + ;; A user callback must not be able to prevent the + ;; lifecycle semaphore from being posted. Preserve the + ;; callback's exception while guaranteeing progress. + (dynamic-wind + void + user-on-close + (lambda () (semaphore-post closed)))))) + (set! active-wv wv) + (on-ready wv url) + (start-update-check!) + (sync closed) + (shutdown) + (values 'webview shutdown)))) + +(module+ test-support + (provide make-idempotent-shutdown)) diff --git a/glaze/assets.rkt b/glaze/assets.rkt index 2580d66..d4d2e90 100644 --- a/glaze/assets.rkt +++ b/glaze/assets.rkt @@ -11,36 +11,71 @@ embedded-public-dir public-dir-relative?) -;; Resolve the directory to serve static files from, in a way that survives -;; packaging. In dev, callers pass a relative "public" and it resolves against -;; `current-directory`. In a packaged app, callers pass the embedded directory -;; (declared via `define-runtime-path` below) so the app does not depend on the -;; working directory at runtime. +;; Candidate roots for a relative asset directory. Development keeps the +;; current directory first. Packaged executables additionally look beside the +;; executable and, for a canonical macOS bundle, in ../Resources. +(define (runtime-asset-roots) + (define cwd (current-directory)) + (define run-file + (with-handlers ([exn:fail? (lambda (e) #f)]) + (find-system-path 'run-file))) + (define exe-dir + (and (path? run-file) + (path-only (path->complete-path run-file)))) + (filter values + (list cwd + exe-dir + (and exe-dir + (simplify-path (build-path exe-dir ".." "Resources") #f))))) + +;; Resolve the directory to serve static files from without changing the +;; process working directory. For an existing relative path, prefer the +;; developer's current directory. When that path is absent (the common case +;; for apps launched from Finder/Explorer), try locations relative to the +;; packaged executable. If nothing exists yet, preserve the historical +;; behavior by returning the current-directory resolution. (define (resolve-public-dir dir) - (if (complete-path? dir) - dir - (path->complete-path dir (current-directory)))) + (define p + (cond + [(path? dir) dir] + [(string? dir) (string->path dir)] + [else (raise-argument-error 'resolve-public-dir "(or/c path? string?)" dir)])) + (cond + [(complete-path? p) (simplify-path p #f)] + [else + (or (for/or ([root (in-list (runtime-asset-roots))]) + ;; Windows has root-relative paths such as /tmp: they are not + ;; complete paths, but they also cannot be appended to another + ;; base path. Treat an incompatible candidate root as a miss and + ;; let path->complete-path below resolve it against the current + ;; drive instead of leaking build-path's contract exception. + (define candidate + (with-handlers ([exn:fail? (lambda (e) #f)]) + (simplify-path (build-path root p) #f))) + (and candidate (directory-exists? candidate) candidate)) + (simplify-path (path->complete-path p (current-directory)) #f))])) ;; The default embedded public assets directory. Declaring it here with ;; `define-runtime-path` means `raco distribute` copies it next to the ;; executable; packaged apps then serve from this directory at runtime. ;; The path is relative to this source file, so it points at glaze/public ;; (an empty placeholder kept for library-level embedding; per-app embedded -;; assets come from the app's own `define-runtime-path` declaration). +;; assets can also come from an app's own `define-runtime-path` declaration). (define-runtime-path embedded-public-dir "public") -;; True if `path` is the embedded public dir (used by tests/build helpers). +;; Historical predicate retained for compatibility. (define (public-dir-relative? path) (and (path? path) #t)) (define (ensure-public-dir dir) (unless (directory-exists? dir) - (make-directory dir)) + (make-directory* dir)) dir) (define (copy-template src-dir dest-dir) (when (directory-exists? src-dir) - (for ([f (in-directory src-dir)]) + (for ([f (in-directory src-dir)] + #:when (file-exists? f)) (define rel (find-relative-path src-dir f)) (define dest (build-path dest-dir rel)) (unless (file-exists? dest) diff --git a/glaze/autolaunch.rkt b/glaze/autolaunch.rkt index 39d0f6a..4a0ec56 100644 --- a/glaze/autolaunch.rkt +++ b/glaze/autolaunch.rkt @@ -1,16 +1,9 @@ #lang racket/base ;; Launch-at-login ("auto-launch"), three platforms: -;; macOS — SMAppService mainAppService (macOS 13+; requires a packaged -;; .app — registration names the bundle, not the bare exe). -;; No permission prompt, modern replacement for the deprecated -;; LSSharedFileList. -;; Windows — a value in HKCU\Software\Microsoft\Windows\CurrentVersion\Run -;; (user scope, no admin). -;; Linux — an autostart .desktop entry in ~/.config/autostart. -;; -;; (auto-launch-set! "MyApp" #t) ; register -;; (auto-launch-enabled? "MyApp") ; => #t / #f / 'requires-approval +;; macOS — SMAppService mainAppService (macOS 13+; packaged .app) +;; Windows — HKCU\Software\Microsoft\Windows\CurrentVersion\Run +;; Linux — ~/.config/autostart desktop entry (require ffi/unsafe ffi/unsafe/objc @@ -31,55 +24,77 @@ (import-class SMAppService) -;; Status values from SMAppService.Status. +(define SMAppServiceStatusNotRegistered 0) (define SMAppServiceStatusEnabled 1) (define SMAppServiceStatusRequiresApproval 2) +(define SMAppServiceStatusNotFound 3) (define (mac-service) (and servicemgmt (let ([svc (tell SMAppService mainAppService)]) (and (cast svc _id _pointer) svc)))) -;; => #t / #f / 'requires-approval / 'not-registered / #f (unavailable host) (define (mac-enabled?) (define svc (mac-service)) (and svc (let ([s (tell #:type _int svc status)]) (case s + [(0) 'not-registered] [(1) #t] [(2) 'requires-approval] - [(3) 'not-registered] + [(3) #f] [else #f])))) (define (mac-set! enabled?) (define svc (mac-service)) (unless svc - (error 'auto-launch "SMAppService needs macOS 13+ and a packaged .app (raco glaze build)")) - (if enabled? - (let ([err (tell #:type _id svc register)]) - (unless (cast err _id _pointer) ; nil NSError = success - (error 'auto-launch "register failed: ~a" - (tell #:type _string err localizedDescription))) - (when (eq? (mac-enabled?) 'requires-approval) - (error 'auto-launch "registration needs approval in System Settings > General > Login Items"))) - (let ([err (tell #:type _id svc unregister)]) - (unless (cast err _id _pointer) - (error 'auto-launch "unregister failed: ~a" - (tell #:type _string err localizedDescription)))))) + (error 'auto-launch + "SMAppService needs macOS 13+ and a packaged .app (raco glaze build)")) + (define before (mac-enabled?)) + (cond + [enabled? + (cond + [(eq? before #t) #t] + [else + (define ok? + (tell #:type _bool svc registerAndReturnError: #:type _pointer #f)) + (define after (mac-enabled?)) + (cond + [(eq? after #t) #t] + [(eq? after 'requires-approval) + (error 'auto-launch + "registration requires approval in System Settings > General > Login Items")] + [ok? #t] + [else (error 'auto-launch "SMAppService registration failed")])])] + [else + (cond + [(eq? before 'not-registered) #t] + [else + (define ok? + (tell #:type _bool svc unregisterAndReturnError: #:type _pointer #f)) + (define after (mac-enabled?)) + (if (or ok? (eq? after 'not-registered)) + #t + (error 'auto-launch "SMAppService unregistration failed"))])])) ;; ---- Windows (HKCU Run key via reg.exe) ---- (define win-run-key "HKCU\\Software\\Microsoft\\Windows\\CurrentVersion\\Run") +;; Registry queries use the exit status as the API and therefore keep expected +;; "value not found" diagnostics out of application stderr. +(define (win-reg-exit-code reg . args) + (define out (open-output-string)) + (define err (open-output-string)) + (parameterize ([current-output-port out] + [current-error-port err]) + (apply system*/exit-code reg args))) + (define (win-enabled? name) (define reg (find-executable-path "reg.exe" #f)) (and reg (with-handlers ([exn:fail? (lambda (e) #f)]) - (define out (open-output-string)) - (define code - (parameterize ([current-output-port out]) - (system*/exit-code reg "query" win-run-key "/v" name))) - (and (zero? code) #t)))) + (zero? (win-reg-exit-code reg "query" win-run-key "/v" name))))) (define (win-set! name enabled?) (define reg (find-executable-path "reg.exe" #f)) @@ -91,12 +106,36 @@ "/d" (format "\"~a\"" exe) "/f")) (error 'auto-launch "failed to write Run key")) #t] + [(not (win-enabled? name)) + ;; Disable is idempotent when no value exists. + #t] [else - (system*/exit-code reg "delete" win-run-key "/v" name "/f") + (unless (zero? (system*/exit-code reg "delete" win-run-key "/v" name "/f")) + (error 'auto-launch "failed to delete Run key")) #t])) ;; ---- Linux (autostart desktop entry) ---- +(define (desktop-value-escape s) + (apply string-append + (for/list ([c (in-string s)]) + (case c + [(#\\) "\\\\"] + [(#\newline) "\\n"] + [(#\return) "\\r"] + [(#\tab) "\\t"] + [else (string c)])))) + +(define (desktop-exec-quote s) + (string-append + "\"" + (apply string-append + (for/list ([c (in-string s)]) + (if (member c '(#\\ #\" #\` #\$)) + (string #\\ c) + (string c)))) + "\"")) + (define (lin-desktop-path name) (define config-dir (or (getenv "XDG_CONFIG_HOME") @@ -120,8 +159,10 @@ (make-directory* (path-only p)) (call-with-output-file p (lambda (o) - (fprintf o "[Desktop Entry]\nType=Application\nName=~a\nExec=\"~a\"\nX-GNOME-Autostart-enabled=true\n" - name (path->string (find-system-path 'run-file)))) + (fprintf o "[Desktop Entry]\nType=Application\nName=~a\nExec=~a\nX-GNOME-Autostart-enabled=true\n" + (desktop-value-escape name) + (desktop-exec-quote + (path->string (find-system-path 'run-file))))) #:exists 'replace)) (when (file-exists? p) (delete-file p))) @@ -129,19 +170,22 @@ ;; ---- public API ---- -;; Register / unregister `name` as a launch-at-login item. On macOS the -;; bundle registers itself (name is informational); on Windows `name` is the -;; Run-key value name; on Linux it names the autostart entry. (define (auto-launch-set! name enabled?) + (unless (and (string? name) (non-empty-string? name)) + (raise-argument-error 'auto-launch-set! "non-empty-string?" name)) + (unless (boolean? enabled?) + (raise-argument-error 'auto-launch-set! "boolean?" enabled?)) + (when (and (eq? (system-type 'os) 'unix) + (zero? (string-length (safe-name name)))) + (error 'auto-launch-set! "name has no characters usable in a desktop filename")) (case (system-type 'os) [(macosx) (mac-set! enabled?)] [(windows) (win-set! name enabled?)] [else (lin-set! name enabled?)])) -;; => #t / #f when the backend knows; other values report nuance -;; ('requires-approval on macOS, 'not-registered); #f also when the host -;; cannot know (bare-execute on macOS 12-). (define (auto-launch-enabled? name) + (unless (and (string? name) (non-empty-string? name)) + (raise-argument-error 'auto-launch-enabled? "non-empty-string?" name)) (case (system-type 'os) [(macosx) (mac-enabled?)] [(windows) (win-enabled? name)] diff --git a/glaze/browser.rkt b/glaze/browser.rkt index 6bcc3a2..91e15fb 100644 --- a/glaze/browser.rkt +++ b/glaze/browser.rkt @@ -1,16 +1,25 @@ #lang racket/base -(require racket/match - racket/system) +(require racket/system) (provide open-browser) +;; Open a URL without invoking a command shell. The old implementation built a +;; shell command with `format`, so an untrusted URL containing shell +;; metacharacters could execute arbitrary commands in the app's user context. (define (open-browser url) - (define cmd - (match (system-type 'os) - ['windows (format "start ~a" url)] - ['macosx (format "open ~a" url)] - ['unix (format "xdg-open ~a" url)] - [_ #f])) - (when cmd - (system cmd))) + (unless (string? url) + (raise-argument-error 'open-browser "string?" url)) + (define-values (exe args) + (case (system-type 'os) + [(windows) + ;; rundll32's FileProtocolHandler delegates to the registered default + ;; handler. system* keeps the URL as a single argv element. + (values (find-executable-path "rundll32.exe" #f) + (list "url.dll,FileProtocolHandler" url))] + [(macosx) + (values (find-executable-path "open" #f) (list url))] + [(unix) + (values (find-executable-path "xdg-open" #f) (list url))] + [else (values #f '())])) + (and exe (apply system* exe args))) diff --git a/glaze/build.rkt b/glaze/build.rkt index 77d4c45..dabf458 100644 --- a/glaze/build.rkt +++ b/glaze/build.rkt @@ -4,10 +4,9 @@ ;; `raco distribute` so a Glaze project becomes a runnable directory (Windows) ;; or application bundle (macOS) with its frontend assets bundled. ;; -;; The frontend (public/) is declared via define-runtime-path in the generated -;; entry module, so raco distribute copies it next to the executable; at -;; runtime the app resolves the directory without depending on the working -;; directory. +;; The user's entry module is compiled directly so normal Racket +;; `(module+ main ...)` semantics are preserved. Frontend assets are copied +;; into the distribution and resolved at runtime by glaze/assets. (require racket/file racket/list @@ -20,6 +19,56 @@ (provide build-app default-entry-template) + +;; ---- packaging input hygiene ---- + +(define invalid-app-name-chars + (list #\< #\> #\: #\" #\/ #\\ #\| #\? #\*)) + +(define (valid-app-name? s) + (and (string? s) + (non-empty-string? s) + (not (member s '("." ".."))) + (for/and ([c (in-string s)]) + (and (>= (char->integer c) 32) + (not (member c invalid-app-name-chars)))) + (not (member (string-ref s (sub1 (string-length s))) '(#\space #\.))))) + +(define (valid-url-scheme? s) + (and (string? s) (regexp-match? #px"^[a-z][a-z0-9+.-]*$" s))) + +(define (xml-escape s) + (define str (format "~a" s)) + (string-replace + (string-replace + (string-replace + (string-replace + (string-replace str "&" "&") + "<" "<") + ">" ">") + "\"" """) + "'" "'")) + +(define (bundle-id-component s) + (define raw + (list->string + (for/list ([c (in-string (string-downcase s))]) + (if (or (char<=? #\a c #\z) + (char<=? #\0 c #\9) + (char=? c #\.) + (char=? c #\-)) + c + #\-)))) + (define cleaned (regexp-replace* #px"-+" raw "-")) + (if (regexp-match? #px"[a-z0-9]" cleaned) cleaned "app")) + +(define (nsis-escape s) + ;; In NSIS strings, '$' introduces variables/escapes. + (string-replace (format "~a" s) "$" "$$")) + +(define (shell-single-quote s) + (string-append "'" (string-replace s "'" "'\"'\"'") "'")) + ;; Build a Glaze project into a distributable. ;; ;; #:entry — the project's main.rkt path (default "main.rkt") @@ -83,23 +132,49 @@ (define entry-abs (path->complete-path entry-path)) (define project-dir (path-only entry-abs)) (define app-name (or name (path->string (file-name-from-path project-dir)))) - - ;; Generate an entry wrapper in a temp location that requires the user's - ;; main plus glaze, and re-exports nothing. We write it next to the entry so - ;; define-runtime-path for public/ resolves relative to the project. - (define gen-entry (build-path project-dir "glaze-build-entry.rkt")) - (call-with-output-file gen-entry - (lambda (out) (display (entry-module-source entry-path) out)) - #:exists 'replace) - + (unless (valid-app-name? app-name) + (raise-argument-error + 'build-app + "non-empty cross-platform filename without control chars or <>:\"/\\|?*" + app-name)) + (when (and version (not (and (string? version) (non-empty-string? version)))) + (raise-argument-error 'build-app "(or/c #f non-empty-string?)" version)) + (unless (and (list? url-schemes) (andmap valid-url-scheme? url-schemes)) + (raise-argument-error + 'build-app + "(listof lowercase URL schemes matching [a-z][a-z0-9+.-]*)" + url-schemes)) + (when (and icon-path (not (file-exists? icon-path))) + (error 'build-app "icon file not found: ~a" icon-path)) + + ;; Compile the user's actual entry module. Compiling a wrapper that merely + ;; required main.rkt skipped the user's `(module+ main ...)` submodule and + ;; could produce an executable that immediately exited with status 0. ;; Assemble the raco exe arguments. (define os (system-type 'os)) + (when (and entitlements (not (eq? os 'macosx))) + (error 'build-app "#:entitlements is only supported on macOS")) + (when notarize-profile + (unless (eq? os 'macosx) + (error 'build-app "#:notarize-profile is only supported on macOS")) + (unless sign + (error 'build-app "notarization requires #:sign with a signing identity"))) + (when (and sign (eq? os 'unix)) + (error 'build-app "#:sign is not supported for Linux distributions")) (define out-exe-name (case os [(windows) (string-append app-name ".exe")] [(macosx) app-name] ; --gui produces a .app bundle named app-name [else app-name])) - (define out-exe-path (build-path project-dir out-exe-name)) + ;; Build intermediates live in an isolated temporary directory. Older + ;; versions wrote /(.exe) and deleted it afterwards, + ;; which could overwrite a developer-owned file with the same name. + (define build-work-dir (make-temporary-file "glaze-build-~a" 'directory)) + (define out-exe-path (build-path build-work-dir out-exe-name)) + + (define (cleanup-build-work!) + (when (directory-exists? build-work-dir) + (delete-directory/files build-work-dir))) (define exe-args ;; --gui is Windows-only (console-less exe). On macOS --gui would make @@ -117,12 +192,11 @@ [(macosx) (list "--icns" (path->string icon-path))] [else '()]) '()) - (list "-o" (path->string out-exe-path) (path->string gen-entry)))) + (list "-o" (path->string out-exe-path) (path->string entry-abs)))) (unless (apply system* (find-racket-bin) exe-args) - (delete-the-generated-entry gen-entry) + (cleanup-build-work!) (error 'build-app "raco exe failed")) - ;; raco exe emits a read-only launcher; `raco distribute` needs to rewrite ;; the copy it makes (Mach-O/ELF segment patching) and fails with EACCES ;; on some Racket versions otherwise. @@ -135,14 +209,11 @@ ;; produce a consistent layout across platforms. (define dist-args (list "distribute" (path->string out-dir-path) (path->string out-exe-path))) (unless (apply system* (find-racket-bin) dist-args) - (delete-the-generated-entry gen-entry) + (cleanup-build-work!) (error 'build-app "raco distribute failed")) - ;; Clean up the generated entry and the standalone exe copy (distribute has - ;; its own copy inside out-dir). - (delete-the-generated-entry gen-entry) - (when (file-exists? out-exe-path) - (delete-file out-exe-path)) + ;; Distribute has copied everything it needs; remove isolated intermediates. + (cleanup-build-work!) ;; macOS: `raco distribute` of a bare exe yields a flat bin/+lib/ layout ;; (exact shape varies across Racket versions) — assemble the canonical @@ -153,9 +224,9 @@ ;; Bundle the project's public/ next to the distribution so the packaged ;; app can serve its frontend. On macOS the assets go inside the .app bundle - ;; Resources; elsewhere they sit beside the executable. The generated entry - ;; sets current-directory to the executable's dir at runtime so the user's - ;; relative #:public-dir "public" resolves to this copy. + ;; Resources; elsewhere they sit beside the executable. glaze/assets + ;; resolves a relative #:public-dir against these packaged locations without + ;; changing the process current directory. (copy-public-into-dist project-dir out-dir-path app-name os) ;; macOS post-processing: customize the bundle's Info.plist if produced. @@ -174,11 +245,14 @@ ;; Optional installer step. Each platform helper probes for the required ;; external tooling and warns (without failing the build) when it's absent; - ;; the CI matrix installs them. Returns the produced artifact path (or #f). + ;; the CI matrix exercises native paths and documented fallbacks. Returns + ;; the produced artifact path (or #f). (define installer-artifact (if installer? (make-installer os out-dir-path app-name (or version "0.0.0")) #f)) + (when (and installer? (not installer-artifact)) + (error 'build-app "installer was requested but no installer artifact was produced")) ;; Sign the installer artifact too (Windows msi / NSIS setup exe) — it ;; embeds the already-signed exe but is itself what SmartScreen judges. @@ -212,36 +286,82 @@ (define (run . args) (apply system* args)) -;; Windows: prefer WiX v4 (`wix`), then NSIS (`makensis`); else zip the dist. +;; Return the WiX executable only when the installed major version is 4. +;; Newer WiX majors have changed CLI/licensing behavior and must not be fed +;; Glaze's v4 source/command line by accident. Failure to probe is treated as +;; unsupported so NSIS/archive fallback remains available. +(define (find-wix-v4) + (define wix + (or (find-executable-path "wix.exe" #f) + (find-executable-path "wix" #f))) + (and wix + (with-handlers ([exn:fail? (lambda (e) #f)]) + (define out (open-output-string)) + (define err (open-output-string)) + (define code + (parameterize ([current-output-port out] + [current-error-port err]) + (system*/exit-code wix "--version"))) + (define text + (string-trim + (string-append (get-output-string out) " " (get-output-string err)))) + (define m (regexp-match #px"^\\s*([0-9]+)(?:[.]|\\s|$)" text)) + (and (zero? code) + m + (= (string->number (second m)) 4) + wix)))) + +;; Windows: prefer supported WiX v4, then NSIS; else zip the dist. (define (make-windows-installer out-dir app-name [version "0.0.0"]) (define dist (path->complete-path out-dir)) + (define any-wix + (or (find-executable-path "wix.exe" #f) + (find-executable-path "wix" #f))) + (define wix-v4 (find-wix-v4)) + (when (and any-wix (not wix-v4)) + (displayln + "[glaze] ignoring unsupported WiX version; Glaze currently supports WiX v4." + (current-error-port))) (cond - [(find-tool "wix.exe" "wix") + [wix-v4 (define msi-path (build-path dist (string-append app-name ".msi"))) ;; WiX v4: `wix build -o out.msi `; we generate a minimal wxs. - (define wxs-path (build-path dist (string-append app-name ".wxs"))) - (call-with-output-file wxs-path - (lambda (out) (display (windows-wxs app-name dist version) out)) - #:exists 'replace) - (if (run (find-executable-path "wix.exe" #f) - "build" - "-o" - (path->string msi-path) - (path->string wxs-path)) - msi-path - (fprintf (current-error-port) "[glaze] WiX build failed; see output above.\n"))] + (define wxs-path (make-temporary-file "glaze-wix-~a.wxs")) + (dynamic-wind + (lambda () + (call-with-output-file wxs-path + (lambda (out) (display (windows-wxs app-name dist version) out)) + #:exists 'replace) + (when (file-exists? msi-path) (delete-file msi-path))) + (lambda () + (unless (run wix-v4 + "build" "-o" (path->string msi-path) + (path->string wxs-path)) + (error 'build-app "WiX v4 build failed")) + (unless (file-exists? msi-path) + (error 'build-app "WiX v4 reported success but installer is missing: ~a" msi-path)) + msi-path) + (lambda () (when (file-exists? wxs-path) (delete-file wxs-path))))] [(find-tool "makensis") - (define nsis-path (build-path dist (string-append app-name ".nsi"))) - (call-with-output-file nsis-path - (lambda (out) (display (windows-nsis app-name dist) out)) - #:exists 'replace) + (define nsis-path (make-temporary-file "glaze-nsis-~a.nsi")) (define setup-exe (build-path dist (string-append app-name "-setup.exe"))) - (if (run (find-executable-path "makensis" #f) (path->string nsis-path)) - setup-exe - (fprintf (current-error-port) "[glaze] NSIS build failed; see output above.\n"))] + (dynamic-wind + (lambda () + (call-with-output-file nsis-path + (lambda (out) (display (windows-nsis app-name dist) out)) + #:exists 'replace) + (when (file-exists? setup-exe) (delete-file setup-exe))) + (lambda () + (unless (run (find-executable-path "makensis" #f) (path->string nsis-path)) + (error 'build-app "NSIS build failed")) + (unless (file-exists? setup-exe) + (error 'build-app "NSIS reported success but installer is missing: ~a" setup-exe)) + setup-exe) + (lambda () (when (file-exists? nsis-path) (delete-file nsis-path))))] [else - (display "[glaze] No Windows installer toolchain found (wix / makensis); " (current-error-port)) - (displayln "producing a .zip instead. Install WiX Toolset or NSIS for a real installer." + (display "[glaze] No supported Windows installer toolchain found (WiX v4 / NSIS); " + (current-error-port)) + (displayln "producing a .zip instead. Install WiX Toolset v4 or NSIS for a real installer." (current-error-port)) (archive-directory dist app-name "zip")])) @@ -252,24 +372,22 @@ (define dmg-path (build-path dist (string-append app-name ".dmg"))) (cond [(find-tool "create-dmg") - (and (run (find-executable-path "create-dmg" #f) - "--volname" - app-name - (path->string dmg-path) - (path->string bundle)) - dmg-path)] + (when (file-exists? dmg-path) (delete-file dmg-path)) + (unless (run (find-executable-path "create-dmg" #f) + "--volname" app-name + (path->string dmg-path) + (path->string bundle)) + (error 'build-app "create-dmg failed")) + dmg-path] [(find-tool "hdiutil") - (and (run (find-executable-path "hdiutil" #f) - "create" - "-volname" - app-name - "-srcfolder" - (path->string bundle) - "-ov" - "-format" - "UDZO" - (path->string dmg-path)) - dmg-path)] + (when (file-exists? dmg-path) (delete-file dmg-path)) + (unless (run (find-executable-path "hdiutil" #f) + "create" "-volname" app-name + "-srcfolder" (path->string bundle) + "-ov" "-format" "UDZO" + (path->string dmg-path)) + (error 'build-app "hdiutil failed")) + dmg-path] [else (display "[glaze] No macOS dmg toolchain found (create-dmg / hdiutil); " (current-error-port)) (displayln "producing a .zip instead." (current-error-port)) @@ -279,25 +397,60 @@ (define (make-linux-installer out-dir app-name) (define dist (path->complete-path out-dir)) (define appimage-path (build-path dist (string-append app-name ".AppImage"))) + (define appimagetool (find-executable-path "appimagetool" #f)) (cond - [(find-tool "appimagetool") - (define appdir (build-path dist "AppDir")) - (and (run (find-executable-path "appimagetool" #f) - (path->string appdir) - (path->string appimage-path)) - appimage-path)] - [(find-tool "linuxdeploy") - (putenv "OUTPUT" (path->string appimage-path)) - (and (run (find-executable-path "linuxdeploy" #f) - "--appdir" - (path->string (build-path dist "AppDir")) - "--output" - "appimage") - appimage-path)] + [appimagetool + (define appdir (make-temporary-file "glaze-AppDir-~a" 'directory)) + (dynamic-wind + (lambda () + (when (file-exists? appimage-path) (delete-file appimage-path)) + (define payload (build-path appdir "usr" "share" app-name)) + (make-directory* (path-only payload)) + (copy-directory/files dist payload) + (define app-run (build-path appdir "AppRun")) + (call-with-output-file app-run + (lambda (out) + (fprintf out "#!/bin/sh\nset -eu\nHERE=$(CDPATH= cd -- \"$(dirname -- \"$0\")\" && pwd)\n") + (fprintf out "APP_NAME=~a\n" (shell-single-quote app-name)) + (display "ROOT=\"$HERE/usr/share/$APP_NAME\"\n" out) + (display "if [ -x \"$ROOT/$APP_NAME\" ]; then exec \"$ROOT/$APP_NAME\" \"$@\"; fi\n" out) + (display "exec \"$ROOT/bin/$APP_NAME\" \"$@\"\n" out)) + #:exists 'replace) + (file-or-directory-permissions + app-run + (bitwise-ior (file-or-directory-permissions app-run 'bits) #o100)) + (call-with-output-file (build-path appdir (string-append app-name ".desktop")) + (lambda (out) + (fprintf out "[Desktop Entry]\nType=Application\nName=~a\nExec=AppRun\nIcon=glaze-app\nTerminal=false\nCategories=Utility;\n" + app-name)) + #:exists 'replace) + ;; appimagetool requires an icon named by the Desktop Entry. + (call-with-output-file (build-path appdir "glaze-app.svg") + (lambda (out) + (display + "" + out)) + #:exists 'replace) + (void)) + (lambda () + (define old-extract (getenv "APPIMAGE_EXTRACT_AND_RUN")) + (define ok? + (dynamic-wind + (lambda () (putenv "APPIMAGE_EXTRACT_AND_RUN" "1")) + (lambda () + (run appimagetool (path->string appdir) (path->string appimage-path))) + (lambda () (putenv "APPIMAGE_EXTRACT_AND_RUN" (or old-extract ""))))) + (unless ok? + (error 'build-app "appimagetool failed")) + (unless (file-exists? appimage-path) + (error 'build-app "appimagetool reported success but AppImage is missing")) + appimage-path) + (lambda () + (when (directory-exists? appdir) (delete-directory/files appdir))))] [else - (display "[glaze] No Linux AppImage toolchain found (appimagetool / linuxdeploy); " - (current-error-port)) - (displayln "producing a .tar.gz instead." (current-error-port)) + (displayln + "[glaze] appimagetool not found; producing a .tar.gz instead." + (current-error-port)) (archive-directory dist app-name "tar.gz")])) ;; Minimal WiX v4 source referencing the dist directory contents. @@ -322,11 +475,11 @@ WXEOF - app-name - version - app-name - (path->string dist-dir) - app-name)) + (xml-escape app-name) + (xml-escape version) + (xml-escape app-name) + (xml-escape (path->string dist-dir)) + (xml-escape app-name))) ;; Minimal NSIS script. (define (windows-nsis app-name dist-dir) @@ -342,13 +495,13 @@ Section "" CreateShortcut "$DESKTOP\\~a.lnk" "$INSTDIR\\~a.exe" SectionEnd NSI - app-name - (path->string dist-dir) - app-name - app-name - (path->string dist-dir) - app-name - app-name)) + (nsis-escape app-name) + (nsis-escape (path->string dist-dir)) + (nsis-escape app-name) + (nsis-escape app-name) + (nsis-escape (path->string dist-dir)) + (nsis-escape app-name) + (nsis-escape app-name))) ;; Produce a zip or tar.gz of dist contents as a portable fallback. Uses the ;; host `tar` if present (handles both formats), else warns. Returns the @@ -363,13 +516,21 @@ NSI [(equal? fmt "zip") (cond [(and (eq? (system-type 'os) 'windows) (find-executable-path "powershell.exe" #f)) - (and (run (find-executable-path "powershell.exe" #f) - "-NoProfile" - "-Command" - (format "Compress-Archive -Path '~a\\*' -DestinationPath '~a' -Force" - (path->string dist-abs) - (path->string archive-path))) - archive-path)] + (define script (make-temporary-file "glaze-archive-~a.ps1")) + (dynamic-wind + (lambda () + (call-with-output-file script + (lambda (out) + (display "param([string]$Source,[string]$Destination)\nCompress-Archive -Path (Join-Path $Source '*') -DestinationPath $Destination -Force\n" out)) + #:exists 'replace)) + (lambda () + (and (run (find-executable-path "powershell.exe" #f) + "-NoProfile" "-NonInteractive" "-File" + (path->string script) + "-Source" (path->string dist-abs) + "-Destination" (path->string archive-path)) + archive-path)) + (lambda () (when (file-exists? script) (delete-file script))))] [(find-executable-path "zip" #f) (and (parameterize ([current-directory parent]) (run (find-executable-path "zip" #f) "-r" (path->string archive-path) base)) @@ -416,7 +577,9 @@ NSI " (and c (directory-exists? (build-path c \"public\")) c))])\n" " (when (and pick (not (directory-exists? (build-path (current-directory) \"public\"))))\n" " (current-directory pick)))\n" - (format "(require \"~a\")\n" entry-filename))) + (format "(dynamic-require \"~a\" #f)\n" entry-filename) + (format "(define main-submod '(submod \"~a\" main))\n" entry-filename) + "(when (module-declared? main-submod #t) (dynamic-require main-submod #f))\n")) ;; Assemble a canonical macOS .app bundle from whatever `raco distribute` ;; produced. Current versions lay out /bin/ + /lib/; older @@ -469,18 +632,23 @@ NSI PLIST - app-name app-name app-name app-name version version + (xml-escape app-name) + (xml-escape app-name) + (xml-escape (bundle-id-component app-name)) + (xml-escape app-name) + (xml-escape version) + (xml-escape version) (if (null? url-schemes) "" (string-append "\n CFBundleURLTypes\n \n \n" " CFBundleURLNameio.glaze." - app-name + (xml-escape (bundle-id-component app-name)) "\n" " CFBundleURLSchemes\n \n" (string-join (for/list ([sc (in-list url-schemes)]) - (format " ~a\n" sc)) + (format " ~a\n" (xml-escape sc))) "") " \n \n ")))) ;; Copy the project's public/ into the distribution next to the executable. @@ -519,29 +687,25 @@ PLIST (define (post-process-macos-bundle out-dir app-name icon [version #f]) (define bundle (build-path out-dir (string-append app-name ".app"))) (define plist (build-path bundle "Contents" "Info.plist")) - (when (file-exists? plist) - (define pb (find-executable-path "PlistBuddy" #f)) - (when pb - (define (plist-set key val) - (system* pb "-c" (format "Set :~a ~a" key val) plist)) - (with-handlers ([exn:fail? void]) - (plist-set "CFBundleName" app-name) - (plist-set "CFBundleDisplayName" app-name) - (plist-set "CFBundleIdentifier" (string-append "io.glaze." app-name)) - (when version - (plist-set "CFBundleShortVersionString" version) - (plist-set "CFBundleVersion" version))) - (when (and icon (file-exists? icon)) - ;; Copy the icon into Resources and reference it. - (define icns-name (path->string (file-name-from-path icon))) - (define res-dir (build-path bundle "Contents" "Resources")) - (make-directory* res-dir) - (call-with-output-file (build-path res-dir icns-name) - (lambda (out) - (call-with-input-file icon (lambda (in) (copy-port in out)))) - #:exists 'replace) - (with-handlers ([exn:fail? void]) - (system* pb "-c" (format "Set :CFBundleIconFile ~a" icns-name) plist)))))) + ;; Name/id/version are already written by macos-info-plist. This pass only + ;; installs the optional icon and makes the plist reference it. + (when (and icon (file-exists? icon)) + (unless (file-exists? plist) + (error 'build-app "Info.plist missing from bundle: ~a" plist)) + (define pb-path (string->path "/usr/libexec/PlistBuddy")) + (unless (file-exists? pb-path) + (error 'build-app "PlistBuddy not found; cannot install bundle icon")) + (define icns-name (path->string (file-name-from-path icon))) + (define res-dir (build-path bundle "Contents" "Resources")) + (make-directory* res-dir) + (copy-file icon (build-path res-dir icns-name) #t) + (define set-ok? + (system* pb-path "-c" (format "Set :CFBundleIconFile ~a" icns-name) plist)) + (unless (or set-ok? + (system* pb-path "-c" + (format "Add :CFBundleIconFile string ~a" icns-name) + plist)) + (error 'build-app "could not write CFBundleIconFile to ~a" plist)))) ;; ---- Code signing & notarization ---- @@ -559,14 +723,11 @@ PLIST (sign-macos-bundle bundle sign entitlements hardened-runtime?)] [(windows) (define exe-path (build-path out-dir (string-append app-name ".exe"))) - (if (file-exists? exe-path) - (sign-windows-file exe-path sign timestamp-url) - (displayln (format "[glaze] cannot sign: exe not found at ~a" exe-path) - (current-error-port)))] + (unless (file-exists? exe-path) + (error 'build-app "cannot sign: exe not found at ~a" exe-path)) + (sign-windows-file exe-path sign timestamp-url)] [else - (displayln "[glaze] --sign is not applicable on this platform (no standard signing " - (current-error-port)) - (displayln "scheme for Linux apps); ignoring." (current-error-port))])) + (error 'build-app "#:sign is unsupported on this platform")])) ;; Sign a macOS .app with `codesign`, then verify. Raises on failure. ;; @@ -629,11 +790,8 @@ PLIST (define (sign-windows-file file cert-spec [timestamp-url default-timestamp-url]) (define signtool (find-tool "signtool.exe" "signtool")) (unless signtool - (displayln "[glaze] signtool not found (Windows SDK); skipping code signing. " - (current-error-port)) - (displayln "[glaze] Install the Windows SDK Signing Tools to sign for distribution." - (current-error-port)) - #f) + (error 'build-app + "signtool not found; install Windows SDK Signing Tools before using #:sign")) (when signtool (define cert-flag ;; A 40-hex string is a SHA-1 thumbprint; anything else is a subject name. @@ -681,9 +839,13 @@ PLIST (error 'build-app "notarization failed for ~a (profile ~a)" artifact keychain-profile)) (define staple-target (if (file-exists? dmg) dmg bundle)) - (system*/exit-code xcrun "stapler" "staple" (path->string staple-target)) - (fprintf (current-error-port) "[glaze] notarized: ~a\n" staple-target) + (unless (zero? (system*/exit-code xcrun "stapler" "staple" + (path->string staple-target))) + (error 'build-app "stapling notarization ticket failed for ~a" + staple-target)) + (fprintf (current-error-port) "[glaze] notarized and stapled: ~a\n" + staple-target) #t)) (define (default-entry-template) - entry-module-source) + entry-module-source) \ No newline at end of file diff --git a/glaze/deeplink.rkt b/glaze/deeplink.rkt index af9df9f..96d3fa2 100644 --- a/glaze/deeplink.rkt +++ b/glaze/deeplink.rkt @@ -47,12 +47,33 @@ "/ve" "/d" (format "\"~a\" \"%1\"" exe-path) "/f") #t)) +(define (desktop-value-escape s) + ;; Desktop Entry string values use backslash escapes for control + ;; characters. Prevent a user-controlled app name from injecting keys. + (apply string-append + (for/list ([c (in-string s)]) + (case c + [(#\\) "\\\\"] + [(#\newline) "\\n"] + [(#\return) "\\r"] + [(#\tab) "\\t"] + [else (string c)])))) + +(define (desktop-exec-quote s) + ;; Exec= has its own quoting rules. Inside double quotes, escape characters + ;; with special meaning so an executable path remains one literal argv[0]. + (string-append + "\"" + (apply string-append + (for/list ([c (in-string s)]) + (if (member c '(#\\ #\" #\` #\$)) + (string #\\ c) + (string c)))) + "\"")) + ;; Linux: a desktop entry advertising the scheme, registered as its default ;; handler via xdg-mime when available. (define (lin-register! scheme exe-path app-name) - (define config-dir - (or (getenv "XDG_CONFIG_HOME") - (build-path (find-system-path 'home-dir) ".config"))) (define data-dir (or (getenv "XDG_DATA_HOME") (build-path (find-system-path 'home-dir) ".local" "share"))) @@ -62,8 +83,10 @@ (define desktop-path (build-path apps-dir desktop-name)) (call-with-output-file desktop-path (lambda (o) - (fprintf o "[Desktop Entry]\nType=Application\nName=~a\nExec=\"~a\" %u\nMimeType=x-scheme-handler/~a;\nNoDisplay=true\n" - app-name exe-path scheme)) + (fprintf o "[Desktop Entry]\nType=Application\nName=~a\nExec=~a %u\nMimeType=x-scheme-handler/~a;\nNoDisplay=true\n" + (desktop-value-escape app-name) + (desktop-exec-quote exe-path) + scheme)) #:exists 'replace) ;; Best-effort: without xdg-mime the entry is in place but may not be ;; picked up until the next desktop-environment rescan. @@ -82,6 +105,8 @@ ;; 'desktop — Linux desktop entry (re)written ;; 'build-time — macOS: declared in the bundle's Info.plist at build time (define (ensure-url-scheme! scheme #:app-name [app-name scheme]) + (unless (string? app-name) + (raise-argument-error 'ensure-url-scheme! "string?" app-name)) (unless (regexp-match? #rx"^[a-z][a-z0-9+.-]*$" scheme) (error 'ensure-url-scheme! "invalid URL scheme: ~a" scheme)) (case (system-type 'os) @@ -93,4 +118,5 @@ (error 'ensure-url-scheme! "failed to write registry entries for ~a" scheme))] [else (define exe (find-system-path 'run-file)) - (lin-register! scheme (path->string exe) app-name)])) + (lin-register! scheme (path->string exe) app-name) + 'desktop])) diff --git a/glaze/dialogs.rkt b/glaze/dialogs.rkt index 880f076..39118e1 100644 --- a/glaze/dialogs.rkt +++ b/glaze/dialogs.rkt @@ -1,19 +1,12 @@ #lang racket/base ;; Native file/folder dialogs, three platforms: -;; macOS — NSOpenPanel / NSSavePanel via objc FFI (AppKit is loaded -;; explicitly; plain racket only links Foundation). -;; Windows — GetOpenFileNameW / GetSaveFileNameW from comdlg32 (present on -;; every Windows install; the Vista IFileOpenDialog COM dance -;; buys nicer chrome, not capability). -;; Linux — zenity or kdialog via subprocess (the dialog front-ends of -;; the desktop environments). When neither exists, opening a -;; dialog RAISES — silent #f would be indistinguishable from -;; the user cancelling; check dialog-supported? first. +;; macOS — NSOpenPanel / NSSavePanel via objc FFI +;; Windows — GetOpenFileNameW / GetSaveFileNameW for files and +;; SHBrowseForFolderW for directories +;; Linux — zenity or kdialog subprocesses ;; -;; Contract: #f (or an empty list for pick-files) means the user cancelled. -;; Dialogs block the calling thread until the user picks; call from a thread -;; you can afford to park. +;; Contract: #f (or an empty list for pick-files) means user cancellation. (require ffi/unsafe ffi/unsafe/objc @@ -29,56 +22,94 @@ pick-files pick-folder save-file-dialog - ;; pure helpers, exported for the test suite + ;; pure helpers, exported for regression tests win-filter-string wstr wstr-parts) -;; ---- UTF-16 plumbing (Windows wide strings) ---- +;; ---- common validation ---- + +(define (valid-filter? f) + (and (list? f) + (pair? f) + (string? (car f)) + (andmap string? (cdr f)))) -(define utf16-converter - (bytes-open-converter "UTF-8" "UTF-16LE")) +(define (check-dialog-args who title directory filters [default-name #f]) + (unless (or (not title) (string? title)) + (raise-argument-error who "(or/c #f string?)" title)) + (unless (or (not directory) (path? directory) (string? directory)) + (raise-argument-error who "(or/c #f path? string?)" directory)) + (unless (and (list? filters) (andmap valid-filter? filters)) + (raise-argument-error who "list of (list name pattern ...) strings" filters)) + (unless (or (not default-name) (string? default-name)) + (raise-argument-error who "(or/c #f string?)" default-name))) + +;; ---- UTF-16 plumbing (Windows wide strings) ---- -;; platform string -> NUL-terminated UTF-16LE bytes. +;; platform string -> NUL-terminated UTF-16LE bytes. Use a fresh converter per +;; call: dialog APIs can be invoked from different Racket threads and converter +;; state is not a useful process-global resource. (define (wstr s) + (unless (string? s) + (raise-argument-error 'wstr "string?" s)) + (define cv (bytes-open-converter "UTF-8" "UTF-16LE")) (define in (string->bytes/utf-8 s)) - (define-values (out consumed status) - (bytes-convert utf16-converter in)) + (define-values (out consumed status) (bytes-convert cv in)) + (bytes-close-converter cv) (unless (and (eq? status 'complete) (= consumed (bytes-length in))) (error 'wstr "UTF-16 conversion failed")) (bytes-append out (bytes 0 0))) -;; UTF-16LE bytes -> list of strings split on NUL code units (2 zero bytes — -;; unit-aware, so paths containing code units like U+0100 split correctly). -(define (wstr-parts b) +(define (utf16-nul-at? b i) + (and (<= (+ i 1) (sub1 (bytes-length b))) + (zero? (bytes-ref b i)) + (zero? (bytes-ref b (+ i 1))))) + +(define (decode-utf16 b start end) (define cv (bytes-open-converter "UTF-16LE" "UTF-8")) - (let loop ([i 0] [acc '()]) - (if (>= (+ i 1) (bytes-length b)) - (reverse acc) - (if (and (zero? (bytes-ref b i)) (zero? (bytes-ref b (+ i 1)))) - (reverse acc) ; terminating NUL code unit - (let ([end (let loop2 ([j i]) - (if (and (zero? (bytes-ref b j)) (zero? (bytes-ref b (+ j 1)))) - j - (loop2 (+ j 2))))]) - (define-values (out consumed status) - (bytes-convert cv (subbytes b i end))) - (loop (+ end 2) - (cons (bytes->string/utf-8 out) acc))))))) + (define-values (out consumed status) (bytes-convert cv (subbytes b start end))) + (bytes-close-converter cv) + (unless (eq? status 'complete) + (error 'wstr-parts "invalid UTF-16 buffer")) + (bytes->string/utf-8 out)) + +;; Windows multi-select buffers are a UTF-16 multi-string: +;; directory NUL file1 NUL file2 NUL NUL +;; A single selection is simply path NUL NUL. A single NUL separates entries; +;; an empty next entry (double NUL) terminates the list. +(define (wstr-parts b) + (unless (bytes? b) + (raise-argument-error 'wstr-parts "bytes?" b)) + (define len (bytes-length b)) + (let loop ([start 0] [acc '()]) + (cond + [(>= (+ start 1) len) (reverse acc)] + [(utf16-nul-at? b start) (reverse acc)] + [else + (define end + (let find ([i start]) + (cond + [(>= (+ i 1) len) len] + [(utf16-nul-at? b i) i] + [else (find (+ i 2))]))) + (define piece (decode-utf16 b start end)) + (define next (+ end 2)) + (if (or (>= (+ next 1) len) (utf16-nul-at? b next)) + (reverse (cons piece acc)) + (loop next (cons piece acc)))]))) ;; ---- platform dispatch ---- (define (dialog-supported?) (case (system-type 'os) [(macosx) (and appkit #t)] - [(windows) (and comdlg32 #t)] + [(windows) (and comdlg32 shell32 #t)] [else (and (or (find-executable-path "zenity" #f) (find-executable-path "kdialog" #f)) #t)])) -;; Filter spec: (list (list "Human name" "*.txt" "*.md") ...). - -;; ---- macOS (AppKit via objc) ---- +;; ---- macOS (AppKit) ---- (define appkit (with-handlers ([exn:fail? (lambda (e) #f)]) @@ -94,15 +125,12 @@ (define (as-path p) (if (string? p) (string->path p) p)) -;; Common panel configuration. NSOpenPanel subclasses NSSavePanel — every -;; setter exists on both. (define (configure-panel! panel title directory filters) (when title (tellv panel setTitle: (->nsstring title))) (when (and directory (directory-exists? (as-path directory))) (tellv panel setDirectoryURL: #:type _id (tell NSURL fileURLWithPath: #:type _id (->nsstring (path->string (as-path directory)))))) - ;; Allowed types: plain extensions ("txt", "md") work on macOS 11+. (define exts (for*/list ([f (in-list filters)] [pattern (in-list (cdr f))] @@ -126,16 +154,18 @@ (configure-panel! panel title directory filters) (tellv panel setCanChooseFiles: #:type _bool (not folder?)) (tellv panel setCanChooseDirectories: #:type _bool folder?) - (when multiple? - (tellv panel setAllowsMultipleSelection: #:type _bool #t)) + (tellv panel setAllowsMultipleSelection: #:type _bool multiple?) (define response (tell #:type _int panel runModal)) (and (= response NSModalResponseOK) (let () (define urls (tell #:type _id panel URLs)) (define n (tell #:type _int urls count)) - (for/list ([i (in-range n)]) - (define p (nsurl->path (tell #:type _id urls objectAtIndex: #:type _int i))) - (and p (string->path p)))))) + (filter values + (for/list ([i (in-range n)]) + (define p + (nsurl->path + (tell #:type _id urls objectAtIndex: #:type _int i))) + (and p (string->path p))))))) (define (mac-save title default-name directory filters) (define panel (tell NSSavePanel savePanel)) @@ -147,13 +177,12 @@ (let ([p (nsurl->path (tell #:type _id panel URL))]) (and p (string->path p))))) -;; ---- Windows (comdlg32) ---- +;; ---- Windows ---- (define comdlg32 (with-handlers ([exn:fail? (lambda (e) #f)]) (ffi-lib "comdlg32"))) -;; OPENFILENAMEW — the full modern struct (unused fields passed as 0/NULL). (define-cstruct _OPENFILENAMEW ([lStructSize _uint32] [hwndOwner _pointer] @@ -180,20 +209,75 @@ [FlagsEx _uint32])) (define OFN_ALLOWMULTISELECT #x00000200) -(define OFN_EXPLORER #x00080000) +(define OFN_EXPLORER #x00080000) (define OFN_OVERWRITEPROMPT #x00000002) -(define OFN_PICKFOLDERS #x00000020) + +(define shell32 + (with-handlers ([exn:fail? (lambda (e) #f)]) + (ffi-lib "shell32"))) +(define ole32 + (with-handlers ([exn:fail? (lambda (e) #f)]) + (ffi-lib "ole32"))) + +(define-cstruct _BROWSEINFOW + ([hwndOwner _pointer] + [pidlRoot _pointer] + [pszDisplayName _pointer] + [lpszTitle _pointer] + [ulFlags _uint32] + [lpfn _pointer] + [lParam _intptr] + [iImage _int])) + +(define SHBrowseForFolderW + (and shell32 + (get-ffi-obj "SHBrowseForFolderW" shell32 + (_fun _BROWSEINFOW-pointer -> _pointer) + (lambda () #f)))) +(define SHGetPathFromIDListW + (and shell32 + (get-ffi-obj "SHGetPathFromIDListW" shell32 + (_fun _pointer _pointer -> _bool) + (lambda () #f)))) +(define CoTaskMemFree + (and ole32 + (get-ffi-obj "CoTaskMemFree" ole32 + (_fun _pointer -> _void) + (lambda () #f)))) + +(define BIF_RETURNONLYFSDIRS #x00000001) + +(define (win-pick-folder title _directory) + (unless (and SHBrowseForFolderW SHGetPathFromIDListW) + (error 'pick-folder "Windows Shell folder dialog unavailable")) + (define display-buffer (make-bytes (* 2 260))) + (define path-buffer (make-bytes (* 2 32768))) + (define title-buffer (and title (wstr title))) + (define bi + (make-BROWSEINFOW #f #f display-buffer title-buffer + BIF_RETURNONLYFSDIRS #f 0 0)) + (define pidl (SHBrowseForFolderW bi)) + (and pidl + (dynamic-wind + void + (lambda () + (and (SHGetPathFromIDListW pidl path-buffer) + (let ([parts (wstr-parts path-buffer)]) + (and (pair? parts) (string->path (first parts)))))) + (lambda () + (when CoTaskMemFree (CoTaskMemFree pidl)))))) (define GetOpenFileNameW - (and comdlg32 (get-ffi-obj "GetOpenFileNameW" comdlg32 - (_fun _OPENFILENAMEW-pointer -> _bool) (lambda () #f)))) + (and comdlg32 + (get-ffi-obj "GetOpenFileNameW" comdlg32 + (_fun _OPENFILENAMEW-pointer -> _bool) + (lambda () #f)))) (define GetSaveFileNameW - (and comdlg32 (get-ffi-obj "GetSaveFileNameW" comdlg32 - (_fun _OPENFILENAMEW-pointer -> _bool) (lambda () #f)))) + (and comdlg32 + (get-ffi-obj "GetSaveFileNameW" comdlg32 + (_fun _OPENFILENAMEW-pointer -> _bool) + (lambda () #f)))) -;; Win32 filter encoding: "name\0patterns\0" pairs, whole blob -;; double-NUL-terminated. "All files" is appended when no filter matches -;; everything, so the user is never stuck. (define (win-filter-string filters) (string-append (string-join @@ -204,47 +288,48 @@ "") "\0")) -(define (win-open-dialog! title directory filters multiple? folder? save? default-name) +(define (copy-initial-name! buffer default-name) + (when (and default-name (non-empty-string? default-name)) + (define encoded (wstr default-name)) + (when (> (bytes-length encoded) (bytes-length buffer)) + (raise-arguments-error 'save-file-dialog + "default filename is too long for the Windows dialog buffer" + "default-name" default-name)) + (bytes-copy! buffer 0 encoded))) + +(define (win-open-dialog! title directory filters multiple? _folder? save? default-name) (define getter (if save? GetSaveFileNameW GetOpenFileNameW)) (unless getter (error 'pick-file "comdlg32 unavailable")) - (define file-buffer (make-bytes (* 2 32768))) ; UTF-16, MAX_PATH headroom - (define initial - (and default-name - (non-empty-string? default-name) - (not directory) - (wstr default-name))) + ;; lpstrFile must point at storage whose actual allocation matches nMaxFile. + ;; Always pass the large buffer and copy the optional default name into it; + ;; passing a small encoded default string with nMaxFile=32768 would let the + ;; native API write beyond the allocation. + (define file-buffer (make-bytes (* 2 32768))) + (copy-initial-name! file-buffer default-name) (define ofn (make-OPENFILENAMEW (ctype-sizeof _OPENFILENAMEW) #f #f (wstr (win-filter-string filters)) #f 0 0 - (or initial file-buffer) + file-buffer (quotient (bytes-length file-buffer) 2) #f 0 (and directory (wstr (path->string (as-path directory)))) (and title (wstr title)) (bitwise-ior (if multiple? (bitwise-ior OFN_ALLOWMULTISELECT OFN_EXPLORER) 0) - (if folder? OFN_PICKFOLDERS 0) (if save? OFN_OVERWRITEPROMPT 0)) 0 0 #f #f #f #f #f 0 0)) - (define ok? (getter ofn)) - (and ok? - (let () - (define used - (for/first ([i (in-range 0 (bytes-length file-buffer) 2)] - #:when (and (zero? (bytes-ref file-buffer i)) - (zero? (bytes-ref file-buffer (+ i 1))))) - i)) - (define parts (wstr-parts (subbytes file-buffer 0 (or used (bytes-length file-buffer))))) + (and (getter ofn) + (let ([parts (wstr-parts file-buffer)]) (cond - ;; Multi-select (explorer mode): first part = folder, rest = names. [(and multiple? (> (length parts) 1)) (define dir (path->directory-path (first parts))) (for/list ([n (in-list (rest parts))]) (build-path dir n))] - [else (for/list ([p (in-list parts)]) (string->path p))])))) + [else + (for/list ([p (in-list parts)]) (string->path p))])))) -;; ---- Linux (zenity / kdialog) ---- +;; ---- Linux ---- (define (run-dialog-capture exe args) (with-handlers ([exn:fail? (lambda (e) #f)]) @@ -252,14 +337,15 @@ (define code (parameterize ([current-output-port out]) (apply system*/exit-code exe args))) - ;; 0 = picked, 1 = cancelled. (and (= code 0) (let ([s (string-trim (get-output-string out))]) (and (non-empty-string? s) s))))) (define (zenity-filters filters) (append-map - (lambda (f) (list "--file-filter" (format "~a | ~a" (car f) (string-join (cdr f) " ")))) + (lambda (f) + (list "--file-filter" + (format "~a | ~a" (car f) (string-join (cdr f) " ")))) filters)) (define (kdialog-filter filters) @@ -290,14 +376,22 @@ #:when (non-empty-string? line)) (string->path line)))] [kdialog - (define start (or directory default-name ".")) + (define start + (cond + [(and directory default-name) + (path->string (build-path (as-path directory) default-name))] + [directory (if (path? directory) (path->string directory) directory)] + [default-name default-name] + [else "."])) (define args - (append (cond - [folder? (list "--getexistingdirectory" start)] - [save? (list "--getsavefilename" start (kdialog-filter filters))] - [multiple? (list "--getopenfilename" start "--multiple" (kdialog-filter filters))] - [else (list "--getopenfilename" start (kdialog-filter filters))]) - (if title (list (format "--title ~a" title)) '()))) + (append + (cond + [folder? (list "--getexistingdirectory" start)] + [save? (list "--getsavefilename" start (kdialog-filter filters))] + [multiple? (list "--getopenfilename" start "--multiple" + (kdialog-filter filters))] + [else (list "--getopenfilename" start (kdialog-filter filters))]) + (if title (list "--title" title) '()))) (define s (run-dialog-capture kdialog args)) (and s (for/list ([line (in-list (string-split s "\n"))] @@ -311,47 +405,47 @@ (define (unwrap-single r) (and r (pair? r) (first r))) -(define (check-support!) +(define (check-support! who) (unless (dialog-supported?) - (error 'pick-file "no file dialog backend on this platform"))) + (error who "no file dialog backend on this platform"))) -;; Open one file. #f when cancelled. (define (pick-file #:title [title #f] #:directory [directory #f] #:filters [filters '()]) - (check-support!) + (check-dialog-args 'pick-file title directory filters) + (check-support! 'pick-file) (case (system-type 'os) [(macosx) (unwrap-single (mac-pick title directory filters #f #f))] [(windows) (unwrap-single (win-open-dialog! title directory filters #f #f #f #f))] [else (unwrap-single (lin-dialog title directory filters #f #f #f #f))])) -;; Open one or more files. Returns a list (empty on cancel). (define (pick-files #:title [title #f] #:directory [directory #f] #:filters [filters '()]) - (check-support!) + (check-dialog-args 'pick-files title directory filters) + (check-support! 'pick-files) (case (system-type 'os) [(macosx) (or (mac-pick title directory filters #t #f) '())] [(windows) (or (win-open-dialog! title directory filters #t #f #f #f) '())] [else (or (lin-dialog title directory filters #t #f #f #f) '())])) -;; Pick an existing folder. #f when cancelled. (define (pick-folder #:title [title #f] #:directory [directory #f]) - (check-support!) + (check-dialog-args 'pick-folder title directory '()) + (check-support! 'pick-folder) (case (system-type 'os) [(macosx) (unwrap-single (mac-pick title directory '() #f #t))] - [(windows) (unwrap-single (win-open-dialog! title directory '() #f #t #f #f))] + [(windows) (win-pick-folder title directory)] [else (unwrap-single (lin-dialog title directory '() #f #t #f #f))])) -;; Save-as dialog. #f when cancelled. The overwrite prompt is the dialog's; -;; no file is created here. (define (save-file-dialog #:title [title #f] #:default-name [default-name #f] #:directory [directory #f] #:filters [filters '()]) - (check-support!) + (check-dialog-args 'save-file-dialog title directory filters default-name) + (check-support! 'save-file-dialog) (case (system-type 'os) [(macosx) (mac-save title default-name directory filters)] [(windows) (win-open-dialog! title directory filters #f #f #t default-name)] - [else (unwrap-single (lin-dialog title directory filters #f #f #t default-name))])) + [else (unwrap-single + (lin-dialog title directory filters #f #f #t default-name))])) diff --git a/glaze/events.rkt b/glaze/events.rkt index aa7c7b0..d6649bf 100644 --- a/glaze/events.rkt +++ b/glaze/events.rkt @@ -14,7 +14,8 @@ ;; const es = new EventSource('/glaze/events'); ;; es.addEventListener('counter-changed', e => e.detail); -(require racket/async-channel) +(require json + racket/async-channel) (provide make-event-bus event-bus? @@ -45,9 +46,24 @@ ;; Deliver (name . jsexpr) to every subscriber. Non-blocking: a full ;; backlog drops the event for that subscriber only. +(define (valid-event-name? name) + (define s + (cond + [(symbol? name) (symbol->string name)] + [(string? name) name] + [else #f])) + (and s + (positive? (string-length s)) + (not (regexp-match? #rx"[\r\n\u0000]" s)))) + (define (bus-broadcast! bus name data) - (unless (or (symbol? name) (string? name)) - (raise-argument-error 'bus-broadcast! "(or/c symbol? string?)" name)) + (unless (valid-event-name? name) + (raise-argument-error + 'bus-broadcast! + "non-empty symbol/string without CR, LF, or NUL" + name)) + (unless (jsexpr? data) + (raise-argument-error 'bus-broadcast! "jsexpr?" data)) (define payload (list (if (string? name) (string->symbol name) name) data)) (define snapshot @@ -59,4 +75,6 @@ ;; Blocking receive with timeout — for tests and non-SSE consumers. ;; Returns (list name data) or 'timeout. (define (bus-wait ch [secs 10]) + (unless (and (real? secs) (>= secs 0)) + (raise-argument-error 'bus-wait "nonnegative-real?" secs)) (or (sync/timeout secs ch) 'timeout)) diff --git a/glaze/license.rkt b/glaze/license.rkt index 21970a6..2843007 100644 --- a/glaze/license.rkt +++ b/glaze/license.rkt @@ -155,19 +155,10 @@ [else (json-string (format "~a" v))])) (define (json-string s) - (string-append - "\"" - (string-join - (for/list ([c (in-string s)]) - (case c - [(#\") "\\\""] - [(#\\) "\\\\"] - [(#\newline) "\\n"] - [(#\return) "\\r"] - [(#\tab) "\\t"] - [else (string c)])) - "") - "\"")) + ;; Let the JSON library handle every required escape (including control + ;; characters below U+0020) instead of maintaining a partial encoder. + (jsexpr->string s)) + ;; ---- RSA-SHA256 over payload bytes ---- @@ -229,6 +220,22 @@ #:expiry [expiry #f] #:machine-id [machine #f] #:out [out "app.license"]) + (unless (path-string? private-key) + (raise-argument-error 'issue-license "path-string?" private-key)) + (unless (and (string? product) (non-empty-string? product)) + (raise-argument-error 'issue-license "non-empty-string?" product)) + (unless (and (string? subject) (non-empty-string? subject)) + (raise-argument-error 'issue-license "non-empty-string?" subject)) + (when expiry + (unless (string? expiry) + (raise-argument-error 'issue-license "(or/c #f string?)" expiry)) + ;; Parse now so malformed dates cannot be signed into a license that every + ;; validator will later reject or interpret inconsistently. + (days-until-expiry expiry)) + (when (and machine (not (string? machine))) + (raise-argument-error 'issue-license "(or/c #f string?)" machine)) + (unless (path-string? out) + (raise-argument-error 'issue-license "path-string?" out)) (define claims (make-hasheq (append (list (cons 'product product) @@ -309,18 +316,33 @@ ;; Days until an "YYYY-MM-DD" expiry (expiry day inclusive); negative when ;; already past. Raises on a malformed date. (define (days-until-expiry expiry) - ;; #px, not #rx: {n} quantifiers need Perl-style syntax + (unless (string? expiry) + (raise-argument-error 'days-until-expiry "string?" expiry)) + ;; #px, not #rx: {n} quantifiers need Perl-style syntax. (define m (regexp-match #px"^([0-9]{4})-([0-9]{2})-([0-9]{2})$" expiry)) (unless m (error 'days-until-expiry "malformed expiry date: ~a" expiry)) (define y (string->number (second m))) (define mo (string->number (third m))) (define d (string->number (fourth m))) + (define secs-exp + (with-handlers ([exn:fail? + (lambda (e) + (error 'days-until-expiry + "invalid expiry date: ~a" expiry))]) + ;; Use UTC so daylight-saving transitions cannot turn a calendar day + ;; into 23/25 hours and shift the result by one. + (find-seconds 0 0 0 d mo y #f))) + (define parsed (seconds->date secs-exp #f)) + (unless (and (= (date-year parsed) y) + (= (date-month parsed) mo) + (= (date-day parsed) d)) + (error 'days-until-expiry "invalid expiry date: ~a" expiry)) (define today (current-date)) - (define secs-exp (find-seconds 0 0 0 d mo y #f)) - (define secs-now (find-seconds 0 0 0 - (date-day today) (date-month today) - (date-year today) #f)) - (inexact->exact (floor (/ (- secs-exp secs-now) 60 60 24)))) + (define secs-now + (find-seconds 0 0 0 + (date-day today) (date-month today) + (date-year today) #f)) + (quotient (- secs-exp secs-now) 86400)) ;; True when the YYYY-MM-DD date is strictly before today. (define (date-passed? ymd) diff --git a/glaze/main.rkt b/glaze/main.rkt index 229c99a..af36eee 100644 --- a/glaze/main.rkt +++ b/glaze/main.rkt @@ -1,5 +1,15 @@ #lang racket/base +;; Public application facade. +;; +;; New applications should normally `(require glaze)` rather than depend on +;; platform backend modules or the repository's internal layout. The facade +;; remains deliberately broad during the 0.x stabilization period so existing +;; focused imports and exported bindings keep working while public/internal +;; boundaries are documented and tested. +;; +;; See docs/architecture.md for the dependency and stability rules. + (require "server.rkt" "api.rkt" "api-macros.rkt" diff --git a/glaze/server.rkt b/glaze/server.rkt index 6b4bf3a..b4f7aff 100644 --- a/glaze/server.rkt +++ b/glaze/server.rkt @@ -23,9 +23,11 @@ racket/file racket/match racket/path + racket/port racket/string racket/tcp "api.rkt" + "assets.rkt" "events.rkt") (provide start-dev-server @@ -60,13 +62,42 @@ #:api [api-routes '()] #:events [event-bus #f] #:api-token [api-token #f] + #:bootstrap-token [bootstrap-token api-token] #:serve-api-client? [serve-client? #t]) + (unless (and (exact-integer? port) (<= 1 port 65535)) + (raise-argument-error 'start-server "exact-integer? in [1, 65535]" port)) + (unless (or (path? public-dir) (string? public-dir)) + (raise-argument-error 'start-server "(or/c path? string?)" public-dir)) + (unless (and (list? api-routes) (andmap route? api-routes)) + (raise-argument-error 'start-server "(listof route?)" api-routes)) (when (and event-bus (not (event-bus? event-bus))) - (raise-argument-error 'start-server "event-bus?" event-bus)) - (when (and api-token (not (string? api-token))) - (raise-argument-error 'start-server "(or/c #f string?)" api-token)) + (raise-argument-error 'start-server "(or/c #f event-bus?)" event-bus)) + (define (valid-capability-token? v) + (and (string? v) + (regexp-match? #px"^[A-Za-z0-9._~-]+$" v))) + (when (and api-token (not (valid-capability-token? api-token))) + (raise-argument-error + 'start-server + "(or/c #f non-empty cookie/header-safe token string)" + api-token)) + (when (and bootstrap-token (not (valid-capability-token? bootstrap-token))) + (raise-argument-error + 'start-server + "(or/c #f non-empty cookie/header-safe bootstrap token string)" + bootstrap-token)) + (when (and bootstrap-token (not api-token)) + (raise-arguments-error + 'start-server + "bootstrap token requires an API token" + "bootstrap-token" bootstrap-token)) + (unless (boolean? serve-client?) + (raise-argument-error 'start-server "boolean?" serve-client?)) + (define resolved-public-dir (resolve-public-dir public-dir)) (define dispatcher - (make-dispatcher public-dir api-routes port event-bus serve-client? api-token)) (define shutdown-server (serve #:dispatch dispatcher #:port port #:listen-ip "127.0.0.1")) + (make-dispatcher resolved-public-dir api-routes port event-bus serve-client? + api-token bootstrap-token)) + (define shutdown-server + (serve #:dispatch dispatcher #:port port #:listen-ip "127.0.0.1")) ;; `serve` accepts the port synchronously but the accepting loop runs in a ;; background thread; if that thread dies (e.g. bind race), callers saw ;; only "connection refused" much later. Prove the listener is accepting @@ -98,52 +129,99 @@ [else (sleep 0.02) (loop)]))) (unless accepting? (shutdown-server) - (raise-arguments-error - 'start-server - (format "listener on port ~a did not start accepting within ~as" - port listen-wait-secs) - "port" port))) + ;; Treat a listener that failed to become reachable as a network startup + ;; failure so run-app's random-port allocator can retry a race rather than + ;; surfacing a misleading argument error. + (raise + (exn:fail:network + (format "start-server: listener on port ~a did not start accepting within ~as" + port listen-wait-secs) + (current-continuation-marks))))) ;; ---- Host-header validation (DNS-rebinding guard) ---- -(define (host-allowed? req port) +(define (string-index-of s ch) + (for/or ([c (in-string s)] [i (in-naturals)] #:when (char=? c ch)) i)) + +;; Parse a Host header without confusing the colons inside a bracketed IPv6 +;; literal with the optional :port separator. Hostnames are case-insensitive. +(define (host-string-allowed? host) + (define s (string-downcase (string-trim host))) + (define bare + (cond + ;; Be liberal for raw clients even though HTTP normally brackets IPv6. + [(string=? s "::1") "::1"] + [(regexp-match #px"^\\[([^\\]]+)\\](?::[0-9]+)?$" s) + => (lambda (m) (second m))] + [else + (define colon (string-index-of s #\:)) + (if colon (substring s 0 colon) s)])) + (and (member bare '("127.0.0.1" "localhost" "::1")) #t)) + +(define (host-allowed? req _port) (define h (headers-assq #"Host" (request-headers/raw req))) (cond - ;; No Host header (ancient clients, raw sockets): nothing was spoofed. + ;; No Host header (ancient clients, raw sockets): browsers always send one, + ;; so this does not weaken the DNS-rebinding boundary for web content. [(not h) #t] [else - (define host (bytes->string/latin-1 (header-value h))) - (define bare (if (string-contains? host ":") - (substring host 0 (string-index-of host #\:)) - host)) - (member bare (list "127.0.0.1" "localhost" "[::1]" "::1"))])) - -(define (string-index-of s ch) - (for/or ([c (in-string s)] [i (in-naturals)] #:when (char=? c ch)) i)) + (host-string-allowed? (bytes->string/latin-1 (header-value h)))])) + +;; Browser capability calls must originate from this exact local server. +;; Ports are part of Origin, so another localhost web app cannot reuse the +;; session cookie to drive Glaze APIs. Programmatic clients without Origin +;; continue to authenticate with X-Glaze-Token. +(define (origin-allowed? req port) + (define h (headers-assq #"Origin" (request-headers/raw req))) + (cond + [(not h) #t] + [else + (define origin + (string-downcase + (string-trim (bytes->string/latin-1 (header-value h))))) + (member origin + (list (format "http://127.0.0.1:~a" port) + (format "http://localhost:~a" port) + (format "http://[::1]:~a" port)))])) ;; ---- dispatcher ---- -(define (make-dispatcher public-dir api-routes port event-bus serve-client? api-token) +(define (make-dispatcher public-dir api-routes port event-bus serve-client? + api-token bootstrap-token) + (define bootstrap-lock (make-semaphore 1)) + (define bootstrap-live? (box (and bootstrap-token #t))) + + (define (consume-bootstrap! req) + (and bootstrap-token + (call-with-semaphore + bootstrap-lock + (lambda () + (and (unbox bootstrap-live?) + (bootstrap-request? req bootstrap-token) + (begin + (set-box! bootstrap-live? #f) + #t)))))) + (lambda (conn req) + (define api-request? (api-matches? api-routes req)) + (define event-request? (and event-bus (sse-request? req))) + (define capability-request? (or api-request? event-request?)) (define resp (cond - [(not (host-allowed? req port)) (error-response 403 "host not allowed")] - ;; One-time bootstrap: the capability URL (?glaze-token=..., opened by - ;; run-app) exchanges the token for an HttpOnly cookie and redirects - ;; to the clean path. api.js no longer hands the token out, so a - ;; casual local prober that can read openly-served endpoints still - ;; cannot mint a cookie. - [(and api-token (bootstrap-request? req api-token)) - (bootstrap-response req)] - ;; The token guards capabilities (API routes + the event stream), - ;; not resources: static files and the api.js bootstrap stay open — - ;; the page received its cookie via the bootstrap redirect above. - [(and api-token (pair? api-routes) (not (token-ok? req api-token)) - (or (api-matches? api-routes req) - (and event-bus (sse-request? req)))) + [(not (host-allowed? req port)) + (error-response 403 "host not allowed")] + [(and capability-request? (not (origin-allowed? req port))) + (error-response 403 "origin not allowed")] + ;; The bootstrap nonce is single-use and distinct from the long-lived + ;; API token when run-app creates the server. A direct start-server + ;; call keeps backward compatibility by defaulting bootstrap-token to + ;; api-token, while still consuming it after the first exchange. + [(consume-bootstrap! req) + (bootstrap-response req api-token)] + [(and api-token capability-request? (not (token-ok? req api-token))) (error-response 401 "missing or invalid glaze token")] - [(find-api-response api-routes req)] - [(and event-bus (sse-request? req)) (sse-response event-bus)] + [api-request? (find-api-response api-routes req)] + [event-request? (sse-response event-bus)] [(and serve-client? (api-client-request? req)) (api-client-response api-routes api-token)] [(directory-exists? public-dir) (serve-static-file public-dir req)] @@ -189,21 +267,20 @@ ;; 302 back to the same path (query dropped), setting the cookie the page ;; will use for API + SSE calls. A wrong token in the query never matches ;; and falls through to the normal flow — no cookie is minted. -(define (bootstrap-response req) +(define (bootstrap-response req api-token) (define target (string-append "/" (url-path-string (request-uri req)))) - (define token - (for/or ([kv (in-list (url-query (request-uri req)))] - #:when (eq? (car kv) bootstrap-param)) - (cdr kv))) - (response/full 302 #"Found" (current-seconds) - #"text/plain; charset=utf-8" - (list (header #"Location" (string->bytes/latin-1 target)) - (header #"Set-Cookie" - (string->bytes/latin-1 - (format "glaze_token=~a; Path=/; HttpOnly; SameSite=Strict" - token)))) - (list (string->bytes/utf-8 (format "Redirecting to ~a\n" target))))) + (response/full + 302 #"Found" (current-seconds) + #"text/plain; charset=utf-8" + (list (header #"Location" (string->bytes/latin-1 target)) + (header #"Cache-Control" #"no-store") + (header #"Referrer-Policy" #"no-referrer") + (header #"Set-Cookie" + (string->bytes/latin-1 + (format "glaze_token=~a; Path=/; HttpOnly; SameSite=Strict" + api-token)))) + (list (string->bytes/utf-8 (format "Redirecting to ~a\n" target))))) (define (sse-request? req) (and (bytes=? (request-method req) #"GET") @@ -268,23 +345,35 @@ (define (generate-api-client api-routes) (define entries (for/list ([r (in-list api-routes)]) - (define method (route-method r)) + (define method-str (symbol->string (route-method r))) (define segments (route-segments r)) + ;; Generated JavaScript uses positional internal parameter names rather + ;; than route parameter text. A route like :user-id must not produce an + ;; illegal JS identifier such as `function(user-id, ...)`. + (define param-count + (for/sum ([seg (in-list segments)]) (if (param? seg) 1 0))) (define args - (for/list ([seg (in-list segments)] #:when (param? seg)) - (param-id seg))) + (append (for/list ([i (in-range param-count)]) (format "p~a" i)) + '("body"))) + (define next-param 0) + (define url-pieces + (for/list ([seg (in-list segments)]) + (cond + [(param? seg) + (define i next-param) + (set! next-param (add1 next-param)) + (format "encodeURIComponent(p~a)" i)] + [else + ;; jsexpr->string gives us a correctly escaped JS string literal. + (jsexpr->string seg)]))) (define url-expr - (string-join - (for/list ([seg (in-list segments)]) - (if (param? seg) - (string-append "'+encodeURIComponent(" (param-id seg) ")+'") - seg)) - "/")) - (define method-str (symbol->string method)) - (format " ~a: function(~a) { return glaze.call('~a', '~a', ~a); }," - (route->js-name segments) - (string-join (append args '("body")) ", ") - method-str + (if (null? url-pieces) + "\"\"" + (string-join url-pieces " + '/' + "))) + (format " ~a: function(~a) { return glaze.call(~a, ~a, ~a); }," + (jsexpr->string (route->js-name segments)) + (string-join args ", ") + (jsexpr->string method-str) url-expr (if (string=? method-str "GET") "null" "body")))) (string-append @@ -330,7 +419,7 @@ (apply string-append (for/list ([seg (in-list drop-api)] [i (in-naturals)]) (cond - [(param? seg) (string-titlecase (param-id seg))] + [(param? seg) (js-camel (param-id seg) #f)] [(zero? i) (js-camel seg #t)] [else (js-camel seg #f)])))) @@ -350,36 +439,73 @@ (lambda (e) (error-response 400 (exn-message e)))] [exn:fail? (lambda (e) + ;; Preserve diagnostic detail for the trusted + ;; reporter, but never expose arbitrary exception + ;; text to the WebView/browser response. ((current-glaze-error-reporter) e (url-path-string (request-uri req))) - (error-response 500 (exn-message e)))]) + (error-response 500 "internal server error"))]) (define result (apply (route-handler r) req captured)) (cond [(response? result) result] [else (api-response result)]))))) +;; Return #t when candidate is at or below root after path normalization. +;; `find-relative-path` also handles Windows drive boundaries for us. +(define (path-contained? root candidate) + (define rel (find-relative-path root candidate)) + (and (relative-path? rel) + (for/and ([part (in-list (explode-path rel))]) + (not (eq? part 'up))))) + +;; Build a request path below public-dir and prove it cannot escape. Existing +;; files are normalized through the filesystem as a second check so a symlink +;; inside public/ cannot expose a file outside the public root. +(define (safe-public-candidate dir segments) + (with-handlers ([exn:fail? (lambda (e) #f)]) + (define root (simplify-path (path->complete-path dir) #t)) + (define candidate + (simplify-path (apply build-path root segments) #f)) + (and (path-contained? root candidate) + (cond + [(file-exists? candidate) + (define resolved (simplify-path candidate #t)) + (and (path-contained? root resolved) resolved)] + [else candidate])))) + (define (serve-static-file dir req) (define uri-path (url-path (request-uri req))) - (define segments (filter (lambda (s) (not (equal? s ""))) (map path/param-path uri-path))) + (define segments + (filter (lambda (s) (not (equal? s ""))) + (map path/param-path uri-path))) (define rel (if (null? segments) '("index.html") segments)) - (define candidate (apply build-path dir rel)) + (define candidate (safe-public-candidate dir rel)) (cond + [(not candidate) + (error-response 403 "path not allowed")] [(and (file-exists? candidate) (not (directory-exists? candidate))) (make-file-response candidate)] [else - (define fallback (build-path dir "index.html")) - (if (file-exists? fallback) + (define fallback (safe-public-candidate dir '("index.html"))) + (if (and fallback (file-exists? fallback)) (make-file-response fallback) (make-404-response))])) +;; Stream static assets directly from disk to the HTTP output port. The old +;; `file->bytes` response loaded the entire asset into the Racket heap first, +;; which scaled poorly for video, WebAssembly, source maps, and other large +;; frontend assets. (define (make-file-response path) - (define data (file->bytes path)) (define mime (path->mime-type path)) - (response/full 200 #"OK" (current-seconds) mime '() (list data))) + (response 200 #"OK" (current-seconds) mime '() + (lambda (out) + (call-with-input-file path + (lambda (in) (copy-port in out)) + #:mode 'binary)))) (define (make-404-response) (response/full 404 @@ -417,3 +543,7 @@ [(member ext '(#".mp3")) #"audio/mpeg"] [(member ext '(#".map")) #"application/json; charset=utf-8"] [else #"application/octet-stream"])) + +(module+ test-support + (provide host-string-allowed? + safe-public-candidate)) \ No newline at end of file diff --git a/glaze/sys/main.rkt b/glaze/sys/main.rkt index a948cbb..3eaa274 100644 --- a/glaze/sys/main.rkt +++ b/glaze/sys/main.rkt @@ -1,12 +1,9 @@ #lang racket/base ;; glaze/sys — desktop-system integrations beyond the tray: clipboard, -;; notifications, opening/revealing paths, single-instance locking, and -;; (via the webview module) window controls. Same platform-dispatch shape -;; as glaze/tray and glaze/webview. +;; notifications, opening/revealing paths, and single-instance locking. -(require racket/file - racket/system) +(require racket/tcp) (provide sys-supported? clipboard-set! @@ -16,8 +13,6 @@ reveal-path single-instance?) -;; ---- platform backend dispatch ---- - (define (backend-module-path) (case (system-type 'os) [(macosx) 'glaze/sys/sys-macos] @@ -43,53 +38,75 @@ (with-handlers ([exn:fail? (lambda (e) #f)]) ((ref 'supported?)))) -;; ---- clipboard ---- - -;; Place text on the system clipboard. Returns #t on success. +;; Platform failures are best-effort values, but caller type errors remain +;; visible contracts instead of being swallowed into #f/"". (define (clipboard-set! text) + (unless (string? text) + (raise-argument-error 'clipboard-set! "string?" text)) (with-handlers ([exn:fail? (lambda (e) #f)]) ((ref 'clipboard-set!) text))) -;; Read text from the system clipboard; "" when empty/absent. (define (clipboard-get) (with-handlers ([exn:fail? (lambda (e) "")]) ((ref 'clipboard-get)))) -;; ---- notifications ---- - -;; Show a desktop notification. Returns #t if a delivery mechanism ran -;; (delivery itself is best-effort — OS settings may suppress it). (define (notify! title [body ""] #:subtitle [subtitle ""]) + (unless (string? title) + (raise-argument-error 'notify! "string?" title)) + (unless (string? body) + (raise-argument-error 'notify! "string?" body)) + (unless (string? subtitle) + (raise-argument-error 'notify! "string?" subtitle)) (with-handlers ([exn:fail? (lambda (e) #f)]) ((ref 'notify!) title body subtitle))) -;; ---- opening files / URLs ---- +(define (path-argument->string who p) + (cond + [(path? p) (path->string p)] + [(string? p) p] + [else (raise-argument-error who "(or/c path? string?)" p)])) -;; Open a path or URL with the OS default handler. Returns #t if the -;; launcher subprocess succeeded. (define (open-path p) + (define s (path-argument->string 'open-path p)) (with-handlers ([exn:fail? (lambda (e) #f)]) - ((ref 'open-path) (if (path? p) (path->string p) p)))) + ((ref 'open-path) s))) -;; Reveal a file in Finder / Explorer / the file manager (selecting it). (define (reveal-path p) + (define s (path-argument->string 'reveal-path p)) (with-handlers ([exn:fail? (lambda (e) #f)]) - ((ref 'reveal-path) (if (path? p) (path->string p) p)))) + ((ref 'reveal-path) s))) ;; ---- single instance ---- -;; Adjudicate "am I the first instance of app-id?" without leaving files -;; behind: derive a deterministic TCP port from the id and hold a listener -;; on it for the process lifetime. The second instance's bind fails. -;; Returns #t for the first instance, #f if another process already holds -;; the lock. (A firewall prompt is possible on first run on some systems.) -(define (single-instance? app-id) - (define h (equal-hash-code app-id)) - (define port (+ 49152 (modulo h 16384))) - (with-handlers ([exn:fail:network? (lambda (e) #f)]) - (define cust (make-custodian)) - (parameterize ([current-custodian cust]) - (tcp-listen port 1 #f "127.0.0.1")) - #t)) +(define instance-locks (make-hash)) +(define instance-locks-sema (make-semaphore 1)) -(require racket/tcp) +(define (app-id->lock-port app-id) + (define h + (for/fold ([h 2166136261]) + ([b (in-bytes (string->bytes/utf-8 app-id))]) + (bitwise-and (* (bitwise-xor h b) 16777619) #xffffffff))) + (+ 49152 (modulo h 16384))) + +;; Hold a deterministic loopback listener strongly for the process lifetime. +;; This is intentionally a lightweight 0.x lock rather than an OS-specific IPC +;; protocol; collisions with an unrelated process conservatively report #f. +(define (single-instance? app-id) + (unless (and (string? app-id) (positive? (string-length app-id))) + (raise-argument-error 'single-instance? "non-empty-string?" app-id)) + (call-with-semaphore + instance-locks-sema + (lambda () + (cond + [(hash-has-key? instance-locks app-id) #f] + [else + (define cust (make-custodian)) + (with-handlers ([exn:fail:network? + (lambda (e) + (custodian-shutdown-all cust) + #f)]) + (define listener + (parameterize ([current-custodian cust]) + (tcp-listen (app-id->lock-port app-id) 1 #f "127.0.0.1"))) + (hash-set! instance-locks app-id (cons cust listener)) + #t)])))) diff --git a/glaze/sys/sys-linux.rkt b/glaze/sys/sys-linux.rkt index 2d53c79..f9c53e1 100644 --- a/glaze/sys/sys-linux.rkt +++ b/glaze/sys/sys-linux.rkt @@ -31,36 +31,49 @@ (if version (format ".~a" version) ""))))))) (define gtk-lib (try-ffi-lib "gtk-3" "0")) +(define gdk-lib (try-ffi-lib "gdk-3" "0")) (define gobject-lib (try-ffi-lib "gobject-2.0" "0")) (define (maybe-bind lib name type) (and lib (get-ffi-obj name lib type (lambda () #f)))) +(define gdk_atom_intern_static_string + (maybe-bind gdk-lib "gdk_atom_intern_static_string" (_fun _string -> _pointer))) (define gtk_clipboard_get - (maybe-bind gtk-lib "gtk_clipboard_get" (_fun _int -> _pointer))) + (maybe-bind gtk-lib "gtk_clipboard_get" (_fun _pointer -> _pointer))) (define gtk_clipboard_set_text (maybe-bind gtk-lib "gtk_clipboard_set_text" (_fun _pointer _string _int -> _void))) (define gtk_clipboard_wait_for_text (maybe-bind gtk-lib "gtk_clipboard_wait_for_text" (_fun _pointer -> _string))) -(define CLIPBOARD 69) ; GDK_SELECTION_CLIPBOARD atom id on X11 +(define (clipboard-atom) + (and gdk_atom_intern_static_string + (gdk_atom_intern_static_string "CLIPBOARD"))) (define (supported?) - (and (eq? (system-type 'os) 'unix) gtk-lib gtk_clipboard_get #t)) + (and (eq? (system-type 'os) 'unix) + gtk-lib gdk-lib gtk_clipboard_get gdk_atom_intern_static_string #t)) (define (clipboard-set! text) - (define cb (gtk_clipboard_get CLIPBOARD)) - (and cb (begin (gtk_clipboard_set_text cb text (string-length text)) #t))) + (define atom (clipboard-atom)) + (define cb (and atom (gtk_clipboard_get atom))) + ;; -1 asks GTK to measure the NUL-terminated UTF-8 byte string correctly; + ;; Racket string-length counts characters, not bytes. + (and cb (begin (gtk_clipboard_set_text cb text -1) #t))) (define (clipboard-get) - (define cb (gtk_clipboard_get CLIPBOARD)) + (define atom (clipboard-atom)) + (define cb (and atom (gtk_clipboard_get atom))) (and cb (or (gtk_clipboard_wait_for_text cb) ""))) (define (notify! title body subtitle) (define n (find-executable-path "notify-send")) (and n - (if (non-empty-string? subtitle) - (system* n title body (string-append "-h" subtitle)) - (system* n title body)))) + ;; notify-send has summary + body, but no portable subtitle flag. Keep + ;; the subtitle as visible text instead of passing a malformed -h hint. + (system* n title + (if (non-empty-string? subtitle) + (string-append subtitle "\n" body) + body)))) (define (open-path p) (define x (find-executable-path "xdg-open")) @@ -68,4 +81,9 @@ (define (reveal-path p) (define x (find-executable-path "xdg-open")) - (and x (system* x (path->string (path-only (string->path p)))))) + (define pp (path->complete-path (if (path? p) p (string->path p)))) + (define target + (if (directory-exists? pp) + pp + (or (path-only pp) (current-directory)))) + (and x (system* x (path->string target)))) diff --git a/glaze/sys/sys-macos.rkt b/glaze/sys/sys-macos.rkt index 71b66ab..43955ae 100644 --- a/glaze/sys/sys-macos.rkt +++ b/glaze/sys/sys-macos.rkt @@ -50,14 +50,22 @@ "")))) (define (notify! title body subtitle) - (define script - (format "display notification ~s with title ~s~a" - body title - (if (non-empty-string? subtitle) - (format " subtitle ~s" subtitle) - ""))) (define osa (find-executable-path "osascript")) - (and osa (system* osa "-e" script))) + (define script + (string-append + "on run argv\n" + " set bodyText to item 1 of argv\n" + " set titleText to item 2 of argv\n" + " set subtitleText to item 3 of argv\n" + " if subtitleText is \"\" then\n" + " display notification bodyText with title titleText\n" + " else\n" + " display notification bodyText with title titleText subtitle subtitleText\n" + " end if\n" + "end run")) + ;; User-controlled notification text travels as argv, never as AppleScript + ;; source, so quotes/backslashes cannot change the script. + (and osa (system* osa "-e" script "--" body title subtitle))) (define (open-path p) (define o (find-executable-path "open")) diff --git a/glaze/sys/sys-windows.rkt b/glaze/sys/sys-windows.rkt index 7b5e365..24aedb4 100644 --- a/glaze/sys/sys-windows.rkt +++ b/glaze/sys/sys-windows.rkt @@ -38,26 +38,42 @@ (get-ffi-obj "GlobalUnlock" kernel32 (_fun _pointer -> _bool))) (define GlobalSize (get-ffi-obj "GlobalSize" kernel32 (_fun _pointer -> _uintptr))) +(define GlobalFree + (get-ffi-obj "GlobalFree" kernel32 (_fun _pointer -> _pointer))) (define CF_UNICODETEXT 13) (define GMEM_MOVEABLE 2) -;; UTF-16 helpers (bytes-open-converter is one-directional). -(define conv (bytes-open-converter "platform-UTF-8" "platform-UTF-16")) -(define (wstr s) - (define-values (out _in _status) (bytes-convert conv (string->bytes/utf-8 s))) - (define n (bytes-length out)) - (define p (malloc _uint8 (+ n 2) 'raw)) - (memcpy p out n) - (ptr-set! p _uint16 (quotient n 2) 0) - p) +;; UTF-16 helpers. +(define (utf16-bytes s) + (define cv (bytes-open-converter "UTF-8" "UTF-16LE")) + (define in (string->bytes/utf-8 s)) + (define-values (out consumed status) (bytes-convert cv in)) + (unless (and (eq? status 'complete) (= consumed (bytes-length in))) + (error 'clipboard-set! "UTF-16 conversion failed")) + (bytes-append out #"\0\0")) + +;; Decode UTF-16 code units, including surrogate pairs. The previous helper +;; treated each 16-bit unit as a Unicode scalar, corrupting non-BMP text. (define (wstr->string p) (and p (let loop ([i 0] [chars '()]) (define u (ptr-ref p _uint16 i)) - (if (zero? u) - (list->string (reverse chars)) - (loop (add1 i) (cons (integer->char u) chars)))))) + (cond + [(zero? u) (list->string (reverse chars))] + [(<= #xD800 u #xDBFF) + (define v (ptr-ref p _uint16 (add1 i))) + (if (<= #xDC00 v #xDFFF) + (let ([cp (+ #x10000 + (arithmetic-shift (- u #xD800) 10) + (- v #xDC00))]) + (loop (+ i 2) (cons (integer->char cp) chars))) + (loop (add1 i) (cons #\uFFFD chars)))] + [(<= #xDC00 u #xDFFF) + (loop (add1 i) (cons #\uFFFD chars))] + [else + (loop (add1 i) (cons (integer->char u) chars))])))) + (define (supported?) (and (eq? (system-type 'os) 'windows) #t)) @@ -65,16 +81,24 @@ (define (clipboard-set! text) (and (OpenClipboard #f) (dynamic-wind - (lambda () (void)) + void (lambda () (EmptyClipboard) - (define p (wstr text)) - (define bytes-n (+ 2 (* 2 (length (string->list text))))) - (define h (GlobalAlloc GMEM_MOVEABLE bytes-n)) - (define dst (GlobalLock h)) - (memcpy dst p bytes-n) - (GlobalUnlock h) - (not (zero? (cast (SetClipboardData CF_UNICODETEXT h) _pointer _intptr)))) + (define data (utf16-bytes text)) + (define h (GlobalAlloc GMEM_MOVEABLE (bytes-length data))) + (and h + (let ([dst (GlobalLock h)]) + (cond + [(not dst) + (GlobalFree h) + #f] + [else + (memcpy dst data (bytes-length data)) + (GlobalUnlock h) + (define result (SetClipboardData CF_UNICODETEXT h)) + ;; Ownership transfers to the clipboard only on success. + (unless result (GlobalFree h)) + (and result #t)])))) (lambda () (CloseClipboard))))) (define (clipboard-get) diff --git a/glaze/tray/main.rkt b/glaze/tray/main.rkt index 24ced2c..d0ce4f0 100644 --- a/glaze/tray/main.rkt +++ b/glaze/tray/main.rkt @@ -1,16 +1,7 @@ #lang racket/base -;; Public tray API. Dispatches to a platform-specific backend based on -;; (system-type 'os): -;; - 'windows -> tray-windows.rkt (Shell_NotifyIconW via ffi/unsafe) -;; - 'macosx -> tray-macos.rkt (NSStatusItem via ffi/unsafe/objc) [stub for now] -;; - 'unix -> trayay-linux.rkt (libayatana-appindicator via ffi/unsafe) [stub for now] -;; -;; Every backend exports the SAME procedure names (make-tray, set-tooltip!, -;; set-icon!, set-menu!, close, supported?) and performs its own platform / -;; library gating. If a backend's make-tray raises (native deps missing or not -;; implemented), the dispatcher catches it, warns, and retries against the stub -;; so callers always get a usable (possibly inert) handle. +;; Public tray API. Platform-specific native code remains behind this module; +;; application-facing values are validated before they reach FFI. (require "tray-protocol.rkt") @@ -23,15 +14,10 @@ tray-set-menu! tray-close tray-supported? - ;; re-export protocol surface for menu construction (all-from-out "tray-protocol.rkt")) -;; A tray handle wraps the backend-specific handle together with the backend -;; tag, so `tray-backend` introspection (and tests) can tell which -;; implementation is live without poking native resources. (struct tray (backend handle) #:transparent) -;; Pick the backend module path for the current OS. (define (backend-module-path) (case (system-type 'os) [(windows) 'glaze/tray/tray-windows] @@ -39,9 +25,6 @@ [(unix) 'glaze/tray/tray-linux] [else 'glaze/tray/tray-stub])) -;; Cached proc table for the active backend: name symbol -> procedure. We load -;; lazily on first use so requiring glaze/tray on a host platform never drags -;; in another platform's backend (which could fail at require time). (define backend-procs #f) (define (load-backend!) @@ -52,15 +35,17 @@ (hash-set! backend-procs name (dynamic-require mod name)))) backend-procs) -;; Load the stub's procs under a separate table, used for fallback. +(define stub-procs #f) + (define (load-stub-procs) - (define tbl (make-hash)) - (for ([name (in-list '(make-tray set-tooltip! set-icon! set-menu! close supported?))]) - ;; Stub exports use a `stub:` prefix. - (hash-set! tbl - name - (dynamic-require 'glaze/tray/tray-stub (string->symbol (format "stub:~a" name))))) - tbl) + (unless stub-procs + (set! stub-procs (make-hash)) + (for ([name (in-list '(make-tray set-tooltip! set-icon! set-menu! close supported?))]) + (hash-set! stub-procs + name + (dynamic-require 'glaze/tray/tray-stub + (string->symbol (format "stub:~a" name)))))) + stub-procs) (define (ref name tbl) (hash-ref tbl name)) @@ -69,12 +54,21 @@ (with-handlers ([exn:fail? (lambda (e) #f)]) ((ref 'supported? (load-backend!))))) -;; Track whether we have fallen back to the stub so subsequent mutators also -;; use the stub procs (per-process: a host with no native backend stays inert). -(define using-stub? (box #f)) +(define (check-tray who t) + (unless (tray? t) + (raise-argument-error who "tray?" t))) + +(define (check-icon who icon-path) + (unless (or (not icon-path) (path? icon-path) (string? icon-path)) + (raise-argument-error who "(or/c #f path? string?)" icon-path))) + +(define (check-items who items) + (unless (and (list? items) (andmap menu-item? items)) + (raise-argument-error who "(listof menu-item?)" items))) -(define (current-table) - (if (unbox using-stub?) +(define (table-for-tray t) + (check-tray 'tray-operation t) + (if (eq? (tray-backend t) 'stub) (load-stub-procs) (load-backend!))) @@ -82,24 +76,31 @@ #:tooltip tooltip #:menu items #:on-event [on-event (lambda (e) (void))]) - (with-handlers ([exn:fail? (lambda (e) - (fprintf (current-error-port) - "[glaze] tray backend unavailable (~a); using no-op stub.\n" - (exn-message e)) - (set-box! using-stub? #t) - (define tbl (load-stub-procs)) - (tray 'stub - ((ref 'make-tray tbl) #:icon icon-path - #:tooltip tooltip - #:menu items - #:on-event on-event)))]) + (check-icon 'make-tray icon-path) + (unless (string? tooltip) + (raise-argument-error 'make-tray "string?" tooltip)) + (check-items 'make-tray items) + (unless (and (procedure? on-event) (procedure-arity-includes? on-event 1)) + (raise-argument-error 'make-tray "procedure accepting one argument" on-event)) + (with-handlers ([exn:fail? + (lambda (e) + (fprintf (current-error-port) + "[glaze] tray backend unavailable (~a); using no-op stub.\n" + (exn-message e)) + (define tbl (load-stub-procs)) + (tray 'stub + ((ref 'make-tray tbl) + #:icon icon-path + #:tooltip tooltip + #:menu items + #:on-event on-event)))]) (tray (detected-backend) - ((ref 'make-tray (load-backend!)) #:icon icon-path - #:tooltip tooltip - #:menu items - #:on-event on-event)))) + ((ref 'make-tray (load-backend!)) + #:icon icon-path + #:tooltip tooltip + #:menu items + #:on-event on-event)))) -;; Backend tag for tagging purposes (does not force a reload). (define (detected-backend) (case (system-type 'os) [(windows) 'windows] @@ -108,10 +109,21 @@ [else 'stub])) (define (tray-set-tooltip! t tooltip) - ((ref 'set-tooltip! (current-table)) (tray-handle t) tooltip)) + (check-tray 'tray-set-tooltip! t) + (unless (string? tooltip) + (raise-argument-error 'tray-set-tooltip! "string?" tooltip)) + ((ref 'set-tooltip! (table-for-tray t)) (tray-handle t) tooltip)) + (define (tray-set-icon! t icon-path) - ((ref 'set-icon! (current-table)) (tray-handle t) icon-path)) + (check-tray 'tray-set-icon! t) + (check-icon 'tray-set-icon! icon-path) + ((ref 'set-icon! (table-for-tray t)) (tray-handle t) icon-path)) + (define (tray-set-menu! t items) - ((ref 'set-menu! (current-table)) (tray-handle t) items)) + (check-tray 'tray-set-menu! t) + (check-items 'tray-set-menu! items) + ((ref 'set-menu! (table-for-tray t)) (tray-handle t) items)) + (define (tray-close t) - ((ref 'close (current-table)) (tray-handle t))) + (check-tray 'tray-close t) + ((ref 'close (table-for-tray t)) (tray-handle t))) diff --git a/glaze/tray/tray-protocol.rkt b/glaze/tray/tray-protocol.rkt index addb125..be6fe15 100644 --- a/glaze/tray/tray-protocol.rkt +++ b/glaze/tray/tray-protocol.rkt @@ -1,12 +1,8 @@ #lang racket/base -;; Platform-agnostic menu/tray protocol: menu data structures and an -;; id-allocator for mapping native menu ids back to Racket callbacks. -;; Platform backends translate these structs into native menus (Win32 -;; TrackPopupMenu / menu bar, NSMenu, GtkMenu) and invoke the matching -;; callback when a menu id fires. - -(require racket/contract) +;; Platform-agnostic menu/tray protocol. Platform backends translate these +;; values into Win32, AppKit, or GTK menu objects; malformed values therefore +;; need to be rejected here, before they reach native FFI. (provide (struct-out menu-item) make-menu-item @@ -21,9 +17,6 @@ id-allocator-lookup id-allocator-clear!) -;; A menu item. Separators have label #f and id #f. Normal items carry a label, -;; a stable id (string, user-provided for stable dispatch) and an action thunk. -;; `enabled?` and `checked?` are hints the backend may honor when supported. (struct menu-item (label id action enabled? checked? accel) #:transparent) (define (make-menu-item label @@ -32,6 +25,18 @@ #:enabled? [enabled? #t] #:checked? [checked? #f] #:accel [accel #f]) + (unless (string? label) + (raise-argument-error 'make-menu-item "string?" label)) + (unless (string? id) + (raise-argument-error 'make-menu-item "string?" id)) + (unless (and (procedure? action) (procedure-arity-includes? action 0)) + (raise-argument-error 'make-menu-item "procedure accepting zero arguments" action)) + (unless (boolean? enabled?) + (raise-argument-error 'make-menu-item "boolean?" enabled?)) + (unless (boolean? checked?) + (raise-argument-error 'make-menu-item "boolean?" checked?)) + (unless (or (not accel) (string? accel)) + (raise-argument-error 'make-menu-item "(or/c #f string?)" accel)) (menu-item label id action enabled? checked? accel)) (define (menu-separator) @@ -40,41 +45,57 @@ (define (menu-separator? mi) (and (menu-item? mi) (not (menu-item-label mi)))) -;; A top-level menu (menubar title + its entries) for menu bars. `items` -;; holds menu-item? values; a menu bar is a list of `menu?` values. (struct menu (title items) #:transparent) (define (make-menu title items) + (unless (string? title) + (raise-argument-error 'make-menu "string?" title)) + (unless (and (list? items) (andmap menu-item? items)) + (raise-argument-error 'make-menu "(listof menu-item?)" items)) (menu title items)) -;; Id allocator: assigns increasing positive integers as native menu ids and -;; keeps a hash from id -> action so the backend's message handler can dispatch. -;; Backend ids must be positive integers that fit in the native menu id space -;; (Win32 HMENU uses uintptr; Gtk uses gint; NSMenuItem uses tag NSInteger). (struct id-allocator (next-box table-sema table) #:transparent) (define (make-id-allocator) (id-allocator (box 1) (make-semaphore 1) (make-hash))) +(define (check-allocator who a) + (unless (id-allocator? a) + (raise-argument-error who "id-allocator?" a))) + (define (id-allocator-next! a) + (check-allocator 'id-allocator-next! a) (define b (id-allocator-next-box a)) - (call-with-semaphore (id-allocator-table-sema a) - (lambda () - (begin0 (unbox b) - (set-box! b (add1 (unbox b))))))) + (call-with-semaphore + (id-allocator-table-sema a) + (lambda () + (begin0 (unbox b) + (set-box! b (add1 (unbox b))))))) (define (id-allocator-register! a action) + (check-allocator 'id-allocator-register! a) + (unless (and (procedure? action) (procedure-arity-includes? action 0)) + (raise-argument-error 'id-allocator-register! + "procedure accepting zero arguments" + action)) (define id (id-allocator-next! a)) - (call-with-semaphore (id-allocator-table-sema a) - (lambda () (hash-set! (id-allocator-table a) id action))) + (call-with-semaphore + (id-allocator-table-sema a) + (lambda () (hash-set! (id-allocator-table a) id action))) id) (define (id-allocator-lookup a id) - (call-with-semaphore (id-allocator-table-sema a) - (lambda () (hash-ref (id-allocator-table a) id (lambda () #f))))) + (check-allocator 'id-allocator-lookup a) + (unless (exact-positive-integer? id) + (raise-argument-error 'id-allocator-lookup "exact-positive-integer?" id)) + (call-with-semaphore + (id-allocator-table-sema a) + (lambda () (hash-ref (id-allocator-table a) id (lambda () #f))))) (define (id-allocator-clear! a) - (call-with-semaphore (id-allocator-table-sema a) - (lambda () - (hash-clear! (id-allocator-table a)) - (set-box! (id-allocator-next-box a) 1)))) + (check-allocator 'id-allocator-clear! a) + (call-with-semaphore + (id-allocator-table-sema a) + (lambda () + (hash-clear! (id-allocator-table a)) + (set-box! (id-allocator-next-box a) 1)))) diff --git a/glaze/update.rkt b/glaze/update.rkt index 4c310a4..5fc0049 100644 --- a/glaze/update.rkt +++ b/glaze/update.rkt @@ -1,20 +1,8 @@ #lang racket/base -;; Update checking: fetch a version manifest over HTTP(S), compare with the -;; running version, report availability. Glaze deliberately stops here — -;; downloading and replacing a running app is a per-distribution decision -;; (notarized DMG, MSI upgrade, AppImage overwrite); the app decides what -;; an "update-available" event means. -;; -;; Manifest format (JSON): -;; {"version": "1.2.0", "url": "https://.../releases/1.2.0", "notes": "...", -;; "sha256": ""} ; optional but -;; recommended for paid distribution: verify the download with -;; (verify-file-sha256 artifact sha256) before swapping it in. -;; -;; (check-update "https://example.com/app/manifest.json" -;; #:current-version "1.0.0") -;; => (hasheq 'version "1.2.0" 'url "..." 'notes "..." 'sha256 "...") or #f +;; Update checking: fetch a small version manifest over HTTP(S), compare with +;; the running version, and report availability. Download/replacement remains a +;; distribution-specific application decision. (require json racket/list @@ -28,32 +16,91 @@ verify-file-sha256) (define manifest-timeout-secs 5) +(define max-manifest-bytes (* 1024 1024)) +(define numeric-version-rx #px"^[0-9]+(?:[.][0-9]+)*$") +(define sha256-rx #px"^[0-9a-fA-F]{64}$") -;; -> body bytes or #f. HTTPS needs the openssl collection; absent TLS -;; support degrades to #f (caller treats as "no update info"). +(define (numeric-version? v) + (and (string? v) (regexp-match? numeric-version-rx v))) + +;; Timeout work under a private custodian so timeout also tears down the +;; socket/worker instead of leaving a blocked background thread behind. +(define (call-with-timeout secs thunk) + (define cust (make-custodian)) + (define ch (make-channel)) + (parameterize ([current-custodian cust]) + (thread + (lambda () + (define result + (with-handlers ([exn:fail? (lambda (e) #f)]) + (thunk))) + (channel-put ch result)))) + (define result (sync/timeout secs ch)) + (custodian-shutdown-all cust) + result) + +(define (status-success? status-line) + (and (bytes? status-line) + (regexp-match? #px#"^HTTP/[0-9.]+ 2[0-9][0-9](?: |$)" status-line))) + +;; Network input ports are allowed to return short reads before EOF. Read in +;; chunks until the response ends or exceeds the hard size limit. +(define (read-limited-body in) + (define out (open-output-bytes)) + (let loop ([total 0]) + (define chunk (read-bytes 65536 in)) + (cond + [(eof-object? chunk) (get-output-bytes out)] + [else + (define next (+ total (bytes-length chunk))) + (cond + [(> next max-manifest-bytes) #f] + [else + (write-bytes chunk out) + (loop next)])]))) + +;; -> body bytes or #f. Only HTTP(S) is accepted. TLS errors, non-2xx +;; responses, malformed authorities, oversized manifests and timeouts all +;; safely mean "no update information". (define (fetch-manifest url) - (with-handlers ([exn:fail? (lambda (e) #f)]) - (define m (regexp-match #rx"^([a-zA-Z][a-zA-Z0-9+.-]*)://([^/]+)(/.*)?$" url)) - (unless m (error 'check-update "bad manifest url")) - (define scheme (list-ref m 1)) - (define authority (list-ref m 2)) - (define path (or (list-ref m 3) "/")) - (define ssl? (string-ci=? scheme "https")) - (define hostport (string-split authority ":")) - (define host (first hostport)) - (define port - (or (and (= (length hostport) 2) (string->number (second hostport))) - (if ssl? 443 80))) - (when ssl? - ;; force the openssl module to load so http-sendrecv can use it - (dynamic-require 'openssl 'ssl-connect #f)) - (define-values (_st _headers in) - (http-sendrecv host path #:port port #:ssl? (if ssl? 'auto #f))) - (begin0 - (port->bytes in) - (close-input-port in)))) + (and (string? url) + (call-with-timeout + manifest-timeout-secs + (lambda () + (define m + (regexp-match #rx"^([a-zA-Z][a-zA-Z0-9+.-]*)://([^/]+)(/.*)?$" url)) + (unless m (error 'check-update "bad manifest url")) + (define scheme (string-downcase (list-ref m 1))) + (unless (member scheme '("http" "https")) + (error 'check-update "manifest URL must use http or https")) + (define authority (list-ref m 2)) + (define path (or (list-ref m 3) "/")) + (define ssl? (string=? scheme "https")) + (define hp + (or (regexp-match #px"^\\[([^]]+)\\](?::([0-9]+))?$" authority) + (regexp-match #px"^([^:]+)(?::([0-9]+))?$" authority))) + (unless hp (error 'check-update "bad manifest authority")) + (define host (second hp)) + (define explicit-port (and (third hp) (string->number (third hp)))) + (define port (or explicit-port (if ssl? 443 80))) + (unless (and (exact-integer? port) (<= 1 port 65535)) + (error 'check-update "bad manifest port")) + (when ssl? + (dynamic-require 'openssl 'ssl-connect #f)) + (define-values (status _headers in) + (http-sendrecv host path #:port port #:ssl? (if ssl? 'auto #f))) + (dynamic-wind + void + (lambda () + (and (status-success? status) + (read-limited-body in))) + (lambda () (close-input-port in))))))) (define (check-update manifest-url #:current-version [current "0.0.0"]) + (unless (string? manifest-url) + (raise-argument-error 'check-update "string?" manifest-url)) + (unless (numeric-version? current) + (raise-argument-error 'check-update "numeric dotted version string" current)) (define body (fetch-manifest manifest-url)) (and body (let () @@ -61,36 +108,58 @@ (with-handlers ([exn:fail? (lambda (e) #f)]) (bytes->jsexpr body))) (and (hash? data) - (let ([v (hash-ref data 'version #f)]) - (and (string? v) + (let ([v (hash-ref data 'version #f)] + [u (hash-ref data 'url #f)] + [notes (hash-ref data 'notes #f)] + [sha (hash-ref data 'sha256 #f)]) + ;; A malformed remote manifest is untrusted input: ignore it + ;; rather than raising inside the application. + (and (numeric-version? v) + (string? u) + (non-empty-string? u) + (or (not notes) (string? notes)) + (or (not sha) + (and (string? sha) (regexp-match? sha256-rx sha))) (newer-version? v current) (hasheq 'version v - 'url (hash-ref data 'url #f) - 'notes (hash-ref data 'notes #f) - 'sha256 (hash-ref data 'sha256 #f)))))))) + 'url u + 'notes notes + 'sha256 sha))))))) -;; True when the file at `path` has the given SHA-256 hex digest -;; (case-insensitive). #f when openssl is missing or the file is unreadable -;; — treat #f as "cannot verify", never as "verified". +;; True when the file has the expected SHA-256 digest. #f means verification +;; failed or could not be performed; callers must never interpret #f as safe. (define (verify-file-sha256 path expected-hex) (define exe (find-executable-path "openssl" #f)) + (define p + (cond + [(path? path) path] + [(string? path) (string->path path)] + [else #f])) (and exe + p (string? expected-hex) - (file-exists? path) + (regexp-match? sha256-rx expected-hex) + (file-exists? p) (with-handlers ([exn:fail? (lambda (e) #f)]) (define out (open-output-string)) - (parameterize ([current-output-port out]) - (system*/exit-code exe "dgst" "-sha256" "-r" (path->string path))) - (define m (regexp-match #px"^([0-9a-fA-F]{64})\\b" (get-output-string out))) - (and m - (string-ci=? (second m) (string-trim expected-hex)))))) + (define code + (parameterize ([current-output-port out]) + (system*/exit-code exe "dgst" "-sha256" "-r" (path->string p)))) + (define m + (regexp-match #px"^([0-9a-fA-F]{64})\\b" (get-output-string out))) + (and (zero? code) + m + (string-ci=? (second m) expected-hex))))) ;; Numeric dotted comparison: "1.10.0" > "1.9.2"; missing segments count 0. +;; Glaze 0.x intentionally does not guess at prerelease/SemVer label ordering. (define (newer-version? candidate current) + (unless (numeric-version? candidate) + (raise-argument-error 'newer-version? "numeric dotted version string" candidate)) + (unless (numeric-version? current) + (raise-argument-error 'newer-version? "numeric dotted version string" current)) (define (segments s) - (for/list ([seg (in-list (string-split s "."))] - #:when (non-empty-string? seg)) - (or (string->number seg) 0))) + (map string->number (string-split s "."))) (define a (segments candidate)) (define b (segments current)) (define n (max (length a) (length b))) diff --git a/glaze/webview/main.rkt b/glaze/webview/main.rkt index 35b2b47..a6cd7c5 100644 --- a/glaze/webview/main.rkt +++ b/glaze/webview/main.rkt @@ -1,16 +1,8 @@ #lang racket/base -;; Public WebView API. Opens a native OS window with an embedded WebView -;; control pointing at a URL (typically the local HTTP server Glaze started). -;; Dispatches to a platform-specific backend based on (system-type 'os): -;; - 'windows -> webview-windows.rkt (Win32 window + WebView2 via COM FFI) -;; - 'macosx -> webview-macos.rkt (NSWindow + WKWebView via objc FFI) -;; - 'unix -> webview-linux.rkt (GtkWindow + WebKitGTK via FFI) -;; -;; Glaze is a desktop GUI framework: native WebView startup is part of the -;; application contract. There is deliberately no browser fallback. If a -;; backend or runtime dependency is unavailable, startup fails with actionable -;; platform-specific installation guidance. +;; Public WebView API. Glaze is GUI-first: a native WebView is mandatory and +;; startup fails with platform-specific guidance when its backend is missing. +;; Platform-specific FFI stays behind this dispatcher. (provide open-window open-webview @@ -39,11 +31,8 @@ (require "startup-feedback.rkt" (only-in "../tray/tray-protocol.rkt" menu?)) -;; A webview handle wraps the backend-specific handle + the backend tag. (struct webview (backend handle) #:transparent) -;; Keep the most recent native-backend failure so probes and higher-level -;; callers can report the real cause rather than masking it. (define last-webview-error-box (box #f)) (define (webview-last-error) @@ -93,11 +82,8 @@ "Native WebView could not start: " (webview-error->message e) "\n\n" (webview-install-guidance))) -;; Every successfully opened window, weakly held: closed + collected windows -;; disappear from all-webviews on their own. (define open-registry (make-weak-hasheq)) -;; Pick the backend module path for the current OS. (define (backend-module-path) (case (system-type 'os) [(windows) 'glaze/webview/webview-windows] @@ -120,8 +106,6 @@ (define (ref name) (hash-ref (load-backend!) name)) -;; Non-throwing capability probe. A failed probe records the reason when one -;; is available; actual startup through open-window/open-webview is fail-fast. (define (webview-supported?) (clear-webview-error!) (with-handlers ([exn:fail? (lambda (e) @@ -133,19 +117,42 @@ "the platform backend is present but its runtime dependencies are not available")) supported?)) -;; open-window: high-level entry. Native GUI is mandatory. If the platform -;; backend cannot start, the call raises with installation/repair guidance. +(define (check-open-args who url title width height devtools? background-active? + on-close) + (unless (string? url) + (raise-argument-error who "string?" url)) + (unless (string? title) + (raise-argument-error who "string?" title)) + (unless (exact-positive-integer? width) + (raise-argument-error who "exact-positive-integer?" width)) + (unless (exact-positive-integer? height) + (raise-argument-error who "exact-positive-integer?" height)) + (unless (boolean? devtools?) + (raise-argument-error who "boolean?" devtools?)) + (unless (boolean? background-active?) + (raise-argument-error who "boolean?" background-active?)) + (unless (procedure? on-close) + (raise-argument-error who "procedure?" on-close))) + +(define (check-webview who wv) + (unless (webview? wv) + (raise-argument-error who "webview?" wv))) + (define (open-window url #:title [title "Glaze"] #:width [width 1024] #:height [height 768] #:devtools? [devtools? #f] + #:background-active? [background-active? #f] #:on-close [on-close (lambda () (void))]) + (check-open-args 'open-window url title width height devtools? + background-active? on-close) (open-webview url #:title title #:width width #:height height #:devtools? devtools? + #:background-active? background-active? #:on-close on-close)) (define (open-webview url @@ -153,7 +160,10 @@ #:width [width 1024] #:height [height 768] #:devtools? [devtools? #f] + #:background-active? [background-active? #f] #:on-close [on-close (lambda () (void))]) + (check-open-args 'open-webview url title width height devtools? + background-active? on-close) (clear-webview-error!) (define h (with-handlers ([exn:fail? (lambda (e) @@ -164,6 +174,7 @@ #:width width #:height height #:devtools? devtools? + #:background-active? background-active? #:on-close on-close))) (cond [h @@ -174,8 +185,6 @@ (unless (webview-last-error) (remember-webview-error! "the native backend returned unavailable")) (define diagnostic (webview-diagnostic)) - ;; Packaged GUI apps may have no console. Show the same diagnosis in an - ;; OS-level dialog before raising; CI/automation suppresses the dialog. (show-webview-startup-error! diagnostic) (raise-user-error 'open-webview diagnostic)])) @@ -187,72 +196,82 @@ [else 'stub])) (define (webview-close wv) + (check-webview 'webview-close wv) ((ref 'close) (webview-handle wv))) (define (webview-navigate wv url) + (check-webview 'webview-navigate wv) + (unless (string? url) + (raise-argument-error 'webview-navigate "string?" url)) ((ref 'navigate) (webview-handle wv) url)) -;; ---- verification APIs ---- -;; Observe webview state programmatically — the point is that callers (and -;; agents developing Glaze apps) can assert on what the UI is showing without -;; a human at the screen. All degrade to #f where a backend cannot provide -;; the value yet. - -;; Current page title once the first navigation has committed, else #f. (define (webview-title wv) + (check-webview 'webview-title wv) ((ref 'title) (webview-handle wv))) -;; Current page URL once the first navigation has committed, else #f. (define (webview-url wv) + (check-webview 'webview-url wv) ((ref 'url) (webview-handle wv))) -;; Captures the window contents to a PNG. dest defaults to a fresh temp -;; file. Returns the path, or #f when the backend/window cannot be captured. (define (webview-capture! wv [dest #f]) + (check-webview 'webview-capture! wv) + (unless (or (not dest) (path? dest) (string? dest)) + (raise-argument-error 'webview-capture! "(or/c #f path? string?)" dest)) ((ref 'capture!) (webview-handle wv) dest)) -;; ---- window controls ---- -(define (webview-set-title! wv t) ((ref 'set-title!) (webview-handle wv) t)) +(define (webview-set-title! wv t) + (check-webview 'webview-set-title! wv) + (unless (string? t) + (raise-argument-error 'webview-set-title! "string?" t)) + ((ref 'set-title!) (webview-handle wv) t)) + (define (webview-set-size! wv width height) + (check-webview 'webview-set-size! wv) + (unless (exact-positive-integer? width) + (raise-argument-error 'webview-set-size! "exact-positive-integer?" width)) + (unless (exact-positive-integer? height) + (raise-argument-error 'webview-set-size! "exact-positive-integer?" height)) ((ref 'set-size!) (webview-handle wv) width height)) + (define (webview-set-fullscreen! wv on?) + (check-webview 'webview-set-fullscreen! wv) + (unless (boolean? on?) + (raise-argument-error 'webview-set-fullscreen! "boolean?" on?)) ((ref 'set-fullscreen!) (webview-handle wv) on?)) -(define (webview-focus! wv) ((ref 'focus!) (webview-handle wv))) +(define (webview-focus! wv) + (check-webview 'webview-focus! wv) + ((ref 'focus!) (webview-handle wv))) -;; ---- menu bar ---- -;; Replace the app's custom menus with `menus` — a list of menu? values -;; (glaze/tray/tray-protocol: make-menu + make-menu-item / menu-separator, -;; with #:action thunks and optional #:accel like "Cmd+O"). Real keystroke -;; accelerators on macOS; display-only hints on Windows/Linux (v1). (define (webview-set-menu! wv menus) + (check-webview 'webview-set-menu! wv) + (unless (and (list? menus) (andmap menu? menus)) + (raise-argument-error 'webview-set-menu! "(listof menu?)" menus)) ((ref 'set-menu!) (webview-handle wv) menus)) -;; ---- multi-window ---- - -;; True once the window is closed (either webview-close or the OS chrome). (define (webview-closed? wv) + (check-webview 'webview-closed? wv) ((ref 'closed?) (webview-handle wv))) -;; All windows this process opened that have not been garbage collected. -;; Closed-but-uncollected handles report webview-closed? = #t. (define (all-webviews) (for/list ([(wv _) (in-hash open-registry)]) wv)) -;; Close every open window (delivers #:on-close for each). (define (close-all-webviews!) (for ([wv (in-list (all-webviews))] #:unless (webview-closed? wv)) (webview-close wv))) -;; Block until every open window is closed (OS chrome closes included), or -;; until timeout-secs elapse. Returns #t when all closed, #f on timeout. (define (wait-for-webviews [timeout-secs #f]) + (unless (or (not timeout-secs) + (and (real? timeout-secs) (>= timeout-secs 0))) + (raise-argument-error 'wait-for-webviews "(or/c #f nonnegative-real?)" + timeout-secs)) (define deadline (and timeout-secs (+ (current-inexact-milliseconds) (* timeout-secs 1000)))) (let loop () - (define open (for/list ([wv (in-list (all-webviews))] - #:unless (webview-closed? wv)) - wv)) + (define open + (for/list ([wv (in-list (all-webviews))] + #:unless (webview-closed? wv)) + wv)) (cond [(null? open) #t] [(and deadline (>= (current-inexact-milliseconds) deadline)) #f] diff --git a/glaze/webview/webview-linux.rkt b/glaze/webview/webview-linux.rkt index 007787c..08d09bb 100644 --- a/glaze/webview/webview-linux.rkt +++ b/glaze/webview/webview-linux.rkt @@ -157,6 +157,7 @@ #:width [width 1024] #:height [height 768] #:devtools? [devtools? #f] + #:background-active? [background-active? #f] #:on-close [on-close (lambda () (void))]) (define (show-devtools-later!) ;; The inspector window needs the webview realized; retry briefly. diff --git a/glaze/webview/webview-macos.rkt b/glaze/webview/webview-macos.rkt index 73b795e..72adee0 100644 --- a/glaze/webview/webview-macos.rkt +++ b/glaze/webview/webview-macos.rkt @@ -89,6 +89,7 @@ (import-class NSString NSNull NSApplication + NSProcessInfo NSMenu NSMenuItem NSWindow @@ -132,7 +133,18 @@ (define NSViewHeightSizable 16) (define NSApplicationActivationPolicyRegular 0) -(struct mac:webview (window webview delegate closed?-box fullscreen?-box [thread #:mutable]) +;; WKPreferencesInactiveSchedulingPolicyNone (macOS 14+). The setter is +;; probed dynamically so this source continues to load on older macOS. +(define WKInactiveSchedulingPolicyNone 2) + +;; NSActivityUserInitiatedAllowingIdleSystemSleep. This public ProcessInfo +;; activity suppresses App Nap / timer throttling for monitoring-style apps +;; while still allowing normal idle system sleep. It is opt-in and paired with +;; endActivity: on window close. +(define NSActivityUserInitiatedAllowingIdleSystemSleep #x00EFFFFF) + +(struct mac:webview (window webview delegate closed?-box fullscreen?-box activity-token + [thread #:mutable]) #:transparent) (define (supported?) @@ -422,6 +434,7 @@ #:width [width 1024] #:height [height 768] #:devtools? [devtools? #f] + #:background-active? [background-active? #f] #:on-close [on-close (lambda () (void))]) (unless (supported?) (error 'open-webview "macOS WebView backend unavailable (WebKit failed to load)")) @@ -448,8 +461,33 @@ (tellv window setTitle: (->nsstring title)) (tellv window setReleasedWhenClosed: #:type _bool #f) - ;; WKWebView as the content view, tracking window resizes. + ;; WKWebView as the content view, tracking window resizes. On macOS 14+, + ;; keep WebKit from suspending work merely because the view becomes + ;; inactive/detached. This is a public WebKit preference and is independent + ;; from the stronger App Nap opt-in below. (define config (tell (tell WKWebViewConfiguration alloc) init)) + (define prefs (tell #:type _id config preferences)) + (when (and (cast prefs _id _pointer) + (tell prefs respondsToSelector: + #:type _SEL + (selector setInactiveSchedulingPolicy:))) + (tellv prefs setInactiveSchedulingPolicy: + #:type _int + WKInactiveSchedulingPolicyNone)) + + ;; Monitoring applications can explicitly request process activity while + ;; this window is alive. Do not enable it globally: keeping ordinary apps + ;; artificially active would waste power. + (define activity-token + (and background-active? + (let ([process-info (tell NSProcessInfo processInfo)]) + (tell #:type _id process-info + beginActivityWithOptions: + #:type _uintptr + NSActivityUserInitiatedAllowingIdleSystemSleep + reason: + (->nsstring "Glaze background-active WebView"))))) + (define webview (tell (tell WKWebView alloc) initWithFrame: @@ -477,6 +515,12 @@ (lambda () (set-box! closed? #t) (release-pump!) + (when (and activity-token + (cast activity-token _id _pointer)) + (tellv (tell NSProcessInfo processInfo) + endActivity: + #:type _id + activity-token)) (on-close))) (tellv window makeKeyAndOrderFront: #:type _id window) @@ -491,7 +535,8 @@ (tellv app activate) (tellv app activateIgnoringOtherApps: #:type _bool #t)) - (define wv (mac:webview window webview delegate closed? (box #f) #f)) + (define wv + (mac:webview window webview delegate closed? (box #f) activity-token #f)) (navigate wv url) ;; One shared pump services every open window; acquire only after navigate diff --git a/glaze/webview/webview-stub.rkt b/glaze/webview/webview-stub.rkt index 996cccd..3ff2363 100644 --- a/glaze/webview/webview-stub.rkt +++ b/glaze/webview/webview-stub.rkt @@ -2,7 +2,7 @@ ;; Stub WebView backend: used when the platform is unsupported or the native ;; libraries required by a real backend are missing. open-webview returns #f -;; so the public dispatcher (and callers) can fall back to the system browser. +;; so the public dispatcher can raise its actionable GUI-startup diagnostic. (provide open-webview supported? @@ -26,6 +26,7 @@ #:width [width 1024] #:height [height 768] #:devtools? [devtools? #f] + #:background-active? [background-active? #f] #:on-close [on-close (lambda () (void))]) #f) diff --git a/glaze/webview/webview-windows.rkt b/glaze/webview/webview-windows.rkt index 567d968..9596f6d 100644 --- a/glaze/webview/webview-windows.rkt +++ b/glaze/webview/webview-windows.rkt @@ -350,6 +350,7 @@ #:width [width 1024] #:height [height 768] #:devtools? [devtools? #f] + #:background-active? [background-active? #f] #:on-close [on-close (lambda () (void))]) (unless (supported?) (error 'open-webview "WebView2 backend unavailable")) diff --git a/info.rkt b/info.rkt index c648be5..2308283 100644 --- a/info.rkt +++ b/info.rkt @@ -1,10 +1,8 @@ #lang info -;; Single installable package: the repository root IS the package. It -;; provides every collection as a top-level directory — the `glaze` -;; library, the `raco glaze` CLI, the Scribble documentation, and the -;; test suite — so one `raco pkg install glaze` (or `--link .` from a -;; checkout) installs everything. +;; Single installable multi-collection package. Runtime dependencies belong in +;; `deps`; test and documentation tooling stays in `build-deps` so a future +;; binary distribution does not require developer-only libraries. (define name "glaze") (define collection 'multi) @@ -12,21 +10,26 @@ (define deps '(["base" #:version "8.0"] "web-server" - "web-server-lib" - ;; Tests ship inside this package, so rackunit is a runtime dep. - "rackunit-lib")) + "web-server-lib")) + (define build-deps - '("scribble-lib" + '("rackunit-lib" + "scribble-lib" "racket-doc")) -;; NOTE: `raco-commands` and `scribblings` are collection-level fields: -;; they live in glaze-cli/info.rkt and glaze-doc/info.rkt respectively. +;; Glaze is authored and published as Racket source. Catalog/build services may +;; derive built/binary packages for a specific Racket version afterwards. +(define distribution-preference 'source) + +;; `raco-commands` and `scribblings` are collection-level fields in +;; glaze-cli/info.rkt and glaze-doc/info.rkt. -;; NOTE: Racket's `valid-version?` rejects a trailing ".0" component -;; ("0.7.0" is invalid; "0.7" is the same release). +;; Racket's valid-version? treats "0.7" as the appropriate package version +;; spelling for this release line. (define version "0.7") -(define pkg-desc "Build desktop apps with Racket backend and web frontend — a Tauri-like framework for Racket") +(define pkg-desc + "Lisp-native framework for modern desktop applications with Racket and native WebViews") (define pkg-authors '(turinglambdaai)) (define license 'MIT) (define repository "https://github.com/turinglambdaai/glaze") diff --git a/scripts/info.rkt b/scripts/info.rkt index f295c41..e0921ba 100644 --- a/scripts/info.rkt +++ b/scripts/info.rkt @@ -1,6 +1,8 @@ #lang info -;; Collection-level info inside the single `glaze` package: helper -;; scripts (CI webview e2e) are run directly, never compiled by setup. -(define compile-omit-paths '("webview-e2e.rkt")) +;; CI/helper scripts are executed explicitly by workflows; package setup +;; should not compile them as library modules. +(define compile-omit-paths + '("webview-e2e.rkt" + "package-entry-smoke.rkt")) (define test-omit-paths 'all) diff --git a/scripts/macos-occlusion-e2e.rkt b/scripts/macos-occlusion-e2e.rkt new file mode 100644 index 0000000..b54c1bb --- /dev/null +++ b/scripts/macos-occlusion-e2e.rkt @@ -0,0 +1,234 @@ +#lang racket/base + +;; macOS-only regression for issue #2. A real opaque NSWindow is placed +;; directly above the target WebView window. The test first proves that AppKit +;; reports the target as fully occluded, then keeps it covered for more than +;; 30 seconds and observes a JavaScript setInterval through document.title. +;; +;; Keep the native machinery here instead of adding test-only surface to the +;; public API. mac:webview-window is an existing backend inspection hook. +;; Run this probe from an interactive macOS desktop session. GitHub's hosted +;; macos-26-arm64 runner can render and capture WebViews, but did not update +;; per-window occlusion state when one native window covered another (both +;; windows reported 8192), so CI cannot use that host as proof of occlusion. + +(require ffi/unsafe + ffi/unsafe/objc + racket/file + racket/string + glaze/server + glaze/webview/main + (only-in glaze/webview/webview-macos mac:webview-window)) + +(import-class NSColor NSString NSWindow) + +(define-cstruct _NSPoint ([x _double] [y _double])) +(define-cstruct _NSSize ([width _double] [height _double])) +(define-cstruct _NSRect ([origin _NSPoint] [size _NSSize])) + +(define NSBackingStoreBuffered 2) +(define NSWindowAbove 1) +(define NSWindowOcclusionStateVisible 2) +(define cover-margin 64.0) + +(define failures '()) + +(define (log fmt . args) + (apply fprintf (current-error-port) (string-append "[occlusion-e2e] " fmt "\n") args)) + +(define (check! name ok?) + (printf "[occlusion-e2e] ~a ~a\n" (if ok? "PASS" "FAIL") name) + (unless ok? + (set! failures (cons name failures))) + ok?) + +(define (wait-until pred [secs 15]) + (define deadline (+ (current-inexact-milliseconds) (* secs 1000))) + (let loop () + (cond + [(pred) #t] + [(> (current-inexact-milliseconds) deadline) #f] + [else (sleep 0.1) (loop)]))) + +(define (tick-number wv) + (define current-title (webview-title wv)) + (define match + (and (string? current-title) + (regexp-match #px"^occlusion:([0-9]+)$" current-title))) + (and match (string->number (cadr match)))) + +(define (->nsstring s) + (tell (tell NSString alloc) initWithUTF8String: #:type _string s)) + +;; Ask KVC to box the NSUInteger and read its decimal string. This avoids an +;; objc_msgSend integer-return anomaly seen on hosted arm64 runners, where a +;; direct _uintptr call returned 8192 for both visible windows instead of the +;; documented NSWindowOcclusionStateVisible value (2). +(define occlusion-state-key (->nsstring "occlusionState")) +(define (window-occlusion-state window) + (define boxed + (tell #:type _id window valueForKey: #:type _id occlusion-state-key)) + (define state-string (tell #:type _id boxed stringValue)) + (string->number (tell #:type _string state-string UTF8String))) + +(define (expanded-cover-frame frame) + (define origin (NSRect-origin frame)) + (define size (NSRect-size frame)) + (make-NSRect + (make-NSPoint (- (NSPoint-x origin) cover-margin) + (- (NSPoint-y origin) cover-margin)) + (make-NSSize (+ (NSSize-width size) (* 2.0 cover-margin)) + (+ (NSSize-height size) (* 2.0 cover-margin))))) + +(define public-dir (make-temporary-file "glaze-occlusion-~a" 'directory)) +(define stop-server! #f) +(define wv #f) +(define cover #f) + +(dynamic-wind + void + (lambda () + (with-handlers + ([exn:fail? + (lambda (e) + (log "exception: ~a" (exn-message e)) + (set! failures (cons "script completed without exception" failures)))]) + (call-with-output-file (build-path public-dir "index.html") + (lambda (out) + (display + (string-append + "occlusion:0" + "" + "") + out)) + #:exists 'replace) + + (define-values (port stop) + (start-server #:port 18971 #:public-dir public-dir)) + (set! stop-server! stop) + + (set! wv + (open-window (format "http://127.0.0.1:~a/" port) + #:title "Glaze occlusion regression" + #:width 640 + #:height 480 + #:background-active? #t)) + (unless (check! "background-active WebView opens" (webview? wv)) + (error 'macos-occlusion-e2e "WebView backend unavailable")) + + (define started? + (wait-until + (lambda () + (define n (tick-number wv)) + (and n (>= n 4))))) + (unless (check! "JavaScript interval starts" started?) + (error 'macos-occlusion-e2e + "timer did not start; title is ~s" + (webview-title wv))) + + (define target (mac:webview-window (webview-handle wv))) + (define target-frame (tell #:type _NSRect target frame)) + (define cover-frame (expanded-cover-frame target-frame)) + (set! cover + (tell (tell NSWindow alloc) + initWithContentRect: + #:type _NSRect + cover-frame + styleMask: + #:type _uintptr + 0 + backing: + #:type _uintptr + NSBackingStoreBuffered + defer: + #:type _bool + #f)) + (tellv cover setReleasedWhenClosed: #:type _bool #f) + (tellv cover setOpaque: #:type _bool #t) + (tellv cover setHasShadow: #:type _bool #f) + (tellv cover setAlphaValue: #:type _double 1.0) + (tellv cover + setBackgroundColor: + #:type _id + (tell NSColor + colorWithRed: + #:type _double + 0.08 + green: + #:type _double + 0.11 + blue: + #:type _double + 0.14 + alpha: + #:type _double + 1.0)) + ;; Borderless content and frame rectangles are identical, so using the + ;; target's frame plus a small margin covers its full bounds without + ;; title-bar, shadow, or rounded-corner geometry leaking through. + (tellv cover + setLevel: + #:type _intptr + (add1 (tell #:type _intptr target level))) + (tellv cover + orderWindow: + #:type _intptr + NSWindowAbove + relativeTo: + #:type _intptr + (tell #:type _intptr target windowNumber)) + (tellv cover orderFrontRegardless) + + (define (fully-occluded?) + (and (tell #:type _bool target isVisible) + (positive? + (bitwise-and NSWindowOcclusionStateVisible + (window-occlusion-state cover))) + (zero? + (bitwise-and NSWindowOcclusionStateVisible + (window-occlusion-state target))))) + + (unless (check! "AppKit reports the covered target as fully occluded" + (wait-until fully-occluded? 10)) + (error 'macos-occlusion-e2e + "could not establish occlusion (target state=~a, cover state=~a)" + (window-occlusion-state target) + (window-occlusion-state cover))) + + (define before (tick-number wv)) + (log "fully occluded at tick ~a; holding cover for 35 seconds" before) + (sleep 15) + (define middle (tick-number wv)) + (define covered-at-middle? (fully-occluded?)) + (sleep 20) + (define after (tick-number wv)) + (define covered-at-end? (fully-occluded?)) + (log "ticks while covered: before=~a middle=~a after=~a" before middle after) + + (check! "target remains fully occluded after 15 seconds" covered-at-middle?) + (check! "target remains fully occluded after 35 seconds" covered-at-end?) + (check! "JavaScript ticks advance during the first covered interval" + (and before middle (> middle before))) + (check! "JavaScript ticks continue advancing beyond 30 seconds" + (and middle after (> after middle))))) + (lambda () + (when cover + (with-handlers ([exn:fail? (lambda (_) (void))]) + (tellv cover close))) + (when (webview? wv) + (with-handlers ([exn:fail? (lambda (_) (void))]) + (webview-close wv))) + (when stop-server! + (with-handlers ([exn:fail? (lambda (_) (void))]) + (stop-server!))) + (when (directory-exists? public-dir) + (delete-directory/files public-dir)))) + +(if (null? failures) + (begin + (printf "[occlusion-e2e] ALL PASS\n") + (exit 0)) + (begin + (printf "[occlusion-e2e] FAILURES: ~a\n" + (string-join (reverse failures) ", ")) + (exit 1))) diff --git a/scripts/package-entry-smoke.rkt b/scripts/package-entry-smoke.rkt new file mode 100644 index 0000000..b331226 --- /dev/null +++ b/scripts/package-entry-smoke.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +;; Cross-platform packaging regression test. +;; +;; The critical behavior is that an application whose startup code lives in +;; `(module+ main ...)` still executes after build-app/raco distribute. This +;; catches launchers that build successfully but silently exit without running +;; the user's application. + +(require racket/file + racket/path + racket/system + glaze/build) + +(define work (make-temporary-file "glaze-package-smoke-~a" 'directory)) +(define entry (build-path work "main.rkt")) +(define dist (build-path work "dist")) +(define marker (build-path work "ran.txt")) +(define app-name "glaze-package-smoke") + +(call-with-output-file + entry + (lambda (out) + (display + #<string marker)) + (error 'package-smoke "packaged executable failed: ~a" executable)) + +(unless (and (file-exists? marker) + (equal? (file->string marker) "module+ main ran")) + (error 'package-smoke "packaged executable did not run module+ main")) + +(delete-directory/files work) +(displayln "package entry smoke test passed")