From 0d1a31f4c72cee8bcbc82e9c82ecbe20b5d26955 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 14 Apr 2026 15:19:11 +0300 Subject: [PATCH] Neaten up the blog site example And fix some issues. --- examples/blog-site/{README => README.md} | 0 examples/blog-site/blog-site.scm | 51 ++++++++++-------------- examples/blog-site/model.scm | 32 +++++++++------ examples/blog-site/views.scm | 23 +++++++---- 4 files changed, 57 insertions(+), 49 deletions(-) rename examples/blog-site/{README => README.md} (100%) diff --git a/examples/blog-site/README b/examples/blog-site/README.md similarity index 100% rename from examples/blog-site/README rename to examples/blog-site/README.md diff --git a/examples/blog-site/blog-site.scm b/examples/blog-site/blog-site.scm index b5d60d7..c4113c7 100644 --- a/examples/blog-site/blog-site.scm +++ b/examples/blog-site/blog-site.scm @@ -15,40 +15,31 @@ (exit 1)) ;; Create a shared database thread pool. -(define pool (make-db "/tmp/blog-site.db")) +(let* ((db-pool (make-db "/tmp/blog-site.db")) -;; Initialise the schema. -(db-init! pool) + ;; Session manager — in production, use a proper secret. + (session-manager + (make-session-config "change-me-in-production" + #:cookie-name "blog-session")) -;; Session manager — in production, use a proper secret. -(define session-manager - (make-session-config "change-me-in-production" - #:cookie-name "blog-session")) + (all-routes + (wrap-routes + (list (make-blog-component db-pool session-manager) + (route-group '("static") + (route 'GET '(. path) + (make-static-handler + "./static" + #:cache-control '((max-age . 3600))))) + (route '* '* (lambda (request body-port) + (not-found-response)))) + (make-exceptions-handler-wrapper #:dev? #t) + logging-handler-wrapper + security-headers-handler-wrapper + (make-session-handler-wrapper session-manager) + csrf-handler-wrapper)) -;; Build the blog component — handles both HTML and JSON via content negotiation. -(define blog-routes (make-blog-component pool session-manager)) + (port 8082)) -;; Static file serving. -(define static-routes - (route-group '("static") - (route 'GET '(. path) - (make-static-handler "./static" - #:cache-control '((max-age . 3600)))))) - -;; Apply handler wrappers and add a catch-all 404 route. -(define all-routes - (wrap-routes (list blog-routes - static-routes - (route '* '* (lambda (request body-port) - (not-found-response)))) - (make-exceptions-handler-wrapper #:dev? #t) - logging-handler-wrapper - security-headers-handler-wrapper - (make-session-handler-wrapper session-manager) - csrf-handler-wrapper)) - -;; Start the server. -(let ((port 8082)) (format #t "Listening on http://localhost:~a~%" port) (force-output) (run-safsaf all-routes #:port port)) diff --git a/examples/blog-site/model.scm b/examples/blog-site/model.scm index 2382291..194b6d9 100644 --- a/examples/blog-site/model.scm +++ b/examples/blog-site/model.scm @@ -28,6 +28,9 @@ connection to DATABASE-FILE." (sqlite-busy-timeout db 5000) (sqlite-exec db "PRAGMA journal_mode=WAL") (sqlite-exec db "PRAGMA foreign_keys=ON") + + (db-init! db) + (list db))) #:thread-destructor (lambda (db) @@ -44,18 +47,15 @@ SQLite connection. Returns whatever PROC returns." ;;; Schema ;;; -(define (db-init! pool) - "Create the schema if it doesn't exist." - (call-with-db pool - (lambda (db) - (sqlite-exec db " - CREATE TABLE IF NOT EXISTS posts ( - id INTEGER PRIMARY KEY AUTOINCREMENT, - title TEXT NOT NULL, - body TEXT NOT NULL, - image_url TEXT, - created_at TEXT NOT NULL DEFAULT (datetime('now')) - )")))) +(define (db-init! db) + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS posts ( + id INTEGER PRIMARY KEY AUTOINCREMENT, + title TEXT NOT NULL, + body TEXT NOT NULL, + image_url TEXT, + created_at TEXT NOT NULL DEFAULT (datetime('now')) +)")) ;;; ;;; Row conversions @@ -118,6 +118,14 @@ newest first." (sqlite-finalize stmt) (vector-ref row 0))))))) +(define (sqlite-changes db) + "Return the number of rows changed by the most recent INSERT, UPDATE, +or DELETE statement on DB." + (let ((stmt (sqlite-prepare db "SELECT changes()"))) + (let ((row (sqlite-step stmt))) + (sqlite-finalize stmt) + (vector-ref row 0)))) + (define (db-update-post! pool id title body image-url) "Update the post with ID. Returns #t if a row was changed, #f otherwise." (call-with-db pool diff --git a/examples/blog-site/views.scm b/examples/blog-site/views.scm index 11b26c2..d87b24f 100644 --- a/examples/blog-site/views.scm +++ b/examples/blog-site/views.scm @@ -11,6 +11,7 @@ #:use-module (safsaf templating) #:use-module (safsaf utils) #:use-module (safsaf params) + #:use-module (srfi srfi-71) #:use-module (web request) #:use-module (webutils multipart) #:export (make-blog-component)) @@ -420,19 +421,27 @@ PARTS and FORM are already-parsed multipart data." ;;; to simulate PUT and DELETE. ;;; +(define (request-content-type-is-multipart? request) + "Return #t if REQUEST has a multipart/form-data content type." + (let ((ct (request-content-type request))) + (and ct (eq? (car ct) 'multipart/form-data)))) + (define (post-actions request body-port) "Handle POST /posts/{id} — dispatches on _method form field. HTML forms cannot send PUT or DELETE directly, so they POST with a hidden _method field. This handler reads the body once, then delegates to the appropriate core operation. API clients should use PUT/DELETE directly instead." - (let* ((parts (parse-multipart-body request body-port)) - (form (multipart-text-fields parts)) - (method (assoc-ref form "_method"))) - (cond - ((equal? method "PUT") (do-update-post request parts form)) - ((equal? method "DELETE") (do-delete-post request)) - (else (bad-request-response))))) + (let ((parts form (if (request-content-type-is-multipart? request) + (let* ((parts (parse-multipart-body request body-port)) + (form (multipart-text-fields parts))) + (values parts form)) + (values #f (parse-form-body request body-port))))) + (let ((method (assoc-ref form "_method"))) + (cond + ((equal? method "PUT") (do-update-post request parts form)) + ((equal? method "DELETE") (do-delete-post request)) + (else (bad-request-response)))))) ;;; ;;; Component constructor