Neaten up the blog site example

And fix some issues.

examples/blog-site/blog-site.scm

@@ -15,30 +15,21 @@
   (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.
-(define session-manager
+       ;; Session manager — in production, use a proper secret.
+       (session-manager
         (make-session-config "change-me-in-production"
                              #:cookie-name "blog-session"))
 
-;; Build the blog component — handles both HTML and JSON via content negotiation.
-(define blog-routes (make-blog-component pool session-manager))
-
-;; Static file serving.
-(define static-routes
+       (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))))))
-
-;; Apply handler wrappers and add a catch-all 404 route.
-(define all-routes
-  (wrap-routes (list blog-routes
-                     static-routes
+                           (make-static-handler
+                            "./static"
+                            #:cache-control '((max-age . 3600)))))
                   (route '* '* (lambda (request body-port)
                                  (not-found-response))))
           (make-exceptions-handler-wrapper #:dev? #t)
@@ -47,8 +38,8 @@
           (make-session-handler-wrapper session-manager)
           csrf-handler-wrapper))
 
-;; Start the server.
-(let ((port 8082))
+       (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)
-  "Create the schema if it doesn't exist."
-  (call-with-db pool
-    (lambda (db)
+(define (db-init! db)
   (sqlite-exec db "
-        CREATE TABLE IF NOT EXISTS posts (
+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

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 form (if (request-content-type-is-multipart? request)
                         (let* ((parts (parse-multipart-body request body-port))
-         (form (multipart-text-fields parts))
-         (method (assoc-ref form "_method")))
+                               (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)))))
+        (else (bad-request-response))))))
 
 ;;;
 ;;; Component constructor