Port Sinatra framework to Jerboa
ober
25a06ae431664cf8b4dfecc48566115ceeb8fca1
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +build/ +*.so +*.wpo +*.o new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,26 @@ +JERBOA_HOME ?= $(HOME)/mine/jerboa +SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme +JERBUILD ?= $(JERBOA_HOME)/jerbuild.ss + +BUILD_DIR ?= build +SRC_STAGE := $(BUILD_DIR)/src +LIB_STAGE := $(BUILD_DIR)/lib +LIBDIRS := $(LIB_STAGE):$(JERBOA_HOME)/lib + +.PHONY: build test example clean + +build: + rm -rf $(SRC_STAGE) $(LIB_STAGE) + mkdir -p $(SRC_STAGE)/sinatra $(LIB_STAGE) + cp sinatra.ss sinatra-test.ss $(SRC_STAGE)/ + cp sinatra/*.ss $(SRC_STAGE)/sinatra/ + $(SCHEME) --libdirs $(JERBOA_HOME)/lib --script $(JERBUILD) $(SRC_STAGE) $(LIB_STAGE) --force + +test: build + $(SCHEME) --libdirs $(LIBDIRS) --script test-runner.ss + +example: build + $(SCHEME) --libdirs $(LIBDIRS) --script example.ss + +clean: + rm -rf $(BUILD_DIR) new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# jerboa-sinatra + +A Sinatra-style web framework ported to Jerboa. + +## Build + +```sh +make build +``` + +## Test + +```sh +make test +``` + +The Makefile uses `~/mine/jerboa` by default. Override with `JERBOA_HOME=/path/to/jerboa` if needed. new file mode 100644 --- /dev/null +++ b/example.ss @@ -0,0 +1,119 @@ +#!chezscheme +;;; example.ss - Jerboa-Sinatra feature showcase +;;; +;;; Run with: make example +;;; Then visit: http://127.0.0.1:4567/ + +(import (chezscheme) + (jerboa runtime) + (sinatra)) + +;; Configuration +(configure + (set-option! "port" 4567) + (enable! 'sessions) + (set-option! "session-secret" "super-secret-key-change-in-production")) + +;; Before filter - runs before every request +(before + (header! "X-Powered-By" "Jerboa-Sinatra")) + +;; Before filter - only for /admin/* routes +(before "/admin/*" + (unless (session-ref "user") + (redirect "/login"))) + +;; ---- Static pages ---- + +(GET "/" "Welcome to Jerboa-Sinatra!") + +(GET "/hello/:name" + (string-append "<h1>Hello, " (param "name") "!</h1>")) + +;; ---- JSON API ---- + +(GET "/api/users" + (json (hash ("users" (list + (hash ("id" 1) ("name" "Alice")) + (hash ("id" 2) ("name" "Bob"))))))) + +(GET "/api/users/:id" + (let ((id (param "id"))) + (json (hash ("id" id) ("name" "User"))))) + +(POST "/api/users" + (let ((body (sinatra-request-body-json (request)))) + (status! 201) + (json body))) + +;; ---- Session usage ---- + +(GET "/login" + "<form method='post' action='/login'> + <input name='user' placeholder='Username'> + <button type='submit'>Login</button> + </form>") + +(POST "/login" + (let ((body-params (sinatra-request-body-params (request)))) + (session-set! "user" (or (hash-get body-params "user") "anonymous")) + (redirect "/admin"))) + +(GET "/admin" + (let ((user (session-ref "user"))) + (string-append "Welcome, " (or user "unknown") "!"))) + +(GET "/logout" + (session-destroy!) + (redirect "/")) + +;; ---- Splat routes ---- + +(GET "/files/*" + (let ((path (car (splat)))) + (string-append "Requested file: " path))) + +;; ---- Redirects ---- + +(GET "/old-path" + (redirect "/new-path" 301)) + +(GET "/new-path" + "You've been redirected!") + +;; ---- Templates ---- + +(GET "/template" + (render-string "<h1>{{title}}</h1><p>{{message}}</p>" + (hash ("title" "Jerboa-Sinatra") + ("message" "Templates work!")))) + +(GET "/sxml" + (render-sxml + '(html + (head (title "SXML Demo")) + (body + (h1 "SXML Rendering") + (p "This page was generated from SXML.") + (ul + (li "Item 1") + (li "Item 2") + (li "Item 3")))))) + +;; ---- Error handlers ---- + +(not-found + "<h1>404</h1><p>Nothing here!</p>") + +(error-handler + (string-append "<h1>500</h1><p>Something went wrong</p>")) + +;; ---- Start the server ---- + +(displayln "Starting Jerboa-Sinatra example...") +(displayln "Visit http://127.0.0.1:4567/") +(let ((srv (RUN!))) + ;; Keep main thread alive. + (let loop () + (thread-sleep! 3600) + (loop))) new file mode 100644 --- /dev/null +++ b/sinatra-test.ss @@ -0,0 +1,22 @@ +(import (std test) + (sinatra route-test) + (sinatra context-test) + (sinatra helpers-test) + (sinatra cookies-test) + (sinatra session-test) + (sinatra template-test) + (sinatra middleware-test) + (sinatra handler-test)) + +(export sinatra-test) + +(def sinatra-test + (test-suite "jerboa-sinatra" + (run-test-suite! route-test) + (run-test-suite! context-test) + (run-test-suite! helpers-test) + (run-test-suite! cookies-test) + (run-test-suite! session-test) + (run-test-suite! template-test) + (run-test-suite! middleware-test) + (run-test-suite! handler-test))) new file mode 100644 --- /dev/null +++ b/sinatra.ss @@ -0,0 +1,100 @@ +;; Jerboa-Sinatra: A Sinatra-style web framework for Jerboa Scheme +;; +;; Usage: +;; (import (sinatra)) +;; (GET "/" "Hello World!") +;; (RUN!) + +(import (sinatra context) + (sinatra request) + (sinatra response) + (sinatra route) + (sinatra app) + (sinatra handler) + (sinatra helpers) + (sinatra filters) + (sinatra errors) + (sinatra cookies) + (sinatra session) + (sinatra static) + (sinatra template) + (sinatra middleware) + (sinatra logging) + (sinatra mime) + (sinatra dsl)) + +(export + ;; DSL macros (uppercase — wrap body in lambda) + GET POST PUT DELETE PATCH OPTIONS HEAD + ;; DSL functions (lowercase — take explicit lambda) + get post put delete* patch options head + ;; Filters + before after + ;; Error handlers + not-found error-handler + ;; Configuration + configure set-option! enable! disable! + ;; Middleware + use! + ;; Server + RUN! run! + + ;; Modular-style (explicit app) + sinatra-get sinatra-post sinatra-put sinatra-delete + sinatra-patch sinatra-options sinatra-head + sinatra-before sinatra-after + sinatra-not-found sinatra-error-handler + sinatra-run! + make-sinatra-app default-app + + ;; Context accessors + param param! params request response app splat captures + current-app current-request current-response current-params + + ;; Request accessors + sinatra-request? + sinatra-request-method sinatra-request-path sinatra-request-url + sinatra-request-query-string sinatra-request-query-params + sinatra-request-header sinatra-request-body-string + sinatra-request-body-json sinatra-request-body-params + sinatra-request-content-type sinatra-request-content-length + sinatra-request-host sinatra-request-ip + sinatra-request-xhr? sinatra-request-secure? + sinatra-request-user-agent sinatra-request-accept + + ;; Response helpers + halt pass redirect + status! headers! header! content-type! body! + json send-file attachment + etag! last-modified! cache-control! + url-for back + current-error env development? production? test? + + ;; Response object + sinatra-response-status sinatra-response-status-set! + sinatra-response-body sinatra-response-body-set! + sinatra-response-header sinatra-response-header-set! + sinatra-response-content-type sinatra-response-content-type-set! + + ;; Session + session session-ref session-set! session-delete! + session-clear! session-destroy! + + ;; Template + render-sxml render-file-template render-string views-path + + ;; Cookies + parse-cookie-header make-set-cookie + + ;; MIME + mime-type-for mime-type-for-ext mime-type-sym + + ;; Logging + sinatra-logger current-logger log-request + + ;; App settings + app-setting app-setting-set! app-enable! app-disable! + app-add-route! app-add-before! app-add-after! + app-set-not-found! app-set-error-handler! + app-add-middleware! + ) new file mode 100644 --- /dev/null +++ b/sinatra/app.ss @@ -0,0 +1,120 @@ +(import (sinatra route) + (sinatra context)) + +(export make-sinatra-app + app-add-route! + app-add-before! + app-add-after! + app-set-not-found! + app-set-error-handler! + app-setting + app-setting-set! + app-enable! + app-disable! + app-add-middleware! + app-routes + app-before-filters + app-after-filters + app-middleware + app-not-found-handler + app-error-handlers + app-environment + default-app + default-settings) + +;; Default settings hash +(def default-settings + (hash + ("port" 4567) + ("bind" "127.0.0.1") + ("public-folder" "./public") + ("views" "./views") + ("sessions" #f) + ("session-secret" #f) + ("static" #t) + ("logging" #t) + ("show-exceptions" #t) + ("dump-errors" #t) + ("method-override" #f) + ("default-content-type" "text/html; charset=utf-8") + ("environment" "development"))) + +;; App is a hash-table holding all registrations. +;; Using a hash-table rather than defclass to keep things simple +;; and avoid circular dependency issues. +(def (make-sinatra-app) + (let ((app (make-hash-table))) + (hash-put! app 'routes '()) + (hash-put! app 'before-filters '()) + (hash-put! app 'after-filters '()) + (hash-put! app 'error-handlers (make-hash-table)) + (hash-put! app 'not-found-handler #f) + (hash-put! app 'settings (hash-copy default-settings)) + (hash-put! app 'middleware '()) + (hash-put! app 'environment "development") + app)) + +;; Global default app for classic mode +(def default-app (make-sinatra-app)) + +;; Register a route +(def (app-add-route! app method pattern handler (conditions '())) + (let-values (((rx names) (compile-route-pattern pattern))) + (let ((rt (make-route method pattern rx names handler conditions))) + (hash-put! app 'routes + (append (hash-ref app 'routes) (list rt)))))) + +;; Register a before filter +(def (app-add-before! app pattern handler) + (hash-put! app 'before-filters + (append (hash-ref app 'before-filters) + (list (cons pattern handler))))) + +;; Register an after filter +(def (app-add-after! app pattern handler) + (hash-put! app 'after-filters + (append (hash-ref app 'after-filters) + (list (cons pattern handler))))) + +;; Set the 404 handler +(def (app-set-not-found! app handler) + (hash-put! app 'not-found-handler handler)) + +;; Set an error handler (keyed by symbol or status code) +(def (app-set-error-handler! app key handler) + (let ((handlers (hash-ref app 'error-handlers))) + (hash-put! handlers key handler))) + +;; Get a setting value +(def (app-setting app key) + (let ((settings (hash-ref app 'settings))) + (hash-get settings key))) + +;; Set a setting value +(def (app-setting-set! app key value) + (let ((settings (hash-ref app 'settings))) + (hash-put! settings key value))) + +;; Enable a setting (set to #t) +(def (app-enable! app key) + (app-setting-set! app (if (symbol? key) (symbol->string key) key) #t)) + +;; Disable a setting (set to #f) +(def (app-disable! app key) + (app-setting-set! app (if (symbol? key) (symbol->string key) key) #f)) + +;; Add middleware +(def (app-add-middleware! app mw) + (hash-put! app 'middleware + (append (hash-ref app 'middleware) (list mw)))) + +;; Accessors +(def (app-routes app) (hash-ref app 'routes)) +(def (app-before-filters app) (hash-ref app 'before-filters)) +(def (app-after-filters app) (hash-ref app 'after-filters)) +(def (app-middleware app) (hash-ref app 'middleware)) +(def (app-not-found-handler app) (hash-get app 'not-found-handler)) +(def (app-error-handlers app) (hash-ref app 'error-handlers)) + +(def (app-environment app) + (or (app-setting app "environment") "development")) new file mode 100644 --- /dev/null +++ b/sinatra/context-test.ss @@ -0,0 +1,43 @@ +(import (std test) + (sinatra context)) + +(export context-test) + +(def context-test + (test-suite "request context parameters" + + (test-case "param returns value from current-params" + (parameterize ((current-params (hash ("name" "Alice") ("age" "30")))) + (check (param "name") => "Alice") + (check (param "age") => "30"))) + + (test-case "param returns #f for missing key" + (parameterize ((current-params (hash ("name" "Alice")))) + (check (param "missing") => #f))) + + (test-case "param! returns value when present" + (parameterize ((current-params (hash ("name" "Alice")))) + (check (param! "name") => "Alice"))) + + (test-case "param! raises error when missing" + (parameterize ((current-params (hash))) + (check-exception (lambda () (param! "missing")) + (lambda (e) #t)))) + + (test-case "params returns the full hash" + (let ((p (hash ("a" 1) ("b" 2)))) + (parameterize ((current-params p)) + (check (params) => p)))) + + (test-case "splat returns empty list by default" + (parameterize ((current-params (hash))) + (check (splat) => '()))) + + (test-case "splat returns splat values" + (parameterize ((current-params (hash ("splat" (list "foo" "bar"))))) + (check (splat) => (list "foo" "bar")))) + + (test-case "captures returns captures values" + (parameterize ((current-params (hash ("captures" (list "a" "b"))))) + (check (captures) => (list "a" "b")))) + )) new file mode 100644 --- /dev/null +++ b/sinatra/context.ss @@ -0,0 +1,51 @@ +(export current-app + current-request + current-response + current-params + current-halt-k + current-pass-k + current-raw-response + param + param! + params + request + response + app + splat + captures) + +;; Dynamic parameters for request context +(def current-app (make-parameter #f)) +(def current-request (make-parameter #f)) +(def current-response (make-parameter #f)) +(def current-params (make-parameter (hash))) +(def current-halt-k (make-parameter #f)) +(def current-pass-k (make-parameter #f)) +(def current-raw-response (make-parameter #f)) + +;; Convenience accessors for use inside route handlers + +(def (param name) + (hash-get (current-params) name)) + +(def (param! name) + (or (hash-get (current-params) name) + (error "Missing required parameter" name))) + +(def (params) + (current-params)) + +(def (request) + (current-request)) + +(def (response) + (current-response)) + +(def (app) + (current-app)) + +(def (splat) + (or (hash-get (current-params) "splat") '())) + +(def (captures) + (or (hash-get (current-params) "captures") '())) new file mode 100644 --- /dev/null +++ b/sinatra/cookies-test.ss @@ -0,0 +1,57 @@ +(import (std test) + (sinatra cookies)) + +(export cookies-test) + +(def cookies-test + (test-suite "cookie parsing and generation" + + (test-case "parse simple cookie header" + (let ((cookies (parse-cookie-header "name=Alice; age=30"))) + (check (hash-ref cookies "name") => "Alice") + (check (hash-ref cookies "age") => "30"))) + + (test-case "parse single cookie" + (let ((cookies (parse-cookie-header "session=abc123"))) + (check (hash-ref cookies "session") => "abc123"))) + + (test-case "parse empty string" + (let ((cookies (parse-cookie-header ""))) + (check (hash->list cookies) => '()))) + + (test-case "parse #f" + (let ((cookies (parse-cookie-header #f))) + (check (hash->list cookies) => '()))) + + (test-case "make-set-cookie basic" + (let ((cookie (make-set-cookie "name" "Alice"))) + (check cookie ? string?) + ;; Should contain name=Alice + (check (string-contains cookie "name=Alice") ? values))) + + (test-case "make-set-cookie with path" + (let ((cookie (make-set-cookie "sid" "xyz" path: "/api"))) + (check (string-contains cookie "Path=/api") ? values))) + + (test-case "make-set-cookie with max-age" + (let ((cookie (make-set-cookie "sid" "xyz" max-age: 3600))) + (check (string-contains cookie "Max-Age=3600") ? values))) + + (test-case "make-set-cookie with secure" + (let ((cookie (make-set-cookie "sid" "xyz" secure: #t))) + (check (string-contains cookie "Secure") ? values))) + + (test-case "make-set-cookie with httponly" + (let ((cookie (make-set-cookie "sid" "xyz" http-only: #t))) + (check (string-contains cookie "HttpOnly") ? values))) + )) + +;; Helper: check if string contains substring +(def (string-contains haystack needle) + (let ((hlen (string-length haystack)) + (nlen (string-length needle))) + (let loop ((i 0)) + (cond + ((> (+ i nlen) hlen) #f) + ((string=? (substring haystack i (+ i nlen)) needle) i) + (else (loop (+ i 1))))))) new file mode 100644 --- /dev/null +++ b/sinatra/cookies.ss @@ -0,0 +1,83 @@ +(import (std net uri)) + +(export parse-cookie-header + make-set-cookie + request-cookies) + +;; Parse "Cookie: name=value; name2=value2" into hash-table +(def (parse-cookie-header header-str) + (let ((ht (make-hash-table))) + (when (and header-str (not (string=? header-str ""))) + (for-each + (lambda (pair-str) + (let* ((trimmed (str-trim pair-str)) + (eq-pos (string-index trimmed #\=))) + (when eq-pos + (let ((name (str-trim (substring trimmed 0 eq-pos))) + (value (str-trim (substring trimmed (+ eq-pos 1) + (string-length trimmed))))) + (hash-put! ht name (uri-decode value)))))) + (string-split header-str #\;))) + ht)) + +;; Generate a Set-Cookie header value +(def (make-set-cookie name value + path: (path "/") + domain: (domain #f) + max-age: (max-age #f) + expires: (expires #f) + secure: (secure #f) + http-only: (http-only #t) + same-site: (same-site "Lax")) + (let ((parts (list (string-append name "=" (uri-encode value)) + (string-append "Path=" path)))) + (when domain + (set! parts (append parts (list (string-append "Domain=" domain))))) + (when max-age + (set! parts (append parts (list (string-append "Max-Age=" (number->string max-age)))))) + (when expires + (set! parts (append parts (list (string-append "Expires=" expires))))) + (when secure + (set! parts (append parts (list "Secure")))) + (when http-only + (set! parts (append parts (list "HttpOnly")))) + (when same-site + (set! parts (append parts (list (string-append "SameSite=" same-site))))) + (string-join parts "; "))) + +;; Get cookies from a sinatra-request (by reading raw headers) +(def (request-cookies raw-req header-fn) + (let ((cookie-header (header-fn raw-req "Cookie"))) + (if cookie-header + (parse-cookie-header cookie-header) + (make-hash-table)))) + +;; Helper: join strings with separator +(def (string-join strings sep) + (if (null? strings) + "" + (let loop ((rest (cdr strings)) + (result (car strings))) + (if (null? rest) + result + (loop (cdr rest) + (string-append result sep (car rest))))))) + +;; Helper: find index of char in string +(def (string-index str ch) + (let loop ((i 0)) + (cond + ((>= i (string-length str)) #f) + ((char=? (string-ref str i) ch) i) + (else (loop (+ i 1)))))) + +;; Helper: trim whitespace +(def (str-trim s) + (let* ((len (string-length s)) + (start (let loop ((i 0)) + (if (and (< i len) (char-whitespace? (string-ref s i))) + (loop (+ i 1)) i))) + (end (let loop ((i (- len 1))) + (if (and (>= i start) (char-whitespace? (string-ref s i))) + (loop (- i 1)) (+ i 1))))) + (substring s start end))) new file mode 100644 --- /dev/null +++ b/sinatra/dsl.ss @@ -0,0 +1,199 @@ +(import (std net httpd) + (std format) + (sinatra app) + (sinatra handler) + (sinatra context) + (sinatra helpers)) + +(export GET POST PUT DELETE PATCH OPTIONS HEAD + get post put delete* patch options head + before after + not-found error-handler + configure + set-option! enable! disable! + use! + RUN! run! + sinatra-get sinatra-post sinatra-put sinatra-delete + sinatra-patch sinatra-options sinatra-head + sinatra-before sinatra-after + sinatra-not-found sinatra-error-handler + sinatra-run!) + +;; ============================================================ +;; Uppercase route macros — wrap body in lambda +;; ============================================================ + +(defrules GET () + ((_ pattern body ...) + (app-add-route! default-app 'GET pattern + (lambda () body ...)))) + +(defrules POST () + ((_ pattern body ...) + (app-add-route! default-app 'POST pattern + (lambda () body ...)))) + +(defrules PUT () + ((_ pattern body ...) + (app-add-route! default-app 'PUT pattern + (lambda () body ...)))) + +(defrules DELETE () + ((_ pattern body ...) + (app-add-route! default-app 'DELETE pattern + (lambda () body ...)))) + +(defrules PATCH () + ((_ pattern body ...) + (app-add-route! default-app 'PATCH pattern + (lambda () body ...)))) + +(defrules OPTIONS () + ((_ pattern body ...) + (app-add-route! default-app 'OPTIONS pattern + (lambda () body ...)))) + +(defrules HEAD () + ((_ pattern body ...) + (app-add-route! default-app 'HEAD pattern + (lambda () body ...)))) + +;; ============================================================ +;; Lowercase route functions — take explicit lambda handler +;; ============================================================ + +(def (get pattern handler) + (app-add-route! default-app 'GET pattern handler)) + +(def (post pattern handler) + (app-add-route! default-app 'POST pattern handler)) + +(def (put pattern handler) + (app-add-route! default-app 'PUT pattern handler)) + +(def (delete* pattern handler) + (app-add-route! default-app 'DELETE pattern handler)) + +(def (patch pattern handler) + (app-add-route! default-app 'PATCH pattern handler)) + +(def (options pattern handler) + (app-add-route! default-app 'OPTIONS pattern handler)) + +(def (head pattern handler) + (app-add-route! default-app 'HEAD pattern handler)) + +;; ============================================================ +;; Filters +;; ============================================================ + +(defrules before () + ((_ pattern body0 body ...) + (app-add-before! default-app pattern (lambda () body0 body ...))) + ((_ body ...) + (app-add-before! default-app #f (lambda () body ...)))) + +(defrules after () + ((_ pattern body0 body ...) + (app-add-after! default-app pattern (lambda () body0 body ...))) + ((_ body ...) + (app-add-after! default-app #f (lambda () body ...)))) + +;; ============================================================ +;; Error handlers +;; ============================================================ + +(defrules not-found () + ((_ body ...) + (app-set-not-found! default-app (lambda () body ...)))) + +(defrules error-handler () + ((_ body ...) + (app-set-error-handler! default-app 'error (lambda () body ...)))) + +;; ============================================================ +;; Configuration +;; ============================================================ + +(defrules configure () + ((_ body ...) + (begin body ...))) + +(def (set-option! key value) + (app-setting-set! default-app key value)) + +(def (enable! key) + (app-enable! default-app key)) + +(def (disable! key) + (app-disable! default-app key)) + +;; ============================================================ +;; Middleware +;; ============================================================ + +(def (use! mw) + (app-add-middleware! default-app mw)) + +;; ============================================================ +;; Server start +;; ============================================================ + +(defrules RUN! () + ((_) (run!))) + +(def (run! (the-app default-app) + port: (port #f) + bind: (bind #f)) + (let ((port (or port (app-setting the-app "port") 4567)) + (bind (or bind (app-setting the-app "bind") "127.0.0.1"))) + (let* ((handler-fn (sinatra-handler the-app)) + (srv (httpd-start port handler-fn))) + (displayln (format "== Sinatra has taken the stage on port ~a ==" port)) + srv))) + +;; ============================================================ +;; Modular-style (explicit app) functions +;; ============================================================ + +(def (sinatra-get app pattern handler) + (app-add-route! app 'GET pattern handler)) + +(def (sinatra-post app pattern handler) + (app-add-route! app 'POST pattern handler)) + +(def (sinatra-put app pattern handler) + (app-add-route! app 'PUT pattern handler)) + +(def (sinatra-delete app pattern handler) + (app-add-route! app 'DELETE pattern handler)) + +(def (sinatra-patch app pattern handler) + (app-add-route! app 'PATCH pattern handler)) + +(def (sinatra-options app pattern handler) + (app-add-route! app 'OPTIONS pattern handler)) + +(def (sinatra-head app pattern handler) + (app-add-route! app 'HEAD pattern handler)) + +(def (sinatra-before app pattern-or-handler . rest) + (if (null? rest) + ;; (sinatra-before app handler) — no pattern + (app-add-before! app #f pattern-or-handler) + ;; (sinatra-before app pattern handler) + (app-add-before! app pattern-or-handler (car rest)))) + +(def (sinatra-after app pattern-or-handler . rest) + (if (null? rest) + (app-add-after! app #f pattern-or-handler) + (app-add-after! app pattern-or-handler (car rest)))) + +(def (sinatra-not-found app handler) + (app-set-not-found! app handler)) + +(def (sinatra-error-handler app handler) + (app-set-error-handler! app 'error handler)) + +(def (sinatra-run! app port: (port #f) bind: (bind #f)) + (run! app port: port bind: bind)) new file mode 100644 --- /dev/null +++ b/sinatra/errors.ss @@ -0,0 +1,40 @@ +(import (sinatra response) + (sinatra helpers) + (sinatra context)) + +(export handle-not-found + handle-error) + +;; Handle 404 - not found +(def (handle-not-found app sres) + (sinatra-response-status-set! sres 404) + (let ((handler (hash-get app 'not-found-handler))) + (if handler + (let ((body (handler))) + (when (string? body) + (sinatra-response-body-set! sres body))) + (sinatra-response-body-set! sres "<h1>Not Found</h1>")))) + +;; Handle errors +(def (handle-error app sres exn) + (let ((error-handlers (or (hash-get app 'error-handlers) (hash)))) + ;; Try catch-all error handler + (let ((catch-all (hash-get error-handlers 'error))) + (if catch-all + (begin + (sinatra-response-status-set! sres 500) + (let ((body (parameterize ((current-error exn)) + (catch-all)))) + (when (string? body) + (sinatra-response-body-set! sres body)))) + ;; Default error handling + (begin + (sinatra-response-status-set! sres 500) + (let ((environment (or (hash-get app 'environment) "development"))) + (if (string=? environment "development") + (sinatra-response-body-set! sres + (string-append "<h1>Error</h1><pre>" + (with-output-to-string (lambda () (display-exception exn))) + "</pre>")) + (sinatra-response-body-set! sres + "<h1>Internal Server Error</h1>")))))))) new file mode 100644 --- /dev/null +++ b/sinatra/filters.ss @@ -0,0 +1,31 @@ +(import (std pregexp) + (sinatra route)) + +(export run-before-filters + run-after-filters + filter-matches?) + +;; Run before filters for the given method and path. +;; Filters are stored as (cons pattern-or-#f handler). +(def (run-before-filters app method path) + (run-filters (hash-ref app 'before-filters) method path)) + +;; Run after filters for the given method and path. +(def (run-after-filters app method path) + (run-filters (hash-ref app 'after-filters) method path)) + +;; Internal: run a list of filters +(def (run-filters filters method path) + (for-each + (lambda (filter) + (let ((pattern (car filter)) + (handler (cdr filter))) + (when (or (not pattern) + (filter-matches? pattern path)) + (handler)))) + filters)) + +;; Check if a pattern matches the given path. +(def (filter-matches? pattern path) + (let-values (((rx _names) (compile-route-pattern pattern))) + (and (pregexp-match rx path) #t))) new file mode 100644 --- /dev/null +++ b/sinatra/handler-test.ss @@ -0,0 +1,109 @@ +(import (std test) + (std text json) + (std net request) + (std net httpd) + (std format) + (sinatra app) + (sinatra handler) + (sinatra context) + (sinatra helpers) + (sinatra dsl)) + +(export handler-test) + +;; Find a free port for testing +(def (find-free-port) + (+ 10000 (random-integer 50000))) + +;; Start a test server, run body, stop server +(def (with-test-server app proc) + (let* ((port (find-free-port)) + (handler-fn (sinatra-handler app)) + (srv (httpd-start port handler-fn))) + (thread-sleep! 0.1) ;; let server start + (try + (proc port) + (finally + (httpd-stop srv))))) + +(def handler-test + (test-suite "handler dispatch integration" + + (test-case "simple GET returns string body" + (let ((app (make-sinatra-app))) + (sinatra-get app "/" + (lambda () "Hello World")) + (with-test-server app + (lambda (port) + (let ((resp (http-get (format "http://127.0.0.1:~a/" port)))) + (check (request-status resp) => 200) + (check (request-text resp) => "Hello World")))))) + + (test-case "route with named parameter" + (let ((app (make-sinatra-app))) + (sinatra-get app "/hello/:name" + (lambda () (string-append "Hi " (param "name")))) + (with-test-server app + (lambda (port) + (let ((resp (http-get (format "http://127.0.0.1:~a/hello/Alice" port)))) + (check (request-status resp) => 200) + (check (request-text resp) => "Hi Alice")))))) + + (test-case "POST route" + (let ((app (make-sinatra-app))) + (sinatra-post app "/data" + (lambda () (status! 201) "Created")) + (with-test-server app + (lambda (port)