AtlatestRepositorysigil-web
1
;;; (sigil web routes) - Path-based Request Routing2
;;;3
;;; Provides routing functionality for web applications.4
;;; Routes are matched in order; first match wins.5
;;;6
;;; Example:7
;;; (define app8
;;; (router9
;;; (route method: GET pattern: "/" handler: home-handler)10
;;; (route method: GET pattern: "/users/:id" handler: user-handler)11
;;; (route method: POST pattern: "/api/login" handler: login-handler)12
;;; (route method: ANY pattern: "/static/*path" handler: static-handler)))13
;;;14
;;; `method:` defaults to POST when omitted.16
(define-library (sigil web routes)17
(import (sigil core)18
(sigil string)19
(sigil struct)20
(sigil http request))22
(export23
;; HTTP method symbols24
GET POST PUT DELETE PATCH OPTIONS HEAD ANY26
;; Route creation27
route28
route-method29
route-pattern30
route-handler32
;; Router creation33
router34
make-router36
;; Path parameter extraction37
path-param38
path-params40
;; Route combination41
routes)43
(begin45
;; ============================================================46
;; Route Record47
;; ============================================================49
;;; A route consists of a method, pattern, and handler.50
;;;51
;;; `method:` is an HTTP-method symbol (`GET`, `POST`, `ANY`, ...) and52
;;; defaults to `POST` when omitted. A `"post"` string is accepted too and53
;;; normalized at match time.54
(define-struct route55
(method default: 'POST) ; Symbol: 'GET, 'POST, 'ANY, etc. (or string)56
(pattern) ; String: "/users/:id" or "/static/*path"57
(handler)) ; Procedure: (request) -> response59
;; ============================================================60
;; Pattern Matching61
;; ============================================================63
;;; Parse a route pattern into segments64
;;; Returns list of: string (literal), (:param name), (*splat name)65
(define (parse-pattern pattern)66
(let ((segments (string-split pattern "/")))67
;; Filter empty strings first, then parse each segment68
(map parse-segment69
(filter (lambda (s) (not (string=? s ""))) segments))))71
;;; Parse a single path segment72
(define (parse-segment seg)73
(cond74
((and (> (string-length seg) 0)75
(char=? (string-ref seg 0) #\:))76
;; Named parameter :id -> (:param "id")77
(list ':param (substring seg 1 (string-length seg))))78
((and (> (string-length seg) 0)79
(char=? (string-ref seg 0) #\*))80
;; Splat parameter *path -> (*splat "path")81
(list '*splat (substring seg 1 (string-length seg))))82
(else83
;; Literal segment84
seg)))86
;;; Match a path against a parsed pattern87
;;; Returns alist of params on match, #f on no match88
(define (match-pattern parsed-pattern path)89
(let ((path-segments (filter (lambda (s) (not (string=? s "")))90
(string-split path "/"))))91
(match-segments parsed-pattern path-segments '())))93
;;; Match path segments against pattern segments94
(define (match-segments pattern-segs path-segs params)95
(cond96
;; Both empty - match!97
((and (null? pattern-segs) (null? path-segs))98
params)99
;; Pattern empty but path has more - no match100
((null? pattern-segs)101
#f)102
;; Check first pattern segment103
(else104
(let ((pat (car pattern-segs)))105
(cond106
;; Splat - captures rest of path107
((and (pair? pat) (eq? (car pat) '*splat))108
(let ((name (cadr pat))109
(rest-path (string-join path-segs "/")))110
(cons (cons name rest-path) params)))111
;; Path empty but pattern wants more - no match (unless splat handled above)112
((null? path-segs)113
#f)114
;; Named parameter - captures one segment115
((and (pair? pat) (eq? (car pat) ':param))116
(let ((name (cadr pat)))117
(match-segments (cdr pattern-segs)118
(cdr path-segs)119
(cons (cons name (car path-segs)) params))))120
;; Literal - must match exactly121
((string? pat)122
(if (string=? pat (car path-segs))123
(match-segments (cdr pattern-segs)124
(cdr path-segs)125
params)126
#f))127
;; Unknown pattern type128
(else #f))))))130
;; ============================================================131
;; Router132
;; ============================================================134
;;; Normalize an HTTP method to an upcased symbol.135
;;; Accepts a symbol ('GET, 'post) or string ("get", "POST").136
(define (normalize-method m)137
(cond138
((symbol? m) (string->symbol (string-upcase (symbol->string m))))139
((string? m) (string->symbol (string-upcase m)))140
(else m)))142
;;; Does a route's method match a request's method?143
;;; 'ANY matches everything; otherwise compare normalized methods so144
;;; symbol/string and case differences don't matter.145
(define (method-matches? route-meth req-meth)146
(or (eq? route-meth 'ANY)147
(eq? (normalize-method route-meth)148
(normalize-method req-meth))))150
;;; Create a router from a list of routes151
;;; Returns a handler function: (request) -> response or #f152
(define (make-router routes)153
(: list? -> procedure?)154
(lambda (request)155
(let ((method (http-request-method request))156
(path (http-request-path request)))157
(let loop ((routes routes))158
(if (null? routes)159
#f ; No route matched160
(let* ((r (car routes))161
(route-meth (route-method r))162
(pattern (route-pattern r))163
(handler (route-handler r)))164
(if (method-matches? route-meth method)165
(let ((params (match-pattern (parse-pattern pattern) path)))166
(if params167
;; Match! Add params to request context and call handler168
(let ((req-with-params169
(http-request-with-context170
request171
path-params:172
params)))173
(handler req-with-params))174
;; Pattern didn't match, try next route175
(loop (cdr routes))))176
;; Method didn't match, try next route177
(loop (cdr routes)))))))))179
;;; Convenience function for creating routers.180
;;; Usage: (router (route method: GET pattern: "/" handler: handler1)181
;;; (route method: POST pattern: "/api" handler: handler2))182
(define (router . routes)183
(: any? ... -> procedure?)184
(make-router routes))186
;; ============================================================187
;; Path Parameter Access188
;; ============================================================190
;;; Get a path parameter from request191
;;; Returns value or #f if not found192
(define (path-param request name)193
(: any? string? -> any?)194
(let ((params (http-request-context-ref request path-params: '())))195
(let ((pair (assoc name params)))196
(if pair (cdr pair) #f))))198
;;; Get all path parameters from request199
(define (path-params request)200
(: any? -> list?)201
(http-request-context-ref request path-params: '()))203
;; ============================================================204
;; HTTP Method Symbols205
;; ============================================================207
(define GET 'GET)208
(define POST 'POST)209
(define PUT 'PUT)210
(define DELETE 'DELETE)211
(define PATCH 'PATCH)212
(define OPTIONS 'OPTIONS)213
(define HEAD 'HEAD)214
(define ANY 'ANY)216
;; ============================================================217
;; Route Combination218
;; ============================================================220
;;; Combine multiple handlers into a single handler.221
;;;222
;;; Returns the first non-#f response. Use with the threading macro223
;;; to build middleware chains:224
;;;225
;;; ```scheme226
;;; (-> (routes api-routes page-routes static-handler)227
;;; (with-logging)228
;;; (with-not-found))229
;;; ```230
(define (routes . handlers)231
(: procedure? ... -> procedure?)232
(lambda (request)233
(let loop ((handlers handlers))234
(if (null? handlers)235
#f236
(let ((response ((car handlers) request)))237
(if response238
response239
(loop (cdr handlers))))))))241
))