Neaten up the blog site example

And fix some issues.

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.
+       ;; Session manager — in production, use a proper secret.
-(db-init! pool)
+       (session-manager
+        (make-session-config "change-me-in-production"
+                             #:cookie-name "blog-session"))
 
-;; Session manager — in production, use a proper secret.
+       (all-routes
-(define session-manager
+        (wrap-routes
-  (make-session-config "change-me-in-production"
+            (list (make-blog-component db-pool session-manager)
-                       #:cookie-name "blog-session"))
+                  (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.
+       (port 8082))
-(define blog-routes (make-blog-component pool session-manager))
 
-;; 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))

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)
+(define (db-init! db)
-  "Create the schema if it doesn't exist."
+  (sqlite-exec db "
-  (call-with-db pool
+CREATE TABLE IF NOT EXISTS posts (
-    (lambda (db)
+  id INTEGER PRIMARY KEY AUTOINCREMENT,
-      (sqlite-exec db "
+  title TEXT NOT NULL,
-        CREATE TABLE IF NOT EXISTS posts (
+  body TEXT NOT NULL,
-          id INTEGER PRIMARY KEY AUTOINCREMENT,
+  image_url TEXT,
-          title TEXT NOT NULL,
+  created_at TEXT NOT NULL DEFAULT (datetime('now'))
-          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

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))
+  (let ((parts form (if (request-content-type-is-multipart? request)
-         (form (multipart-text-fields parts))
+                        (let* ((parts (parse-multipart-body request body-port))
-         (method (assoc-ref form "_method")))
+                               (form (multipart-text-fields parts)))
-    (cond
+                          (values parts form))
-      ((equal? method "PUT")    (do-update-post request parts form))
+                        (values #f (parse-form-body request body-port)))))
-      ((equal? method "DELETE") (do-delete-post request))
+    (let ((method (assoc-ref form "_method")))
-      (else (bad-request-response)))))
+      (cond
+        ((equal? method "PUT")    (do-update-post request parts form))
+        ((equal? method "DELETE") (do-delete-post request))
+        (else (bad-request-response))))))
 
 ;;;
 ;;; Component constructor