diff --git a/lib/host/conformance.sh b/lib/host/conformance.sh index c89c4beb..a16d569a 100755 --- a/lib/host/conformance.sh +++ b/lib/host/conformance.sh @@ -56,6 +56,7 @@ MODULES=( "lib/dream/router.sx" "lib/host/handler.sx" "lib/host/middleware.sx" + "lib/host/sxtp.sx" "lib/host/router.sx" "lib/host/feed.sx" ) @@ -64,6 +65,7 @@ MODULES=( SUITES=( "handler host-hd-tests-run! lib/host/tests/handler.sx" "middleware host-mw-tests-run! lib/host/tests/middleware.sx" + "sxtp host-sx-tests-run! lib/host/tests/sxtp.sx" "router host-rt-tests-run! lib/host/tests/router.sx" "feed host-fd-tests-run! lib/host/tests/feed.sx" ) diff --git a/lib/host/sxtp.sx b/lib/host/sxtp.sx new file mode 100644 index 00000000..f6ff211c --- /dev/null +++ b/lib/host/sxtp.sx @@ -0,0 +1,173 @@ +;; lib/host/sxtp.sx — SXTP, the host<->subsystem wire format. SXTP messages are +;; SX s-expressions (content-type text/sx): a request/response/condition/event is +;; a tagged list `(request :verb navigate :path "/x" ...)`. See the protocol spec +;; at applications/sxtp/spec.sx. +;; +;; Representation: internally a message is a plain dict tagged by :msg ("request" +;; /"response"/"condition"/"event"), with string keys so the keyword==string rule +;; makes construction and access trivial. verb/status/type are stored as SYMBOLS +;; (they ride the wire bare, not quoted). The wire LIST form is produced/consumed +;; only at the serialise/parse boundary: +;; sxtp/serialize : msg-dict -> text/sx string +;; sxtp/parse : text/sx string -> msg-dict +;; A Dream HTTP request/response bridges to/from SXTP via sxtp/from-dream and +;; sxtp/to-dream, so the host can speak SXTP to subsystems while serving HTTP. +;; Depends on lib/dream/types.sx (dream-response + request/response accessors). + +;; ── helpers ──────────────────────────────────────────────────────── +(define sxtp/-sym + (fn (x) (if (= (type-of x) "symbol") x (string->symbol x)))) +(define sxtp/-name + (fn (x) (if (= (type-of x) "symbol") (symbol->string x) x))) + +;; ── constructors ─────────────────────────────────────────────────── +;; opts is a dict of optional fields (e.g. {:headers .. :params .. :body ..}). +(define sxtp/request + (fn (verb path opts) + (merge {:msg "request" :verb (sxtp/-sym verb) :path path} opts))) +(define sxtp/response + (fn (status opts) + (merge {:msg "response" :status (sxtp/-sym status)} opts))) +(define sxtp/condition + (fn (ctype opts) + (merge {:msg "condition" :type (sxtp/-sym ctype)} opts))) +(define sxtp/event + (fn (etype opts) + (merge {:msg "event" :type (sxtp/-sym etype)} opts))) + +;; ── predicates ───────────────────────────────────────────────────── +(define sxtp/-is? + (fn (m tag) (and (= (type-of m) "dict") (= (get m :msg) tag)))) +(define sxtp/request? (fn (m) (sxtp/-is? m "request"))) +(define sxtp/response? (fn (m) (sxtp/-is? m "response"))) +(define sxtp/condition? (fn (m) (sxtp/-is? m "condition"))) +(define sxtp/event? (fn (m) (sxtp/-is? m "event"))) + +;; ── accessors ────────────────────────────────────────────────────── +(define sxtp/verb (fn (m) (get m :verb))) +(define sxtp/path (fn (m) (get m :path))) +(define sxtp/req-headers (fn (m) (get m :headers))) +(define sxtp/params (fn (m) (get m :params))) +(define sxtp/param (fn (m name) (get (get m :params) name))) +(define sxtp/body (fn (m) (get m :body))) +(define sxtp/capabilities (fn (m) (get m :capabilities))) +(define sxtp/status (fn (m) (get m :status))) +(define sxtp/resp-headers (fn (m) (get m :headers))) +(define sxtp/stream? (fn (m) (= (get m :stream) true))) +(define sxtp/cond-type (fn (m) (get m :type))) +(define sxtp/cond-message (fn (m) (get m :message))) + +;; ── status helpers (build responses) ─────────────────────────────── +(define sxtp/ok (fn (body) (sxtp/response "ok" {:body body}))) +(define sxtp/created (fn (body) (sxtp/response "created" {:body body}))) +(define sxtp/no-content (fn () (sxtp/response "no-content" {}))) +(define sxtp/not-found + (fn (path message) + (sxtp/response "not-found" + {:body (sxtp/condition "resource-not-found" + {:path path :message message :retry false})}))) +(define sxtp/forbidden + (fn (message) + (sxtp/response "forbidden" + {:body (sxtp/condition "forbidden" {:message message})}))) +(define sxtp/invalid + (fn (message) + (sxtp/response "invalid" + {:body (sxtp/condition "invalid" {:message message})}))) +(define sxtp/fail + (fn (message) + (sxtp/response "error" + {:body (sxtp/condition "error" {:message message})}))) + +;; ── HTTP <-> SXTP mappings ───────────────────────────────────────── +(define sxtp/-method-verbs + {:GET "fetch" :HEAD "fetch" :POST "create" + :PUT "mutate" :PATCH "mutate" :DELETE "delete" :OPTIONS "inspect"}) +(define sxtp/verb-for-method + (fn (method) (sxtp/-sym (get sxtp/-method-verbs (upper method) "fetch")))) + +(define sxtp/-status-http + {:ok 200 :created 201 :accepted 202 :no-content 204 :redirect 302 + :not-modified 304 :error 500 :not-found 404 :forbidden 403 + :invalid 400 :conflict 409 :unavailable 503}) +(define sxtp/http-status + (fn (status) (get sxtp/-status-http (sxtp/-name status) 200))) + +;; ── Dream bridge ─────────────────────────────────────────────────── +;; HTTP request -> SXTP request: method->verb, query->params, headers/body carry. +(define sxtp/from-dream + (fn (req) + (sxtp/request + (sxtp/verb-for-method (get req :method)) + (get req :path) + {:headers (get req :headers) + :params (get req :query) + :body (get req :body)}))) + +;; SXTP response -> HTTP response: status->code, body serialised to text/sx. +(define sxtp/-body-text + (fn (b) (if (nil? b) "" (serialize b)))) +(define sxtp/to-dream + (fn (resp) + (dream-response + (sxtp/http-status (sxtp/status resp)) + (merge {:content-type "text/sx"} (or (sxtp/resp-headers resp) {})) + (sxtp/-body-text (sxtp/body resp))))) + +;; ── wire serialise (msg-dict -> text/sx) ─────────────────────────── +;; Top-level field order is fixed per message type so output is deterministic; +;; nested dict/value order follows the serialize primitive. +(define sxtp/-field-order + {:request (list :verb :path :headers :cookies :params :capabilities :body) + :response (list :status :headers :set-cookie :body :stream) + :condition (list :type :message :path :retry :detail) + :event (list :type :id :body :time)}) +;; A nested SXTP message (a condition/event in a :body) serialises in its own +;; list form; plain data values go through the serialize primitive. +(define sxtp/-emit-value + (fn (v) + (if (and (= (type-of v) "dict") (has-key? v :msg)) + (sxtp/serialize v) + (serialize v)))) +(define sxtp/serialize + (fn (msg) + (let ((head (get msg :msg))) + (let ((order (get sxtp/-field-order head))) + (str "(" + head + (reduce + (fn (acc k) + (if (has-key? msg k) + (str acc " :" k " " (sxtp/-emit-value (get msg k))) + acc)) + "" + order) + ")"))))) + +;; ── wire parse (text/sx -> msg-dict) ─────────────────────────────── +;; parse yields a list with keyword-token keys and possibly keyword-token dict +;; keys; sxtp/-normalize deep-converts those tokens to strings so the result is +;; the same string-keyed shape the constructors produce. +(define sxtp/-normalize + (fn (v) + (let ((t (type-of v))) + (cond + ((= t "keyword") (str v)) + ((= t "dict") + (reduce + (fn (acc k) (assoc acc (str k) (sxtp/-normalize (get v k)))) + {} + (keys v))) + ((= t "list") (map sxtp/-normalize v)) + (true v))))) +(define sxtp/-pairs->dict + (fn (kvs acc) + (if (< (len kvs) 2) + acc + (sxtp/-pairs->dict + (rest (rest kvs)) + (assoc acc (str (first kvs)) (sxtp/-normalize (first (rest kvs)))))))) +(define sxtp/parse + (fn (text) + (let ((lst (parse text))) + (sxtp/-pairs->dict (rest lst) {:msg (symbol->string (first lst))})))) diff --git a/lib/host/tests/sxtp.sx b/lib/host/tests/sxtp.sx new file mode 100644 index 00000000..0abeaf53 --- /dev/null +++ b/lib/host/tests/sxtp.sx @@ -0,0 +1,129 @@ +;; lib/host/tests/sxtp.sx — SXTP message algebra, wire serialise/parse round-trip, +;; and the Dream HTTP <-> SXTP bridge. + +(define host-sx-pass 0) +(define host-sx-fail 0) +(define host-sx-fails (list)) + +(define + host-sx-test + (fn + (name actual expected) + (if + (= actual expected) + (set! host-sx-pass (+ host-sx-pass 1)) + (begin + (set! host-sx-fail (+ host-sx-fail 1)) + (append! host-sx-fails {:name name :actual actual :expected expected}))))) + +;; ── constructors + predicates ────────────────────────────────────── +(define host-sx-req (sxtp/request "navigate" "/x" {:headers {:host "h"}})) +(define host-sx-resp (sxtp/ok {:id "e1"})) + +(host-sx-test "request?" (sxtp/request? host-sx-req) true) +(host-sx-test "request not response" (sxtp/response? host-sx-req) false) +(host-sx-test "response?" (sxtp/response? host-sx-resp) true) +(host-sx-test "condition?" (sxtp/condition? (sxtp/condition "x" {})) true) + +;; ── accessors (verb/status are symbols) ──────────────────────────── +(host-sx-test "verb" (symbol->string (sxtp/verb host-sx-req)) "navigate") +(host-sx-test "path" (sxtp/path host-sx-req) "/x") +(host-sx-test "req header" (get (sxtp/req-headers host-sx-req) :host) "h") +(host-sx-test "status" (symbol->string (sxtp/status host-sx-resp)) "ok") +(host-sx-test "body" (get (sxtp/body host-sx-resp) :id) "e1") + +;; ── status helpers ───────────────────────────────────────────────── +(host-sx-test "created status" (symbol->string (sxtp/status (sxtp/created {}))) "created") +(host-sx-test + "not-found status" + (symbol->string (sxtp/status (sxtp/not-found "/p" "gone"))) + "not-found") +(host-sx-test + "not-found body is condition" + (sxtp/condition? (sxtp/body (sxtp/not-found "/p" "gone"))) + true) +(host-sx-test + "forbidden message" + (sxtp/cond-message (sxtp/body (sxtp/forbidden "no"))) + "no") + +;; ── serialise (deterministic top-level field order) ──────────────── +(host-sx-test + "serialize request" + (sxtp/serialize host-sx-req) + "(request :verb navigate :path \"/x\" :headers {:host \"h\"})") +(host-sx-test + "serialize ok" + (sxtp/serialize (sxtp/ok {:id "e1"})) + "(response :status ok :body {:id \"e1\"})") +;; nested condition rides the wire in its (condition ...) list form, no :msg leak. +(host-sx-test + "serialize nested condition as list" + (contains? + (sxtp/serialize (sxtp/not-found "/p" "gone")) + "(condition :type resource-not-found") + true) +(host-sx-test + "serialize no :msg leak" + (contains? (sxtp/serialize host-sx-resp) ":msg") + false) + +;; ── parse + round-trip ───────────────────────────────────────────── +(define host-sx-parsed + (sxtp/parse "(request :verb query :path \"/events\" :headers {:host \"h\"})")) +(host-sx-test "parse msg type" (sxtp/request? host-sx-parsed) true) +(host-sx-test "parse verb" (symbol->string (sxtp/verb host-sx-parsed)) "query") +(host-sx-test "parse path" (sxtp/path host-sx-parsed) "/events") +(host-sx-test + "parse nested header normalised" + (get (sxtp/req-headers host-sx-parsed) :host) + "h") + +(define host-sx-rt (sxtp/parse (sxtp/serialize (sxtp/ok {:id "e1" :n 3})))) +(host-sx-test "round-trip status" (symbol->string (sxtp/status host-sx-rt)) "ok") +(host-sx-test "round-trip body id" (get (sxtp/body host-sx-rt) :id) "e1") +(host-sx-test "round-trip body n" (get (sxtp/body host-sx-rt) :n) 3) + +;; ── HTTP <-> SXTP mappings ───────────────────────────────────────── +(host-sx-test "verb GET->fetch" (symbol->string (sxtp/verb-for-method "GET")) "fetch") +(host-sx-test "verb POST->create" (symbol->string (sxtp/verb-for-method "POST")) "create") +(host-sx-test "verb DELETE->delete" (symbol->string (sxtp/verb-for-method "DELETE")) "delete") +(host-sx-test "verb unknown->fetch" (symbol->string (sxtp/verb-for-method "WIBBLE")) "fetch") +(host-sx-test "http ok->200" (sxtp/http-status (string->symbol "ok")) 200) +(host-sx-test "http not-found->404" (sxtp/http-status (string->symbol "not-found")) 404) + +;; ── Dream bridge ─────────────────────────────────────────────────── +(define host-sx-from + (sxtp/from-dream (dream-request "POST" "/feed?a=1" {} "hi"))) +(host-sx-test "from-dream verb" (symbol->string (sxtp/verb host-sx-from)) "create") +(host-sx-test "from-dream path" (sxtp/path host-sx-from) "/feed") +(host-sx-test "from-dream param" (sxtp/param host-sx-from "a") "1") +(host-sx-test "from-dream body" (sxtp/body host-sx-from) "hi") + +(define host-sx-tod (sxtp/to-dream (sxtp/ok {:id "e1"}))) +(host-sx-test "to-dream status" (dream-status host-sx-tod) 200) +(host-sx-test + "to-dream content-type text/sx" + (dream-resp-header host-sx-tod "content-type") + "text/sx") +(host-sx-test + "to-dream body is sx text" + (dream-resp-body host-sx-tod) + "{:id \"e1\"}") +(host-sx-test + "to-dream not-found->404" + (dream-status (sxtp/to-dream (sxtp/not-found "/p" "gone"))) + 404) +(host-sx-test + "to-dream forbidden->403" + (dream-status (sxtp/to-dream (sxtp/forbidden "no"))) + 403) + +(define + host-sx-tests-run! + (fn + () + {:total (+ host-sx-pass host-sx-fail) + :passed host-sx-pass + :failed host-sx-fail + :fails host-sx-fails})) diff --git a/plans/host-on-sx.md b/plans/host-on-sx.md index bca44deb..83504b56 100644 --- a/plans/host-on-sx.md +++ b/plans/host-on-sx.md @@ -36,8 +36,8 @@ host — no `ocaml-on-sx` dependency. ## Status (rolling) -`bash lib/host/conformance.sh` → **43/43** (4 suites: handler, middleware, router, -feed). Phase 1 DONE; Phase 2 in progress (middleware + write endpoint DONE, SXTP next). +`bash lib/host/conformance.sh` → **82/82** (5 suites: handler, middleware, sxtp, +router, feed). Phases 1 & 2 DONE; Phase 3 (strangler ledger) next. ## Ground rules @@ -91,8 +91,15 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/… INJECTED resource extractor), `host/pipeline` (first = outermost). Reuses Dream's `dream-bearer-token` + `dream-catch-with`; calls lib/acl public API. Mute/prefs layer deferred (no blocker, add when a domain needs it). -- [ ] `sxtp.sx` — host↔subsystem wire format (align with existing spec at - `applications/sxtp/spec.sx`) +- [x] `sxtp.sx` — host↔subsystem wire format (per `applications/sxtp/spec.sx`). + Message algebra (`sxtp/request`/`response`/`condition`/`event` + status + helpers `sxtp/ok`/`created`/`not-found`/`forbidden`/`invalid`/`fail`) as + string-keyed dicts; verb/status/type as symbols (ride the wire bare). Codec: + `sxtp/serialize` (dict → `text/sx` list form, deterministic field order, + nested messages in their own list form, no `:msg` leak) and `sxtp/parse` + (`text/sx` → dict, deep keyword-token→string normaliser). Dream bridge: + `sxtp/from-dream` (HTTP req → SXTP req, method→verb, query→params) and + `sxtp/to-dream` (SXTP resp → HTTP resp, status→code, body→`text/sx`). - [x] migrate a write endpoint (auth + permission + action): `POST /feed` (`host/feed-write-routes resolve`) — auth ∘ ACL("post","feed") ∘ wrap-errors over `host/feed-create`, which parses the JSON body and `feed/post`s it (201); @@ -133,8 +140,19 @@ lib/host/sxtp.sx subsystem APIs (feed/search/commerce/… against lib/acl's public `acl/permit?` (string atoms work — no symbol coercion needed). The write path proves the auth ∘ permission ∘ action stack end-to-end: 401 unauth, 403 unpermitted, 201 + readback on success, 400 on bad body. - - **Remaining for Phase 2: `sxtp.sx`** — the host↔subsystem wire format. Align - with the existing spec at `applications/sxtp/spec.sx`. This is the next tick. +- **Phase 2 COMPLETE (82/82).** `lib/host/sxtp.sx` adds the SXTP codec + Dream + bridge (39-test suite). Key representation calls, learned by probing the runtime: + keywords are strings at eval time but the `serialize` primitive renders + string-keyed dicts back as `{:k v}` and symbols bare — so messages are + string-keyed dicts with verb/status/type as symbols, and a small str-based + emitter produces wire-faithful list form. `parse` needs a deep normaliser + because parsed keyword tokens are a distinct type (not `=` to string literals). + `unquote-splicing` is unreliable here, so the serializer is str-based, not + quasiquote-based. + - **Next: Phase 3 — strangler migration ledger.** Enumerate the Quart endpoints + (use the `rose-ash-services` `svc_routes` MCP tool), track migrated vs proxied, + and stand up a golden-response harness against the live Quart responses. Then + cut over the smallest whole domain (`likes` or `relations`) as proof. ## Blockers