rose-ash/lib/host/sxtp.sx

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