rose-ash/lib/dream/router.sx

;; lib/dream/router.sx — Dream-on-SX routing.
;; Routes are dicts {:method :path :handler}; a router is a handler that
;; dispatches request -> response by method + path, extracting :name path
;; params and binding a ** catch-all. No path match -> 404; path matches but
;; method doesn't -> 405 + Allow. HEAD falls back to the GET handler with an
;; empty body. Depends on types.sx.

;; ── route constructors (one per HTTP method) ───────────────────────
(define dream-get (fn (path handler) (dream-route "GET" path handler)))
(define dream-post (fn (path handler) (dream-route "POST" path handler)))
(define dream-put (fn (path handler) (dream-route "PUT" path handler)))
(define
  dream-delete
  (fn (path handler) (dream-route "DELETE" path handler)))
(define dream-patch (fn (path handler) (dream-route "PATCH" path handler)))
(define dream-head (fn (path handler) (dream-route "HEAD" path handler)))
(define
  dream-options
  (fn (path handler) (dream-route "OPTIONS" path handler)))
(define dream-any (fn (path handler) (dream-route "ANY" path handler)))

;; ── path segmentation ──────────────────────────────────────────────
;; "/users/42/" -> ("users" "42"); "/" -> ()
(define
  dr/segs
  (fn (path) (filter (fn (s) (not (= s ""))) (split path "/"))))

(define
  dr/join-path
  (fn
    (prefix path)
    (str "/" (join "/" (concat (dr/segs prefix) (dr/segs path))))))

;; ── segment matching ───────────────────────────────────────────────
;; Returns a params dict on match (possibly empty {}), nil on no match.
(define
  dr/match-segs
  (fn
    (pat path params)
    (cond
      ((and (empty? pat) (empty? path)) params)
      ((empty? pat) nil)
      (else
        (let
          ((ps (first pat)))
          (cond
            ((= ps "**") (assoc params "**" (join "/" path)))
            ((empty? path) nil)
            ((starts-with? ps ":")
              (dr/match-segs
                (rest pat)
                (rest path)
                (assoc params (substr ps 1) (first path))))
            ((= ps (first path))
              (dr/match-segs (rest pat) (rest path) params))
            (else nil)))))))

;; path-only match: returns params dict or nil
(define
  dr/route-params
  (fn
    (r req)
    (dr/match-segs
      (dr/segs (dream-route-path r))
      (dr/segs (dream-path req))
      {})))

;; method acceptance: exact, ANY, or HEAD served by a GET route
(define
  dr/method-accepts?
  (fn
    (route-method req-method)
    (or
      (= route-method "ANY")
      (= route-method req-method)
      (and (= req-method "HEAD") (= route-method "GET")))))

;; ── middleware pipeline (shared with middleware.sx) ────────────────
;; m1 @@ m2 @@ handler = (m1 (m2 handler)); first in list is outermost.
(define
  dr/apply-middlewares
  (fn (mws handler) (reduce (fn (h mw) (mw h)) handler (reverse mws))))

;; ── scope: prefix mount + middleware chain ─────────────────────────
;; Returns a flat list of routes; nested scopes flatten correctly.
(define
  dr/flatten-routes
  (fn
    (items)
    (reduce
      (fn
        (acc it)
        (if
          (dream-route? it)
          (concat acc (list it))
          (concat acc (dr/flatten-routes it))))
      (list)
      items)))

(define
  dream-scope
  (fn
    (prefix middlewares routes)
    (map
      (fn
        (r)
        (dream-route
          (dream-route-method r)
          (dr/join-path prefix (dream-route-path r))
          (dr/apply-middlewares middlewares (dream-route-handler r))))
      (dr/flatten-routes routes))))

;; ── dispatch ───────────────────────────────────────────────────────
;; allowed = methods of routes whose PATH matched (for 405 + Allow).
(define
  dr/dispatch
  (fn
    (routes req allowed)
    (if
      (empty? routes)
      (if
        (empty? allowed)
        (dream-not-found)
        (dream-method-not-allowed allowed))
      (let
        ((r (first routes)))
        (let
          ((params (dr/route-params r req)))
          (if
            (nil? params)
            (dr/dispatch (rest routes) req allowed)
            (if
              (dr/method-accepts? (dream-route-method r) (dream-method req))
              (dr/run-route r req params)
              (dr/dispatch
                (rest routes)
                req
                (concat allowed (list (dream-route-method r)))))))))))

;; run a matched route; blank the body for an auto-HEAD on a GET route
(define
  dr/run-route
  (fn
    (r req params)
    (let
      ((resp (dream-coerce-response ((dream-route-handler r) (dream-with-params req params)))))
      (if
        (and
          (= (dream-method req) "HEAD")
          (not (= (dream-route-method r) "HEAD")))
        (dream-response (dream-status resp) (dream-headers resp) "")
        resp))))

;; 405 response with an Allow header listing the path's methods
(define
  dream-method-not-allowed
  (fn
    (allowed)
    (dream-add-header
      (dream-response 405 {:content-type "text/plain; charset=utf-8"} "Method Not Allowed")
      "allow"
      (join ", " allowed))))

(define
  dream-router
  (fn
    (routes)
    (let
      ((flat (dr/flatten-routes routes)))
      (fn (req) (dr/dispatch flat req (list))))))