From 02b3293a171c0e607b02722249a98a1f49f3fcc1 Mon Sep 17 00:00:00 2001 From: jrtxio Date: Fri, 2 Oct 2026 16:46:51 +0800 Subject: [PATCH 1/8] features: persistent evidence/artifact store across runtime restarts - core/persist: append-only JSONL store (~/.benchpilot/store; env BENCHPILOT_STORE_DIR / BENCHPILOT_STORE=0) holding completed operation and observation records with their evidence; artifacts live as files with size + SHA-256 references so larger evidence stays out of LLM context (roadmap: persistent evidence/artifact storage + artifact references) - the runtime appends on every completed record and seeds its bounded in-memory history/evidence from the store at startup; serialization happens before the file write so a failure never tears a line - daemon routes: GET /store/operations|observations|artifacts and /store/artifact (base64 content); CLI: benchpilot store evidence | observations | artifacts | artifact [--out] - 4 store tests including a cross-session seed round trip --- racket/benchpilot/client/cli.rkt | 40 +++++ racket/benchpilot/core/hashing.rkt | 44 +++++ racket/benchpilot/core/persist-test.rkt | 83 +++++++++ racket/benchpilot/core/persist.rkt | 198 ++++++++++++++++++++++ racket/benchpilot/core/runtime-state.rkt | 137 ++++++++++++--- racket/benchpilot/runtime-host/daemon.rkt | 61 ++++++- 6 files changed, 540 insertions(+), 23 deletions(-) create mode 100644 racket/benchpilot/core/hashing.rkt create mode 100644 racket/benchpilot/core/persist-test.rkt create mode 100644 racket/benchpilot/core/persist.rkt diff --git a/racket/benchpilot/client/cli.rkt b/racket/benchpilot/client/cli.rkt index 42ea53f..e8febf2 100644 --- a/racket/benchpilot/client/cli.rkt +++ b/racket/benchpilot/client/cli.rkt @@ -5,6 +5,7 @@ ;; stable exit-code contract, one-retry autostart and the doctor check. (require json + net/base64 racket/format racket/list racket/port @@ -799,6 +800,41 @@ (call "POST" "/doip/discover" (hasheq) (hasheq 'windowMs (args-int-opt args 'window-ms))) compact) (if (> (length (hash-ref (unbox last-printed-box) 'vehicles '())) 0) 0 1)] + [(store) + (case subcommand + [(evidence) + (print-result (call "GET" "/store/operations" + (hasheq 'limit (or (args-int-opt args 'limit) 50))) + compact) + 0] + [(observations) + (print-result (call "GET" "/store/observations" + (hasheq 'limit (or (args-int-opt args 'limit) 50))) + compact) + 0] + [(artifacts) + (print-result (call "GET" "/store/artifacts" (hasheq)) compact) + 0] + [(artifact) + (define id (require-positional 2 "artifact id")) + (define result (call "GET" "/store/artifact" (hasheq 'artifactId id))) + (define content (base64-decode (string->bytes/latin-1 + (hash-ref result 'contentBase64)))) + (define out (args-get args 'out)) + (if out + (begin + (display-to-file content out #:mode 'binary #:exists 'replace) + (print-result (hasheq 'ok #t + 'artifactId (hash-ref result 'artifactId) + 'bytes (hash-ref result 'bytes) + 'sha256 (hash-ref result 'sha256) + 'output out) + compact)) + (begin + (write-bytes content) + (newline))) + 0] + [else (raise-validation (format "Unknown command: store ~a" subcommand))])] [(report) ;; --format html: one static evidence report for the bench session. (define results (make-hasheq)) @@ -878,6 +914,10 @@ Usage: benchpilot observe cancel [--json] [--endpoint URL] benchpilot report [--format html] [--out PATH] [--target ID] [--json] [--endpoint URL] + benchpilot store evidence [--limit N] [--json] + benchpilot store observations [--limit N] [--json] + benchpilot store artifacts [--json] + benchpilot store artifact [--out PATH] [--json] benchpilot preflight [--target ID] [--json] benchpilot bench validate [--target ID] [--json] diff --git a/racket/benchpilot/core/hashing.rkt b/racket/benchpilot/core/hashing.rkt new file mode 100644 index 0000000..ea7f614 --- /dev/null +++ b/racket/benchpilot/core/hashing.rkt @@ -0,0 +1,44 @@ +#lang racket/base + +;; Shared SHA-256 hashing through whatever tool the OS ships: sha256sum, +;; shasum, or certutil. No optional collection is required at runtime. + +(require racket/file + racket/list + racket/port + racket/string) + +(provide sha256-hex) + +(define (find-system-tool name) + (or (find-executable-path name) name)) + +(define (run-tool lines->value . argv) + (with-handlers ([exn:fail? (lambda (_) #f)]) + (define output (open-output-string)) + (define p (apply subprocess output #f 'stdout argv)) + (subprocess-wait p) + (if (zero? (subprocess-status p)) + (lines->value (get-output-string output)) + #f))) + +(define (sha256-hex path) + (case (system-path-convention-type) + [(windows) + (run-tool + (lambda (output) + (for/first ([line (in-list (string-split output "\n"))] + #:when (regexp-match? #px"^[0-9a-fA-F]{64}$" (string-trim line))) + (string-trim line))) + (find-system-tool "certutil.exe") "-hashfile" path "SHA256")] + [else + (or (run-tool + (lambda (output) + (and (>= (string-length (string-trim output)) 64) + (first (string-split (string-trim output))))) + (find-system-tool "sha256sum") path) + (run-tool + (lambda (output) + (and (>= (string-length (string-trim output)) 64) + (first (string-split (string-trim output))))) + (find-system-tool "shasum") "-a" "256" path))])) diff --git a/racket/benchpilot/core/persist-test.rkt b/racket/benchpilot/core/persist-test.rkt new file mode 100644 index 0000000..85a6ee5 --- /dev/null +++ b/racket/benchpilot/core/persist-test.rkt @@ -0,0 +1,83 @@ +#lang racket/base + +;; The persistent evidence/artifact store: records round-trip through the +;; JSONL files, artifacts land with checksums, and the runtime seeds its +;; in-memory history from a store created by a previous "session". + +(module+ test + (require benchpilot/core/contracts + benchpilot/core/persist + benchpilot/core/profile + benchpilot/core/runtime-state + benchpilot/core/bench-runtime + benchpilot/diagnostics/channels/sim-uds-channel + benchpilot/simulator/simulated-bench + racket/file + racket/list + racket/string + rackunit) + + (define dir (path->string (make-temporary-file "benchpilot-persist-~a" 'directory))) + (define store (open-persist-store dir)) + + (define record + (bench-operation-record "op-1" "demo" "power.on" + (list "sim.demo") + 1000 1060 60 #f "completed" #f)) + (define evidence + (bench-operation-evidence "op-1" "demo" "power.on" + (list "sim.demo") 1060 + (list (bench-evidence-item + "power.result" "Power-on completed." #f + (hasheq "ok" "true" "voltageV" "12"))))) + + (test-case "records survive a store round trip" + (persist-operation! store record evidence) + (define loaded (persist-load-recent store "operations.jsonl" 10)) + (check-equal? (length loaded) 1) + (define entry (first loaded)) + (check-equal? (hash-ref entry 'id) "op-1") + (check-equal? (hash-ref entry 'state) "completed") + (check-equal? (hash-ref entry 'durationMs) 60) + (check-equal? (hash-ref entry 'deadlineAtMillis) 'null) + (check-equal? (hash-ref (first (hash-ref entry 'items)) 'metadata) + '#hasheq((ok . "true") (voltageV . "12")))) + + (test-case "artifacts land under the store with a checksum" + (define ref (persist-artifact! store "op-1" "capture.json" #"[]")) + (check-equal? (hash-ref ref 'bytes) 2) + (check-true (string-contains? (hash-ref ref 'artifactId) "op-1")) + (define path (persist-artifact-file store (hash-ref ref 'artifactId))) + (check-true (and path (file-exists? path))) + (check-equal? (file->bytes path) #"[]") + (check-false (persist-artifact-file store "../escape"))) + + (test-case "the runtime seeds its history from a previous session" + (persist-operation! store + (struct-copy bench-operation-record record [id "op-0"]) + (struct-copy bench-operation-evidence evidence [operation-id "op-0"])) + (define registry + (make-driver-registry (list (make-simulator-factory) + (make-sim-diagnostics-factory)))) + (define rt (make-bench-runtime registry (default-simulator-profile))) + (define state (bench-runtime-state rt)) + (set-runtime-store! state store) + (seed-persisted-operations! state (persist-load-recent store "operations.jsonl" 128)) + ;; Both persisted operations are queryable in write (chronological) order. + (define history (runtime-recent-operations state 10)) + (check-equal? (length history) 2) + (check-equal? (bench-operation-record-id (first history)) "op-1") + (check-equal? (bench-operation-record-id (last history)) "op-0") + (check-not-false (runtime-get-operation-evidence state "op-0")) + ;; A new operation appends after the seeded entries and lands in the file. + (define t (runtime-target rt "demo")) + (target-power-on rt t 12 0) + (define history* (runtime-recent-operations state 10)) + (check-equal? (length history*) 3) + (check-equal? (bench-operation-record-kind (last history*)) "power.on") + (check-equal? (length (persist-load-recent store "operations.jsonl" 128)) 3)) + + (test-case "disabled store raises the typed error" + (putenv "BENCHPILOT_STORE" "0") + (check-exn exn:fail:persist-disabled? open-persist-store) + (putenv "BENCHPILOT_STORE" ""))) diff --git a/racket/benchpilot/core/persist.rkt b/racket/benchpilot/core/persist.rkt new file mode 100644 index 0000000..f58af26 --- /dev/null +++ b/racket/benchpilot/core/persist.rkt @@ -0,0 +1,198 @@ +#lang racket/base + +;; Persistent evidence/artifact store: selected evidence and larger artifacts +;; survive daemon restarts. Layout under the store directory (default +;; ~/.benchpilot/store; BENCHPILOT_STORE_DIR overrides; BENCHPILOT_STORE=0 +;; disables): +;; +;; operations.jsonl one completed operation record + evidence per line +;; observations.jsonl the same for observations +;; artifacts/. larger evidence that must stay out of LLM context +;; +;; The daemon seeds its in-memory history/evidence from these files at start +;; and appends on every completed record. + +(require json + racket/date + racket/file + racket/format + racket/list + racket/string) + +(require benchpilot/core/contracts + benchpilot/core/hashing) + +(provide (struct-out exn:fail:persist-disabled) + (struct-out persist-store) + persist-store-path + open-persist-store + persist-operation! + persist-observation! + record->jsexpr + observation-record->jsexpr + persist-load-recent + persist-artifact! + persist-artifact-file + utc-iso-millis) + +(struct exn:fail:persist-disabled exn:fail () #:transparent) + +;; ---------------------------------------------------------------------------- +;; Time +;; ---------------------------------------------------------------------------- + +(define (utc-iso-millis millis) + (and millis + (let* ([sec (quotient millis 1000)] + [frac (modulo millis 1000)] + [d (seconds->date sec #f)]) + (string-append + (~a (date-year d) #:width 4 #:pad-string "0") + "-" (~r (date-month d) #:min-width 2 #:pad-string "0") + "-" (~r (date-day d) #:min-width 2 #:pad-string "0") + "T" (~r (date-hour d) #:min-width 2 #:pad-string "0") + ":" (~r (date-minute d) #:min-width 2 #:pad-string "0") + ":" (~r (date-second d) #:min-width 2 #:pad-string "0") + "." (~r frac #:min-width 3 #:pad-string "0") + "Z")))) + +;; ---------------------------------------------------------------------------- +;; Store +;; ---------------------------------------------------------------------------- + +(struct persist-store (path mutex)) + +(define (open-persist-store [dir #f]) + (when (equal? (getenv "BENCHPILOT_STORE") "0") + (raise (exn:fail:persist-disabled + "The persistent store is disabled (BENCHPILOT_STORE=0)." + (current-continuation-marks)))) + (define path + (or dir + (getenv "BENCHPILOT_STORE_DIR") + (path->string (build-path (or (getenv "USERPROFILE") (getenv "HOME") ".") + ".benchpilot" "store")))) + (make-directory* (build-path path "artifacts")) + (persist-store path (make-semaphore 1))) + +(define (with-store-mutex store proc) + (semaphore-wait/enable-break (persist-store-mutex store)) + (begin0 (proc) + (semaphore-post (persist-store-mutex store)))) + +(define (append-line! store file-name jsexpr) + ;; Serialize first: a serialization failure then leaves no torn line + ;; behind for the next append to concatenate onto. + (define line (jsexpr->string jsexpr)) + (with-store-mutex + store + (lambda () + (call-with-output-file* + (build-path (persist-store-path store) file-name) + (lambda (out) + (display line out) + (newline out)) + #:mode 'text + #:exists 'append)))) + +;; ---------------------------------------------------------------------------- +;; Record persistence +;; ---------------------------------------------------------------------------- + +(define (json-keys->symbols h) + (for/hash ([(k v) (in-hash h)]) + (values (if (symbol? k) k (string->symbol (format "~a" k))) v))) + +(define (evidence-items->jsexpr items) + (for/list ([item (in-list items)]) + (hasheq 'kind (bench-evidence-item-kind item) + 'summary (bench-evidence-item-summary item) + 'text (or (bench-evidence-item-text item) 'null) + 'metadata + (json-keys->symbols + (or (bench-evidence-item-metadata item) (hasheq)))))) + +(define (record->jsexpr record evidence) + (hasheq 'kind "operation" + 'id (bench-operation-record-id record) + 'targetId (bench-operation-record-target-id record) + 'operation (bench-operation-record-kind record) + 'resourceIds (bench-operation-record-resource-ids record) + 'startedAtUtc (or (utc-iso-millis (bench-operation-record-started-at-millis record)) 'null) + 'startedAtMillis (bench-operation-record-started-at-millis record) + 'completedAtUtc (or (utc-iso-millis (bench-operation-record-completed-at-millis record)) 'null) + 'completedAtMillis (bench-operation-record-completed-at-millis record) + 'durationMs (bench-operation-record-duration-ms record) + 'deadlineAtUtc (or (utc-iso-millis (bench-operation-record-deadline-at-millis record)) 'null) + 'deadlineAtMillis (or (bench-operation-record-deadline-at-millis record) 'null) + 'state (bench-operation-record-state record) + 'error (or (bench-operation-record-error record) 'null) + 'items (if evidence + (evidence-items->jsexpr (bench-operation-evidence-items evidence)) + '()))) + +(define (observation-record->jsexpr record evidence) + (hasheq 'kind "observation" + 'id (bench-observation-record-id record) + 'targetId (bench-observation-record-target-id record) + 'observation (bench-observation-record-kind record) + 'resourceIds (bench-observation-record-resource-ids record) + 'startedAtUtc (or (utc-iso-millis (bench-observation-record-started-at-millis record)) 'null) + 'startedAtMillis (bench-observation-record-started-at-millis record) + 'completedAtUtc (or (utc-iso-millis (bench-observation-record-completed-at-millis record)) 'null) + 'completedAtMillis (bench-observation-record-completed-at-millis record) + 'durationMs (bench-observation-record-duration-ms record) + 'deadlineAtUtc (or (utc-iso-millis (bench-observation-record-deadline-at-millis record)) 'null) + 'deadlineAtMillis (or (bench-observation-record-deadline-at-millis record) 'null) + 'state (bench-observation-record-state record) + 'error (or (bench-observation-record-error record) 'null) + 'items (if evidence + (evidence-items->jsexpr (bench-observation-evidence-items evidence)) + '()))) + +(define (persist-operation! store record evidence) + (with-handlers ([exn:fail? (lambda (_) (void))]) + (append-line! store "operations.jsonl" (record->jsexpr record evidence)))) + +(define (persist-observation! store record evidence) + (with-handlers ([exn:fail? (lambda (_) (void))]) + (append-line! store "observations.jsonl" (observation-record->jsexpr record evidence)))) + +;; Reads the most recent entries, oldest-first (file order on the tail). +(define (persist-load-recent store file-name limit) + (with-handlers ([exn:fail? (lambda (_) '())]) + (with-store-mutex + store + (lambda () + (define path (build-path (persist-store-path store) file-name)) + (if (file-exists? path) + (let () + (define entries + (for/list ([line (in-list (file->lines path))] + #:unless (string-blank? line)) + (with-handlers ([exn:fail? (lambda (_) #f)]) + (read-json (open-input-string line))))) + (define parsed (filter hash? entries)) + (take-right parsed (min (max 0 limit) (length parsed)))) + '()))))) + +;; ---------------------------------------------------------------------------- +;; Artifacts: larger evidence that stays out of LLM context +;; ---------------------------------------------------------------------------- + +(define (persist-artifact! store operation-id name bytes) + (define safe-name (regexp-replace* #rx"[^A-Za-z0-9._-]" name "_")) + (define file-name (format "~a.~a" operation-id safe-name)) + (define path (build-path (persist-store-path store) "artifacts" file-name)) + (display-to-file bytes path #:mode 'binary #:exists 'replace) + (hasheq 'artifactId file-name + 'name name + 'bytes (bytes-length bytes) + 'sha256 (or (sha256-hex path) "") + 'createdAtUtc (or (utc-iso-millis (now-millis)) 'null))) + +(define (persist-artifact-file store artifact-id) + ;; Only the bare file name is accepted; traversal stays impossible. + (define safe (regexp-replace* #rx"[^A-Za-z0-9._-]" artifact-id "")) + (define path (build-path (persist-store-path store) "artifacts" safe)) + (and (file-exists? path) (path->string path))) diff --git a/racket/benchpilot/core/runtime-state.rkt b/racket/benchpilot/core/runtime-state.rkt index 5546f39..3593da3 100644 --- a/racket/benchpilot/core/runtime-state.rkt +++ b/racket/benchpilot/core/runtime-state.rkt @@ -12,6 +12,7 @@ (require "contracts.rkt" "evidence.rkt" + "persist.rkt" "profile.rkt") (provide (struct-out exec-cancel) @@ -22,6 +23,9 @@ check-disposed new-id now-millis + set-runtime-store! + seed-persisted-operations! + seed-persisted-observations! make-exec-cancel cancel-evt exec-cancel-request-cancel! @@ -128,7 +132,8 @@ op-evidence obs-evidence context-store - disposed-box) + disposed-box + store-box) #:transparent) ;; One in-flight mutation/observation: identity, held gates, cancellation. @@ -150,6 +155,7 @@ (make-evidence-store) (make-evidence-store) (make-context-store) + (box #f) (box #f))) (define (check-disposed rt) @@ -346,27 +352,32 @@ (release-all! rt acquired)) (define (record! items state error) - (evidence-store-put! (runtime-state-op-evidence rt) - operation-id - (bench-operation-evidence operation-id - target-id - operation - normalized - (now-millis) - (evidence-bound-items items))) + (define evidence + (bench-operation-evidence operation-id + target-id + operation + normalized + (now-millis) + (evidence-bound-items items))) + (evidence-store-put! (runtime-state-op-evidence rt) operation-id evidence) (define completed-at (now-millis)) + (define record + (bench-operation-record operation-id + target-id + operation + normalized + started-at + completed-at + (duration-ms-between started-at completed-at) + (active-exec-deadline-at-millis active) + state + error)) (history-push! (runtime-state-operation-history rt) - (bench-operation-record operation-id - target-id - operation - normalized - started-at - completed-at - (duration-ms-between started-at completed-at) - (active-exec-deadline-at-millis active) - state - error) - operation-history-capacity)) + record + operation-history-capacity) + (define store (unbox (runtime-state-store-box rt))) + (when store + (persist-operation! store record evidence))) (define (deadline-path) (record! @@ -631,3 +642,89 @@ (when (> remaining 0) (sync/timeout (/ (min 25 remaining) 1000.0) (or ct never-evt))) (loop)]))) + +;; ---------------------------------------------------------------------------- +;; Persistent store wiring (selected evidence/artifacts across restarts) +;; ---------------------------------------------------------------------------- + +(define (set-runtime-store! rt store) + (set-box! (runtime-state-store-box rt) store)) + +(define (entry-item->struct item) + (bench-evidence-item + (hash-ref item 'kind "") + (hash-ref item 'summary "") + (let ([text (hash-ref item 'text 'null)]) (if (eq? text 'null) #f text)) + (hash-ref item 'metadata (hasheq)))) + +(define (seed-persisted-operations! rt entries) + (define records + (for/list ([e (in-list entries)]) + (bench-operation-record + (hash-ref e 'id "") + (hash-ref e 'targetId "") + (hash-ref e 'operation "") + (hash-ref e 'resourceIds '()) + (hash-ref e 'startedAtMillis 0) + (hash-ref e 'completedAtMillis 0) + (hash-ref e 'durationMs 0) + (let ([d (hash-ref e 'deadlineAtMillis 'null)]) (if (eq? d 'null) #f d)) + (hash-ref e 'state "") + (let ([err (hash-ref e 'error 'null)]) (if (eq? err 'null) #f err))))) + (define evidences + (for/list ([e (in-list entries)]) + (bench-operation-evidence + (hash-ref e 'id "") + (hash-ref e 'targetId "") + (hash-ref e 'operation "") + (hash-ref e 'resourceIds '()) + (hash-ref e 'completedAtMillis 0) + (map entry-item->struct (hash-ref e 'items '()))))) + (for ([rec (in-list records)] + [ev (in-list evidences)]) + (evidence-store-put! (runtime-state-op-evidence rt) + (bench-operation-record-id rec) + ev)) + (define capped + (let* ([merged (append records (unbox (runtime-state-operation-history rt)))] + [n (length merged)]) + (if (> n operation-history-capacity) + (list-tail merged (- n operation-history-capacity)) + merged))) + (set-box! (runtime-state-operation-history rt) capped)) + +(define (seed-persisted-observations! rt entries) + (define records + (for/list ([e (in-list entries)]) + (bench-observation-record + (hash-ref e 'id "") + (hash-ref e 'targetId "") + (hash-ref e 'observation "") + (hash-ref e 'resourceIds '()) + (hash-ref e 'startedAtMillis 0) + (hash-ref e 'completedAtMillis 0) + (hash-ref e 'durationMs 0) + (let ([d (hash-ref e 'deadlineAtMillis 'null)]) (if (eq? d 'null) #f d)) + (hash-ref e 'state "") + (let ([err (hash-ref e 'error 'null)]) (if (eq? err 'null) #f err))))) + (define evidences + (for/list ([e (in-list entries)]) + (bench-observation-evidence + (hash-ref e 'id "") + (hash-ref e 'targetId "") + (hash-ref e 'observation "") + (hash-ref e 'resourceIds '()) + (hash-ref e 'completedAtMillis 0) + (map entry-item->struct (hash-ref e 'items '()))))) + (for ([rec (in-list records)] + [ev (in-list evidences)]) + (evidence-store-put! (runtime-state-obs-evidence rt) + (bench-observation-record-id rec) + ev)) + (define capped + (let* ([merged (append records (unbox (runtime-state-observation-history rt)))] + [n (length merged)]) + (if (> n observation-history-capacity) + (list-tail merged (- n observation-history-capacity)) + merged))) + (set-box! (runtime-state-observation-history rt) capped)) diff --git a/racket/benchpilot/runtime-host/daemon.rkt b/racket/benchpilot/runtime-host/daemon.rkt index e003ab0..117cf5a 100644 --- a/racket/benchpilot/runtime-host/daemon.rkt +++ b/racket/benchpilot/runtime-host/daemon.rkt @@ -9,14 +9,19 @@ ;; wrapping happens once at the dispatch site, keeping the table flat. (require json + racket/file racket/format racket/list racket/port racket/string - racket/tcp) + racket/tcp + net/base64) + +(require benchpilot/core/hashing) (require benchpilot/core/bench-runtime benchpilot/core/contracts + benchpilot/core/persist benchpilot/core/profile benchpilot/core/runtime-state benchpilot/diagnostics/channels/sim-uds-channel @@ -241,6 +246,15 @@ (make-scpi-power-resource-factory)))) (define rt (make-bench-runtime registry profile)) (define state (bench-runtime-state rt)) + ;; Selected evidence + artifacts persist across restarts and seed the + ;; in-memory bounded stores. + (define store + (with-handlers ([exn:fail? (lambda (_) #f)]) + (open-persist-store))) + (when store + (set-runtime-store! state store) + (seed-persisted-operations! state (persist-load-recent store "operations.jsonl" 128)) + (seed-persisted-observations! state (persist-load-recent store "observations.jsonl" 128))) (define lc (make-lifecycle)) (define api-token (resolve-or-create-token)) @@ -273,7 +287,8 @@ (exit 0))) (define dispatch - (make-dispatcher rt state lc (lambda () (semaphore-post shutdown-requested)))) + (make-dispatcher rt state lc store + (lambda () (semaphore-post shutdown-requested)))) (http-serve #:host host @@ -322,7 +337,7 @@ ;; over the request's query/body. Returns #f for unknown routes. ;; ---------------------------------------------------------------------------- -(define (make-dispatcher rt state lc begin-shutdown!) +(define (make-dispatcher rt state lc store begin-shutdown!) (define (target* query) (runtime-target rt (query-ref query "target"))) (lambda (method api-path query body-json) @@ -534,6 +549,46 @@ (hex-up*4 (doip-vehicle-identity-logical-address identity))) (doip-vehicle-identity-ip-address identity))) #f))] + [(match? "GET" "/store/operations") + (lambda () + (unless store (raise-validation "The persistent store is disabled.")) + (hasheq 'kind "operation-list" + 'entries (persist-load-recent store "operations.jsonl" + (query-int query "limit" 50))))] + [(match? "GET" "/store/observations") + (lambda () + (unless store (raise-validation "The persistent store is disabled.")) + (hasheq 'kind "observation-list" + 'entries (persist-load-recent store "observations.jsonl" + (query-int query "limit" 50))))] + [(match? "GET" "/store/artifacts") + (lambda () + (unless store (raise-validation "The persistent store is disabled.")) + (define dir (build-path (persist-store-path store) "artifacts")) + (hasheq 'kind "artifact-list" + 'artifacts + (for/list ([f (in-list (sort (directory-list dir) string<=? + #:key path->string))] + #:when (file-exists? (build-path dir f))) + (hasheq 'artifactId (path->string f) + 'bytes (file-size (build-path dir f))))))] + [(match? "GET" "/store/artifact") + (lambda () + (unless store (raise-validation "The persistent store is disabled.")) + (define id (query-ref query "artifactId")) + (when (string-blank? id) + (raise-validation "artifactId cannot be empty.")) + (define path (persist-artifact-file store id)) + (unless path + (raise (make-target-not-found-error + (format "Artifact '~a' was not found." id)))) + (define content (file->bytes path)) + (hasheq 'kind "artifact" + 'artifactId id + 'bytes (bytes-length content) + 'sha256 (or (sha256-hex path) "") + 'contentBase64 + (bytes->string/latin-1 (base64-encode content ""))))] [(match? "POST" "/shutdown") (lambda () ;; Token-authenticated like every other endpoint: the graceful From 9d1a9ace6899562eb282648ac8bbf75686349af8 Mon Sep 17 00:00:00 2001 From: jrtxio Date: Fri, 2 Oct 2026 16:56:04 +0800 Subject: [PATCH 2/8] features: device error taxonomy + Intel HEX / S-record image model MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - core/device-errors: vendor SDK failure messages classify into six stable classes (timeout/transport/device-state/permission/not-found/ protocol) at the fault site; faulted operations gain a bounded device.error evidence item naming the class and matched pattern — agents branch on behavior, vendor types never reach Core - diagnostics/flash/image: Intel HEX (types 00/01/02/04, checksum enforced, extended linear/segment bases) and Motorola S-record (S1/S2/S3 data, S7-S9 stop, one's-complement checksums) parse into address/data segments; adjacent records merge into contiguous regions - flash plans: .hex/.ihex/.s19/.srec firmware becomes one segment per contiguous region automatically; BIN stays explicit-address --- racket/benchpilot/core/bench-runtime.rkt | 27 ++- racket/benchpilot/core/device-errors.rkt | 66 ++++++ racket/benchpilot/core/runtime-state.rkt | 7 +- .../diagnostics/flash/image-test.rkt | 123 ++++++++++ racket/benchpilot/diagnostics/flash/image.rkt | 216 ++++++++++++++++++ 5 files changed, 436 insertions(+), 3 deletions(-) create mode 100644 racket/benchpilot/core/device-errors.rkt create mode 100644 racket/benchpilot/diagnostics/flash/image-test.rkt create mode 100644 racket/benchpilot/diagnostics/flash/image.rkt diff --git a/racket/benchpilot/core/bench-runtime.rkt b/racket/benchpilot/core/bench-runtime.rkt index 92810ac..8edb945 100644 --- a/racket/benchpilot/core/bench-runtime.rkt +++ b/racket/benchpilot/core/bench-runtime.rkt @@ -21,6 +21,14 @@ "readiness.rkt" "runtime-state.rkt") +(require (only-in benchpilot/diagnostics/flash/image + image-format-for-path + image-segment-address + image-segment-data + merge-image-segments + parse-intel-hex + parse-srecord)) + ;; driver generics (Core abstractions) (provide gen:resource-health-check gen:power-supply @@ -726,11 +734,26 @@ seg [data (read-segment-file (uds-flash-segment-file seg) base-directory)])))])) - (begin + (let () (unless address (raise-validation "Provide --address (flash start address, for example 0x08000000) or a flash plan file.")) - (uds-flash-plan (list (uds-flash-segment address (file->bytes firmware-path) #f)) + ;; BIN keeps one explicit-address segment; HEX/S-record images + ;; carry their own addresses and become one segment per region. + (define image-format (image-format-for-path firmware-path)) + (define segments + (if image-format + (let* ([text (file->string firmware-path)] + [raw (if (string=? image-format "hex") + (parse-intel-hex text) + (parse-srecord text))] + [merged (merge-image-segments raw)]) + (for/list ([seg (in-list merged)]) + (uds-flash-segment (image-segment-address seg) + (bytes->list (image-segment-data seg)) + #f))) + (list (uds-flash-segment address (file->bytes firmware-path) #f)))) + (uds-flash-plan segments 1024 #x02 #f diff --git a/racket/benchpilot/core/device-errors.rkt b/racket/benchpilot/core/device-errors.rkt new file mode 100644 index 0000000..fba8778 --- /dev/null +++ b/racket/benchpilot/core/device-errors.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +;; Device/runtime error taxonomy: vendor SDK messages are classified into a +;; small, stable set of classes without ever leaking vendor types or vendor +;; SDK details into Core. Faulted operations carry a `device.error` evidence +;; item whose metadata names the class and the pattern that matched, so +;; agents can branch on behavior instead of parsing vendor strings. + +(require racket/string) + +(require benchpilot/core/contracts) + +(provide device-error-classes + classify-device-error + device-error-evidence-item) + +;; Each class lists the case-insensitive substrings that indicate it. The +;; first matching class wins; unmatched failures classify as `unknown`. +(define device-error-classes + (list + (cons "timeout" + '("timed out" "timeout" "deadline exceeded" "no response")) + (cons "transport" + '("connection refused" "connection closed" "no route" "unreachable" + "broken pipe" "reset by peer" "socket")) + (cons "device-state" + '("busy" "not ready" "device is off" "power is off" "no power" + "already open" "not open")) + (cons "permission" + '("access denied" "permission" "unauthorized" "in use by another" + "locked")) + (cons "not-found" + '("not found" "no such file" "no such device" "was not found" + "not visible" "not installed" "could not resolve")) + (cons "protocol" + '("checksum" "crc" "invalid response" "unexpected response" + "malformed" "nrc" "flow control" "iso-tp")))) + +(define (contains-ci? haystack needle) + (string-contains? (string-foldcase haystack) (string-foldcase needle))) + +;; -> (values class matched-pattern) +(define (classify-device-error message) + (let loop ([classes device-error-classes]) + (cond + [(null? classes) (values "unknown" "")] + [else + (define match + (findf (lambda (pat) (contains-ci? message pat)) + (cdr (car classes)))) + (if match + (values (car (car classes)) match) + (loop (cdr classes)))]))) + +;; The evidence item attached to faulted operations. +(define (device-error-evidence-item message) + (define-values (class pattern) (classify-device-error message)) + (bench-evidence-item + "device.error" + (format "Failure classified as ~a." class) + (let ([bounded (if (<= (string-length message) 2000) + message + (string-append (substring message 0 2000) "…"))]) + bounded) + (hasheq "class" class + "matchedPattern" (if (string=? pattern "") "" pattern)))) diff --git a/racket/benchpilot/core/runtime-state.rkt b/racket/benchpilot/core/runtime-state.rkt index 3593da3..2c6c382 100644 --- a/racket/benchpilot/core/runtime-state.rkt +++ b/racket/benchpilot/core/runtime-state.rkt @@ -11,6 +11,7 @@ racket/string) (require "contracts.rkt" + "device-errors.rkt" "evidence.rkt" "persist.rkt" "profile.rkt") @@ -404,7 +405,11 @@ (record! (operation-cancellation-evidence) "cancelled" "Operation cancelled.") (raise e)]))] [exn:fail? (lambda (e) - (record! (operation-exception-evidence (exn-message e) (exception-type-name e)) + (record! (append (operation-exception-evidence + (exn-message e) + (exception-type-name e)) + (list (device-error-evidence-item + (exn-message e)))) "faulted" (bound-history-error (exn-message e))) (raise e))]) diff --git a/racket/benchpilot/diagnostics/flash/image-test.rkt b/racket/benchpilot/diagnostics/flash/image-test.rkt new file mode 100644 index 0000000..f13f33d --- /dev/null +++ b/racket/benchpilot/diagnostics/flash/image-test.rkt @@ -0,0 +1,123 @@ +#lang racket/base + +;; Intel HEX / S-record parsing: golden fixtures, checksum enforcement, +;; address bases and segment merging. + +(module+ test + (require benchpilot/diagnostics/flash/image + racket/format + racket/list + rackunit) + + ;; Fixture builders: correct checksums are computed, not hand-written. + (define (ihex addr type data) + (define count (length data)) + (define body + (append (list count + (arithmetic-shift addr -8) + (bitwise-and addr #xFF) + type) + data)) + (define checksum (bitwise-and (- 256 (apply + body)) #xFF)) + (format ":~a" + (apply string-append + (append (for/list ([b (in-list body)]) + (~r b #:base 16 #:min-width 2 #:pad-string "0")) + (list (~r checksum #:base 16 #:min-width 2 #:pad-string "0")))))) + + (define (ihex-line addr type data) + (string-append (ihex addr type data) "\n")) + + (define data-16a (for/list ([i 16]) (modulo (* i 7) 256))) + (define data-16b (for/list ([i 16]) (modulo (+ i 3) 256))) + (define data-11 (for/list ([i 11]) (modulo (+ (* i 5) 2) 256))) + + (define ihex-sample + (string-append + (ihex-line #x0100 0 data-16a) + (ihex-line #x0110 0 data-16b) + (ihex-line #x0120 0 data-11) + (ihex-line 0 1 '()))) + + (define (srec type addr data) + (define addr-bytes (case type [(1 9) 2] [(2 8) 3] [(3 7) 4] [else 0])) + (define addr-list + (for/list ([i (in-range addr-bytes)]) + (bitwise-and (arithmetic-shift addr (* -8 (- addr-bytes 1 i))) #xFF))) + (define count (+ addr-bytes (length data) 1)) + (define sum (apply + count (append addr-list data))) + (define checksum (bitwise-and (bitwise-not sum) #xFF)) + (define all (append (list count) addr-list data (list checksum))) + (format "S~a~a\n" + type + (apply string-append + (for/list ([b (in-list all)]) + (~r b #:base 16 #:min-width 2 #:pad-string "0"))))) + + (define srec-sample + (string-append + (srec 0 0 (map char->integer (string->list "HDR"))) + (srec 1 #x1000 (list #x61 #x42 #x43)) + (srec 1 #x1008 (list #x61 #x42 #x43)) + (srec 9 0 '()))) + + (test-case "intel hex parses records into ordered segments" + (define segs (parse-intel-hex ihex-sample)) + (check-equal? (length segs) 3) + (check-equal? (image-segment-address (first segs)) #x0100) + (check-equal? (bytes-length (image-segment-data (first segs))) 16) + (check-equal? (bytes-ref (image-segment-data (first segs)) 0) 0) + (check-equal? (bytes-ref (image-segment-data (first segs)) 1) 7) + (check-equal? (image-segment-address (third segs)) #x0120)) + + (test-case "intel hex extended linear address raises the base" + (define text + (string-append + (ihex-line 0 4 (list #x08 #x00)) + (ihex-line 0 0 (list #x11 #x22 #x33 #x44)) + (ihex-line 0 1 '()))) + (define segs (parse-intel-hex text)) + (check-equal? (length segs) 1) + (check-equal? (image-segment-address (first segs)) #x08000000)) + + (test-case "intel hex checksums are enforced" + (define good (ihex 0 0 (list 1 2 3))) + (define corrupted + (string-append + (substring good 0 (- (string-length good) 2)) + (if (string=? (substring good (- (string-length good) 2) (- (string-length good) 1)) + "F") + "0" + "F") + "\n")) + (check-exn exn:fail:image? (lambda () (parse-intel-hex corrupted)))) + + (test-case "s-record parses data records with checksum validation" + (define segs (parse-srecord srec-sample)) + (check-equal? (length segs) 2) + (check-equal? (image-segment-address (first segs)) #x1000) + (check-equal? (bytes->list (image-segment-data (first segs))) + (list #x61 #x42 #x43))) + + (test-case "s-record rejects corrupted bytes" + (define good (srec 1 #x1000 (list #x61 #x42 #x43))) + (define corrupted + (string-append + (substring good 0 8) + (string (if (char=? (string-ref good 8) #\6) #\7 #\6)) + (substring good 9))) + (check-exn exn:fail:image? (lambda () (parse-srecord corrupted)))) + + (test-case "adjacent records merge into contiguous segments" + (define segs (parse-intel-hex ihex-sample)) + (define merged (merge-image-segments segs)) + (check-equal? (length merged) 1) + (check-equal? (bytes-length (image-segment-data (first merged))) 43) + (check-equal? (image-segment-address (first merged)) #x0100)) + + (test-case "format detection covers the common extensions" + (check-equal? (image-format-for-path "fw.hex") "hex") + (check-equal? (image-format-for-path "app.ihex") "hex") + (check-equal? (image-format-for-path "app.s19") "srecord") + (check-equal? (image-format-for-path "app.srec") "srecord") + (check-false (image-format-for-path "app.bin")))) diff --git a/racket/benchpilot/diagnostics/flash/image.rkt b/racket/benchpilot/diagnostics/flash/image.rkt new file mode 100644 index 0000000..a23ddcc --- /dev/null +++ b/racket/benchpilot/diagnostics/flash/image.rkt @@ -0,0 +1,216 @@ +#lang racket/base + +;; Firmware image model: Intel HEX and Motorola S-record files parse into +;; address/data segments, so one declarative flash plan can flash a +;; multi-region image the same way it flashes inline hex data. BIN stays +;; explicit-address by design (BenchPilot never guesses flash addresses). + +(require racket/format + racket/list + racket/string) + +(require benchpilot/core/contracts) + +(provide (struct-out image-segment) + (struct-out exn:fail:image) + parse-intel-hex + parse-srecord + image-segments? + merge-image-segments + image-format-for-path) + +(struct image-segment (address data) #:transparent) +(struct exn:fail:image exn:fail () #:transparent) + +(define (image-error message) + (raise (exn:fail:image message (current-continuation-marks)))) + +(define (hex-digit? c) + (or (char-numeric? c) + (and (char>=? (char-upcase c) #\A) (char-upcase c) (char<=? (char-upcase c) #\F)))) + +(define (hex-byte s i) + (string->number (substring s i (+ i 2)) 16)) + +(define (byte-list s offset count) + (for/list ([i (in-range count)]) + (hex-byte s (+ offset (* 2 i))))) + +;; --------------------------------------------------------------------------- +;; Intel HEX (I32HEX): :llaaaatt[dd...]cc, types 00 data, 01 EOF, +;; 02 extended segment address, 04 extended linear address. +;; --------------------------------------------------------------------------- + +(define (parse-intel-hex text) + (define segments + (let loop ([lines (string-split text "\n")] + [base 0] + [acc '()] + [at-eof? #f]) + (if (or (null? lines) at-eof?) + (reverse acc) + (let* ([raw (string-trim (car lines))]) + (cond + [(string-blank? raw) (loop (cdr lines) base acc at-eof?)] + [(not (string-prefix? raw ":")) + (image-error "Intel HEX line does not start with ':'")] + [else + (define body (substring raw 1)) + (define count (hex-byte body 0)) + (define offset (+ (arithmetic-shift (hex-byte body 2) 8) + (hex-byte body 4))) + (define type (hex-byte body 6)) + (define expected-len (+ 5 count)) ; count + addr + type + cksum + (unless (>= (quotient (string-length body) 2) expected-len) + (image-error "Intel HEX record is truncated")) + (define checksum (hex-byte body (* 2 (+ 4 count)))) + (define sum + (for/sum ([i (in-range (+ 4 count))]) + (hex-byte body (* 2 i)))) + (unless (zero? (modulo (+ sum checksum) 256)) + (image-error "Intel HEX checksum mismatch")) + (define data (byte-list body 8 count)) + (case type + [(0) + (define addr (+ base offset)) + (loop (cdr lines) base + (cons (image-segment addr (list->bytes data)) acc) + at-eof?)] + [(1) (loop (cdr lines) base acc #t)] + [(2) + ;; extended segment: base = value << 4 + (loop (cdr lines) + (* (+ (arithmetic-shift (first data) 8) (second data)) 16) + acc at-eof?)] + [(4) + ;; extended linear: base = value << 16 + (loop (cdr lines) + (* (+ (arithmetic-shift (first data) 8) (second data)) + 65536) + acc at-eof?)] + [else (loop (cdr lines) base acc at-eof?)])]))))) + segments) + +;; --------------------------------------------------------------------------- +;; Motorola S-record: S0 header, S1/S2/S3 data, S7/S8/S9 stop; one's +;; complement checksum over count+address+data. +;; --------------------------------------------------------------------------- + +(define (srec-address-length type) + (case type + [(1 9) 2] + [(2 8) 3] + [(3 7) 4] + [else 0])) + +(define (parse-srecord text) + (let loop ([lines (string-split text "\n")] + [acc '()] + [at-stop? #f]) + (if (or (null? lines) at-stop?) + (reverse acc) + (let ([line (string-trim (car lines))]) + (cond + [(string-blank? line) (loop (cdr lines) acc at-stop?)] + [(not (string-prefix? line "S")) + (image-error "S-record line does not start with 'S'")] + [else + (define type (string->number (substring line 1 2))) + (define count (hex-byte line 2)) + ;; "S" and the type are not bytes: byte i lives at char 2+2i. + (define total (quotient (- (string-length line) 2) 2)) + (unless (= count (- total 1)) + (image-error "S-record byte count mismatch")) + (define sum + (for/sum ([i (in-range count)]) + (hex-byte line (* 2 (+ 1 i))))) + (define checksum (hex-byte line (* 2 (+ 1 count)))) + (unless (= (bitwise-and (bitwise-not sum) #xFF) checksum) + (image-error "S-record checksum mismatch")) + (case type + [(1 2 3) + (define addr-bytes (srec-address-length type)) + (define addr + (for/sum ([i (in-range addr-bytes)]) + (arithmetic-shift (hex-byte line (* 2 (+ 2 i))) + (* 8 (- addr-bytes 1 i))))) + ;; byte 0 is the count; data begins after count + address. + (define data-start (+ 2 (* 2 (add1 addr-bytes)))) + (define data-count (- count addr-bytes 1)) + (define data (byte-list line data-start data-count)) + (loop (cdr lines) + (cons (image-segment addr (list->bytes data)) acc) + at-stop?)] + [(7 8 9) (loop (cdr lines) acc #t)] + [else (loop (cdr lines) acc at-stop?)])]))))) + +;; --------------------------------------------------------------------------- +;; Shared helpers +;; --------------------------------------------------------------------------- + +(define (image-segments? v) + (and (list? v) + (andmap (lambda (s) (image-segment? s)) v))) + +(define (merge-image-segments segments [gap 0]) + ;; Coalesces adjacent records into contiguous segments so a flash plan + ;; carries one segment per contiguous region. + (define sorted + (sort segments (lambda (a b) (< (image-segment-address a) + (image-segment-address b))))) + (let loop ([remaining sorted] + [current #f] + [acc '()]) + (cond + [(null? remaining) + (reverse (if current (cons current acc) acc))] + [else + (define seg (car remaining)) + (if (not current) + (loop (cdr remaining) seg acc) + (let* ([cur-end (+ (image-segment-address current) + (bytes-length (image-segment-data current)))] + [next-start (image-segment-address seg)] + [next-end (+ next-start (bytes-length (image-segment-data seg)))]) + (cond + [(<= next-start cur-end) + ;; overlapping or adjacent: extend + (if (<= next-end cur-end) + (loop (cdr remaining) current acc) + (let* ([merged (make-bytes (- next-end + (image-segment-address current)))] + [_ (memcpy-bytes merged 0 (image-segment-data current))] + [_ (memcpy-bytes merged + (- next-start + (image-segment-address current)) + (image-segment-data seg))]) + (loop (cdr remaining) + (image-segment (image-segment-address current) merged) + acc)))] + [(<= (- next-start cur-end) gap) + (let* ([merged (make-bytes (- next-end + (image-segment-address current)))] + [_ (memcpy-bytes merged 0 (image-segment-data current))] + [_ (memcpy-bytes merged + (- next-start + (image-segment-address current)) + (image-segment-data seg))]) + (loop (cdr remaining) + (image-segment (image-segment-address current) merged) + acc))] + [else + (loop (cdr remaining) seg (cons current acc))])))]))) + +(define (memcpy-bytes dest dest-offset src) + (for ([b (in-bytes src)] + [i (in-naturals)]) + (bytes-set! dest (+ dest-offset i) b))) + +(define (image-format-for-path path) + (define lower (string-downcase path)) + (cond + [(or (string-suffix? lower ".hex") (string-suffix? lower ".ihex")) "hex"] + [(or (string-suffix? lower ".s19") (string-suffix? lower ".srec") + (string-suffix? lower ".s28") (string-suffix? lower ".sx") + (string-suffix? lower ".s")) "srecord"] + [else #f])) From c5153397ddaf0ef5f717a639f293fd430c7c39a6 Mon Sep 17 00:00:00 2001 From: jrtxio Date: Fri, 2 Oct 2026 17:08:28 +0800 Subject: [PATCH 3/8] features: UDS DTC primitives (0x19/0x14) end to end - protocol: uds-read-dtcs (ReadDTCInformation 0x19 subfunction 0x02) and uds-clear-dtcs (ClearDiagnosticInformation 0x14) request builders plus a DTC response parser (3-byte DTC + status records) - the simulated ECU answers both services and keeps DTC state across a session (canned fault 0x010870, status 0x2f) - CLI: uds dtc read [--mask XX] / uds dtc clear [--group XXXXXX] over the existing /uds/request route; clear answers with the bare positive SID so responseHex is empty by design - 3 channel-level tests --- racket/benchpilot/client/cli.rkt | 49 +++++++++++++++++++ .../diagnostics/channels/sim-uds-channel.rkt | 32 +++++++++++- racket/benchpilot/diagnostics/dtc-test.rkt | 43 ++++++++++++++++ .../benchpilot/diagnostics/uds/protocol.rkt | 43 ++++++++++++++++ 4 files changed, 165 insertions(+), 2 deletions(-) create mode 100644 racket/benchpilot/diagnostics/dtc-test.rkt diff --git a/racket/benchpilot/client/cli.rkt b/racket/benchpilot/client/cli.rkt index e8febf2..8e98a9f 100644 --- a/racket/benchpilot/client/cli.rkt +++ b/racket/benchpilot/client/cli.rkt @@ -557,6 +557,11 @@ (define (require-positional index label) (or (args-positional args index) (raise-validation (format "Missing required ~a." label)))) + (define (hex-string->bytes hex) + (list->bytes (hex-parse hex))) + (define (bytes->hex-string bs) + (bytes->hex (bytes->list bs))) + (define (maybe-did text) (define n (parse-hex-or-dec text)) (unless (and n (>= n 0) (<= n #xFFFF)) @@ -792,6 +797,48 @@ (args-get args 'confirm-target))) compact) 0] + [(dtc) + (define action + (string->symbol (string-downcase + (or (args-positional args 2) "")))) + (case action + [(read) + (define mask (args-hex-opt args 'mask)) + (define request (uds-read-dtcs (or mask #xFF))) + (define result + (call "POST" "/uds/request" + (target-query) + (hasheq 'requestHex (bytes->hex-string (list->bytes request))))) + (unless (hash-ref result 'positive #f) + (print-result result compact) + 1) + ;; responseHex already excludes the SID. + (define payload (hex-string->bytes (hash-ref result 'responseHex ""))) + (define parsed (parse-dtc-response (bytes->list payload))) + (define out + (if (eq? parsed 'unsupported) + (hasheq 'ok #t 'positive #f 'error "ECU does not support DTC read (NRC or odd response).") + (hasheq 'ok #t + 'positive #t + 'availableMask (format "0x~a" (~r (hash-ref parsed 'availableMask) #:base 16 #:min-width 2 #:pad-string "0")) + 'dtcs (hash-ref parsed 'dtcs '())))) + (print-result out compact) + 0] + [(clear) + (define group (args-hex-opt args 'group)) + (define request (uds-clear-dtcs (or group #xFFFFFF))) + (define result + (call "POST" "/uds/request" + (target-query) + (hasheq 'requestHex (bytes->hex-string (list->bytes request))))) + (if (not (hash-ref result 'positive #f)) + (begin (print-result result compact) 1) + (let () + ;; ClearDiagnosticInformation answers with the bare 0x54 + ;; positive SID; responseHex is empty by design. + (print-result (hasheq 'ok #t 'positive #t 'cleared #t) compact) + 0))] + [else (raise-validation (format "Unknown command: uds dtc ~a" action))])] [else (raise-validation (format "Unknown command: uds ~a" subcommand))])] [(doip) (unless (eq? subcommand (quote discover)) @@ -914,6 +961,8 @@ Usage: benchpilot observe cancel [--json] [--endpoint URL] benchpilot report [--format html] [--out PATH] [--target ID] [--json] [--endpoint URL] + benchpilot uds dtc read [--mask XX] [--target ID] [--json] + benchpilot uds dtc clear [--group XXXXXX] [--target ID] [--json] benchpilot store evidence [--limit N] [--json] benchpilot store observations [--limit N] [--json] benchpilot store artifacts [--json] diff --git a/racket/benchpilot/diagnostics/channels/sim-uds-channel.rkt b/racket/benchpilot/diagnostics/channels/sim-uds-channel.rkt index c058a41..3d0c0fb 100644 --- a/racket/benchpilot/diagnostics/channels/sim-uds-channel.rkt +++ b/racket/benchpilot/diagnostics/channels/sim-uds-channel.rkt @@ -98,7 +98,8 @@ last-image-box erased-box erase-count-box - verify-count-box) + verify-count-box + dtc-box) #:transparent) (struct uds-server-response (response delay-ms) #:transparent) @@ -126,7 +127,8 @@ (box '()) (box #f) (box 0) - (box 0))) + (box 0) + (box (list (hasheq 'dtc #x010870 'status #x2F))))) (define (negative sid nrc) (uds-server-response (list #x7F sid nrc) 0)) @@ -178,8 +180,34 @@ [(#x36) (handle-transfer-data! p request)] [(#x37) (handle-transfer-exit! p request)] [(#x11) (handle-ecu-reset! p request)] + [(#x19) (handle-read-dtc! p request)] + [(#x14) (handle-clear-dtc! p request)] [else (negative (car request) #x11)])])) +(define (handle-read-dtc! p request) + (if (not (= (length request) 3)) + (negative (car request) #x13) + (let ([records + (with-mutex* (uds-processor-mutex p) + (lambda () + (for/list ([entry (in-list (unbox (uds-processor-dtc-box p)))]) + (append (list (bitwise-and (arithmetic-shift (hash-ref entry 'dtc) -16) #xFF) + (bitwise-and (arithmetic-shift (hash-ref entry 'dtc) -8) #xFF) + (bitwise-and (hash-ref entry 'dtc) #xFF)) + (list (hash-ref entry 'status))))))]) + (uds-server-response + (append (list #x59 (second request) #x2F) + (apply append records)) + 0)))) + +(define (handle-clear-dtc! p request) + (if (not (= (length request) 4)) + (negative (car request) #x13) + (begin + (with-mutex* (uds-processor-mutex p) + (lambda () (set-box! (uds-processor-dtc-box p) '()))) + (uds-server-response (list #x54) 0)))) + (define (handle-session! p request) (define options (uds-processor-options p)) (if (not (= (length request) 2)) diff --git a/racket/benchpilot/diagnostics/dtc-test.rkt b/racket/benchpilot/diagnostics/dtc-test.rkt new file mode 100644 index 0000000..af05834 --- /dev/null +++ b/racket/benchpilot/diagnostics/dtc-test.rkt @@ -0,0 +1,43 @@ +#lang racket/base + +;; DTC primitives: the simulated ECU answers ReadDTCInformation (0x19 0x02) +;; with its canned fault and clears it via ClearDiagnosticInformation (0x14). + +(module+ test + (require benchpilot/core/contracts + benchpilot/diagnostics/channels/sim-uds-channel + benchpilot/diagnostics/uds/protocol + racket/list + racket/string + rackunit) + + (define ch (make-sim-uds-channel)) + + (define (dtc-request request) + (define result (sim-channel-request ch request 1000 5000)) + (check-true (uds-request-result-ok result)) + (check-true (uds-request-result-positive result)) + (parse-dtc-response + (hex-parse (uds-request-result-response-hex result)))) + + (test-case "fresh ECU reports the canned DTC" + (define parsed (dtc-request (uds-read-dtcs #xFF))) + (check-equal? (hash-ref parsed 'availableMask) #x2F) + (define dtcs (hash-ref parsed 'dtcs)) + (check-equal? (length dtcs) 1) + (check-equal? (hash-ref (first dtcs) 'dtc) "0x010870") + (check-equal? (hash-ref (first dtcs) 'status) "0x2f")) + + (test-case "clearing removes the DTC" + ;; 0x14 answers with the bare positive SID, which the channel reports + ;; as an empty payload. + (define cleared (sim-channel-request ch (uds-clear-dtcs #xFFFFFF) 1000 5000)) + (check-true (uds-request-result-ok cleared)) + (check-true (uds-request-result-positive cleared)) + (check-equal? (uds-request-result-response-hex cleared) "") + (check-equal? (hash-ref (dtc-request (uds-read-dtcs #xFF)) 'dtcs) '())) + + (test-case "malformed requests are rejected with ISO NRCs" + (define result (sim-channel-request ch (list #x19 #x02) 1000 5000)) + (check-false (uds-request-result-positive result)) + (check-equal? (uds-request-result-nrc result) "incorrectMessageLength"))) diff --git a/racket/benchpilot/diagnostics/uds/protocol.rkt b/racket/benchpilot/diagnostics/uds/protocol.rkt index 2b0fab7..c2cb16f 100644 --- a/racket/benchpilot/diagnostics/uds/protocol.rkt +++ b/racket/benchpilot/diagnostics/uds/protocol.rkt @@ -31,6 +31,9 @@ uds-transfer-data uds-request-transfer-exit uds-ecu-reset + uds-read-dtcs + uds-clear-dtcs + parse-dtc-response uds-address-length make-uds-client uds-send @@ -149,6 +152,46 @@ (define (uds-tester-present [response-required #t]) (list sid-tester-present (if response-required #x00 #x80))) +(define sid-read-dtc-information #x19) +(define sid-clear-diagnostic-information #x14) + +(define (uds-read-dtcs [status-mask #xFF]) + (list sid-read-dtc-information #x02 status-mask)) + +(define (uds-clear-dtcs [group #xFFFFFF]) + (list sid-clear-diagnostic-information + (bitwise-and (arithmetic-shift group -16) #xFF) + (bitwise-and (arithmetic-shift group -8) #xFF) + (bitwise-and group #xFF))) + +;; 59 02 ( )* +(define (parse-dtc-response payload) + ;; payload = positive response bytes after the SID: [02, avail, records...] + (if (or (< (length payload) 2) (not (= (first payload) #x02))) + 'unsupported + (let ([available (second payload)] + [rest (list-tail payload (min 2 (length payload)))]) + (hasheq 'availableMask available + 'dtcs + (let build ([rest rest]) + (if (< (length rest) 4) + '() + (cons (hasheq 'dtc + (format "0x~a" + (string-upcase + (~r (+ (* (first rest) 65536) + (* (second rest) 256) + (third rest)) + #:base 16 + #:min-width 6 + #:pad-string "0"))) + 'status (format "0x~a" + (~r (fourth rest) + #:base 16 + #:min-width 2 + #:pad-string "0"))) + (build (list-tail rest 4))))))))) + (define (uds-read-did did) (list sid-read-data-by-identifier (bitwise-and (arithmetic-shift did -8) #xFF) From 3eee9ff841447928a22d8d504094c0002d3a42ee Mon Sep 17 00:00:00 2001 From: jrtxio Date: Fri, 2 Oct 2026 17:11:52 +0800 Subject: [PATCH 4/8] features: Security Provider abstraction for vendor seed-key algorithms - diagnostics/security-provider: command: deriver names run an external executable with the seed as hex; failures surface as failed security-access steps - flash engine: unknown deriver names fall back through the provider resolver after the builtin table - 3 tests incl. a real shell script round trip --- .../benchpilot/diagnostics/flash/engine.rkt | 6 +- .../diagnostics/security-provider-test.rkt | 40 ++++++++++ .../diagnostics/security-provider.rkt | 80 +++++++++++++++++++ 3 files changed, 125 insertions(+), 1 deletion(-) create mode 100644 racket/benchpilot/diagnostics/security-provider-test.rkt create mode 100644 racket/benchpilot/diagnostics/security-provider.rkt diff --git a/racket/benchpilot/diagnostics/flash/engine.rkt b/racket/benchpilot/diagnostics/flash/engine.rkt index 7f9363d..639c209 100644 --- a/racket/benchpilot/diagnostics/flash/engine.rkt +++ b/racket/benchpilot/diagnostics/flash/engine.rkt @@ -11,6 +11,7 @@ (require benchpilot/core/contracts benchpilot/core/bench-runtime + benchpilot/diagnostics/security-provider benchpilot/diagnostics/uds/protocol) (provide (struct-out exn:fail:flash) @@ -142,7 +143,10 @@ ;; 2. Security access (optional). (when (uds-flash-plan-security-level plan) (define deriver-name (uds-flash-plan-key-deriver plan)) - (define deriver (and deriver-name (hash-ref (flash-engine-key-derivers engine) deriver-name #f))) + (define deriver + (and deriver-name + (or (hash-ref (flash-engine-key-derivers engine) deriver-name #f) + (resolve-key-deriver deriver-name)))) (unless deriver (fail! (format "Plan references key deriver '~a' but no such deriver is registered." deriver-name))) diff --git a/racket/benchpilot/diagnostics/security-provider-test.rkt b/racket/benchpilot/diagnostics/security-provider-test.rkt new file mode 100644 index 0000000..96496d5 --- /dev/null +++ b/racket/benchpilot/diagnostics/security-provider-test.rkt @@ -0,0 +1,40 @@ +#lang racket/base + +;; Security Provider: an external command computes the security key from the +;; seed (`command:` deriver names), so vendor algorithms stay in vendor +;; binaries while Core only sees bytes. + +(module+ test + (require benchpilot/diagnostics/flash/engine + benchpilot/diagnostics/security-provider + racket/file + racket/format + racket/runtime-path + rackunit) + + (test-case "external command provider computes the key from the seed" + (define script-path (make-temporary-file "keyprov-~a.sh")) + (display-to-file + #<