rose-ash/lib/host/tests/sxtp.sx

;; 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)
(host-sx-test "patch?" (sxtp/patch? (sxtp/patch "#x" {})) true)
(host-sx-test "patch not event" (sxtp/event? (sxtp/patch "#x" {})) false)
(host-sx-test "signals?" (sxtp/signals? (sxtp/signals {:n 3} {})) true)
(host-sx-test "signals not patch" (sxtp/patch? (sxtp/signals {:n 3} {})) false)

;; ── 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)

;; ── patch + signals (Datastar-borrowed) ───────────────────────────
;; Mode defaults to outer; accepts string OR symbol input.
(host-sx-test
  "patch default mode is outer symbol"
  (symbol->string (sxtp/mode (sxtp/patch "#x" {})))
  "outer")
(host-sx-test
  "patch accepts symbol mode"
  (symbol->string (sxtp/mode (sxtp/patch "#x" {:mode (string->symbol "inner")})))
  "inner")
(host-sx-test
  "patch accepts string mode and normalises"
  (symbol->string (sxtp/mode (sxtp/patch "#x" {:mode "append"})))
  "append")
(host-sx-test
  "patch target accessor"
  (sxtp/target (sxtp/patch "#cart" {}))
  "#cart")
(host-sx-test
  "patch serialises with target/mode/body in fixed order"
  (sxtp/serialize (sxtp/patch "#x" {:body "hi"}))
  "(patch :target \"#x\" :mode outer :body \"hi\")")
(host-sx-test
  "patch remove mode serialises without :body"
  (sxtp/serialize (sxtp/patch "#x" {:mode "remove"}))
  "(patch :target \"#x\" :mode remove)")
(host-sx-test
  "patch transition? predicate"
  (sxtp/transition? (sxtp/patch "#x" {:transition true}))
  true)

(host-sx-test
  "signals accessor"
  (get (sxtp/values (sxtp/signals {:cart/count 3} {})) :cart/count)
  3)
(host-sx-test
  "signals only-if-missing default false"
  (sxtp/only-if-missing? (sxtp/signals {:n 1} {}))
  false)
(host-sx-test
  "signals only-if-missing true round-trips"
  (sxtp/only-if-missing? (sxtp/signals {:n 1} {:only-if-missing true}))
  true)
(host-sx-test
  "signals serialise"
  (sxtp/serialize (sxtp/signals {:cart/count 3} {}))
  "(signals :values {:cart/count 3})")

;; ── round-trip ────────────────────────────────────────────────────
(define host-sx-patch-rt
  (sxtp/parse (sxtp/serialize (sxtp/patch "#mini" {:mode "inner" :body "n=3"}))))
(host-sx-test "patch rt msg" (sxtp/patch? host-sx-patch-rt) true)
(host-sx-test "patch rt target" (sxtp/target host-sx-patch-rt) "#mini")
(host-sx-test "patch rt mode" (symbol->string (sxtp/mode host-sx-patch-rt)) "inner")
(define host-sx-signals-rt
  (sxtp/parse (sxtp/serialize (sxtp/signals {:a 1 :b "x"} {:only-if-missing true}))))
(host-sx-test "signals rt msg" (sxtp/signals? host-sx-signals-rt) true)
(host-sx-test "signals rt values"
  (get (sxtp/values host-sx-signals-rt) :a) 1)
(host-sx-test "signals rt only-if-missing"
  (sxtp/only-if-missing? host-sx-signals-rt) true)

;; ── 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)

;; ── engine<->server write wire: serialize (engine) <-> host/sx-body (server) ──
;; A boosted form posts (serialize {field->value}) as text/sx; the server reads it
;; back with host/sx-body. This is the SX write wire, verified with NO DOM (client-
;; agnostic): what the engine's serialize emits, host/sx-body must parse back
;; losslessly — including sx_content full of the quotes/parens that would break a
;; naive encoder. (The server side is what conformance can prove; the DOM field-read
;; is the one irreducibly-browser bit, left to a Playwright smoke.)
(define host-sx-wire-content "(article (h1 \"Title\") (p \"He said \\\"hi\\\" (x)\"))")
(define host-sx-wire-req
  (dream-request "POST" "/x" {:content-type "text/sx"}
    (serialize {:title "Hi there" :sx_content host-sx-wire-content :status "published"})))
(host-sx-test "sx-body round-trips a serialized field dict"
  (get (host/sx-body host-sx-wire-req) "title") "Hi there")
(host-sx-test "sx-body preserves quoted/parenthesised sx_content losslessly"
  (get (host/sx-body host-sx-wire-req) "sx_content") host-sx-wire-content)
(host-sx-test "field reads a text/sx body by content-type"
  (host/field host-sx-wire-req "status") "published")
(host-sx-test "field falls back to urlencoded form (the no-engine path)"
  (host/field (dream-request "POST" "/x"
                {:content-type "application/x-www-form-urlencoded"}
                "title=From+Form&status=draft") "title")
  "From Form")

(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}))