Initial commit

Safsaf is a Guile web framework, written using Claude Code running
Claude Opus 4.6, based off of the Guix Data Service, Nar Herder and
Guix Build Coordinator codebases.

examples/blog-site/README

@@ -0,0 +1,23 @@
+Blog Site Example
+=================
+
+A small blog application demonstrating Safsaf's routing, handler
+wrappers, sessions, CSRF protection, and content negotiation.  Uses
+SQLite for storage.
+
+Running
+-------
+
+From the repository root:
+
+    ./pre-inst-env guile -L examples/blog-site examples/blog-site/blog-site.scm
+
+Or from the example directory:
+
+    cd examples/blog-site
+    ../../pre-inst-env guile -L . blog-site.scm
+
+The server listens on http://localhost:8082.
+
+The session secret and database path are hard-coded for demonstration
+purposes — do not use these values in production.

examples/blog-site/blog-site.scm

@@ -0,0 +1,54 @@
+(use-modules (model)
+             (views)
+             (safsaf)
+             (safsaf handler-wrappers csrf)
+             (safsaf handler-wrappers exceptions)
+             (safsaf handler-wrappers logging)
+             (safsaf handler-wrappers security-headers)
+             (safsaf handler-wrappers sessions)
+             (safsaf response-helpers)
+             (safsaf router))
+
+(unless (file-exists? "static/style.css")
+  (format (current-error-port)
+          "error: run this from the examples/blog-site/ directory~%")
+  (exit 1))
+
+;; Create a shared database thread pool.
+(define pool (make-db "/tmp/blog-site.db"))
+
+;; Initialise the schema.
+(db-init! pool)
+
+;; Session manager — in production, use a proper secret.
+(define 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
+  (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

@@ -0,0 +1,144 @@
+(define-module (model)
+  #:use-module (knots thread-pool)
+  #:use-module (sqlite3)
+  #:export (make-db
+            call-with-db
+            db-init!
+            db-list-posts
+            db-get-post
+            db-create-post!
+            db-update-post!
+            db-delete-post!))
+
+;;;
+;;; Connection pool
+;;;
+
+(define* (make-db database-file #:key (pool-size 4))
+  "Create a thread pool where each thread holds an open SQLite
+connection to DATABASE-FILE."
+  (make-fixed-size-thread-pool
+   pool-size
+   #:name "sqlite"
+   #:thread-initializer
+   (lambda ()
+     (let ((db (sqlite-open database-file
+                            (logior SQLITE_OPEN_READWRITE
+                                    SQLITE_OPEN_CREATE))))
+       (sqlite-busy-timeout db 5000)
+       (sqlite-exec db "PRAGMA journal_mode=WAL")
+       (sqlite-exec db "PRAGMA foreign_keys=ON")
+       (list db)))
+   #:thread-destructor
+   (lambda (db)
+     (sqlite-close db))))
+
+(define (call-with-db pool proc)
+  "Run (PROC db) on a thread from POOL, where DB is the thread's
+SQLite connection.  Returns whatever PROC returns."
+  (call-with-thread pool
+    (lambda (db)
+      (proc db))))
+
+;;;
+;;; 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'))
+        )"))))
+
+;;;
+;;; Row conversions
+;;;
+
+(define (row->post-summary row)
+  "Convert a list-view row (vector) to an alist."
+  `((id         . ,(vector-ref row 0))
+    (title      . ,(vector-ref row 1))
+    (created-at . ,(vector-ref row 2))))
+
+(define (row->post row)
+  "Convert a detail-view row (vector) to an alist."
+  `((id         . ,(vector-ref row 0))
+    (title      . ,(vector-ref row 1))
+    (body       . ,(vector-ref row 2))
+    (image-url  . ,(vector-ref row 3))
+    (created-at . ,(vector-ref row 4))))
+
+;;;
+;;; Queries
+;;;
+
+(define (db-list-posts pool)
+  "Return all posts as a list of alists (id, title, created-at),
+newest first."
+  (call-with-db pool
+    (lambda (db)
+      (let ((stmt (sqlite-prepare db
+                    "SELECT id, title, created_at FROM posts ORDER BY id DESC")))
+        (let ((rows (sqlite-map row->post-summary stmt)))
+          (sqlite-finalize stmt)
+          rows)))))
+
+(define (db-get-post pool id)
+  "Return the post with ID as an alist, or #f if not found."
+  (call-with-db pool
+    (lambda (db)
+      (let ((stmt (sqlite-prepare db
+                    "SELECT id, title, body, image_url, created_at
+                     FROM posts WHERE id = ?")))
+        (sqlite-bind stmt 1 id)
+        (let ((row (sqlite-step stmt)))
+          (sqlite-finalize stmt)
+          (and row (row->post row)))))))
+
+(define (db-create-post! pool title body image-url)
+  "Insert a new post and return its ID."
+  (call-with-db pool
+    (lambda (db)
+      (let ((stmt (sqlite-prepare db
+                    "INSERT INTO posts (title, body, image_url) VALUES (?, ?, ?)")))
+        (sqlite-bind stmt 1 title)
+        (sqlite-bind stmt 2 body)
+        (sqlite-bind stmt 3 image-url)
+        (sqlite-step stmt)
+        (sqlite-finalize stmt)
+        (let ((stmt (sqlite-prepare db "SELECT last_insert_rowid()")))
+          (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
+    (lambda (db)
+      (let ((stmt (sqlite-prepare db
+                    "UPDATE posts SET title = ?, body = ?, image_url = ?
+                     WHERE id = ?")))
+        (sqlite-bind stmt 1 title)
+        (sqlite-bind stmt 2 body)
+        (sqlite-bind stmt 3 image-url)
+        (sqlite-bind stmt 4 id)
+        (sqlite-step stmt)
+        (sqlite-finalize stmt)
+        (> (sqlite-changes db) 0)))))
+
+(define (db-delete-post! pool id)
+  "Delete the post with ID.  Returns #t if a row was deleted, #f otherwise."
+  (call-with-db pool
+    (lambda (db)
+      (let ((stmt (sqlite-prepare db "DELETE FROM posts WHERE id = ?")))
+        (sqlite-bind stmt 1 id)
+        (sqlite-step stmt)
+        (sqlite-finalize stmt)
+        (> (sqlite-changes db) 0)))))

examples/blog-site/static/style.css

@@ -0,0 +1,30 @@
+* { margin: 0; padding: 0; box-sizing: border-box; }
+body { font-family: system-ui, sans-serif; line-height: 1.6; max-width: 48rem; margin: 0 auto; padding: 1rem; color: #222; }
+nav { border-bottom: 1px solid #ddd; padding: 0.75rem 0; margin-bottom: 1.5rem; }
+nav a { text-decoration: none; color: #444; margin-right: 1rem; }
+nav a:hover { color: #000; }
+h1 { margin-bottom: 0.75rem; }
+h1 a { text-decoration: none; color: inherit; }
+p, ul, pre { margin-bottom: 1rem; }
+ul { padding-left: 1.5rem; }
+a { color: #1a6; }
+pre { background: #f5f5f5; padding: 1rem; overflow-x: auto; white-space: pre-wrap; }
+form label { display: block; margin-bottom: 0.25rem; font-weight: 600; }
+form input[type="text"], form textarea { width: 100%; padding: 0.4rem; border: 1px solid #ccc; border-radius: 3px; font-family: inherit; font-size: inherit; }
+form textarea { resize: vertical; }
+form button { margin-top: 0.5rem; padding: 0.4rem 1.2rem; background: #1a6; color: #fff; border: none; border-radius: 3px; cursor: pointer; }
+form button:hover { background: #158; }
+.field { margin-bottom: 1rem; }
+.error { color: #c33; font-size: 0.9rem; margin-top: 0.2rem; }
+.post-meta { color: #888; font-size: 0.9rem; margin-bottom: 1rem; }
+.header-image { width: 100%; max-height: 20rem; object-fit: cover; border-radius: 4px; margin-bottom: 1rem; }
+.nav-form { display: inline; }
+.nav-link { background: none; border: none; color: #444; cursor: pointer; font: inherit; padding: 0; margin-right: 1rem; }
+.nav-link:hover { color: #000; }
+form input[type="file"] { margin-top: 0.25rem; }
+.post-actions { margin-bottom: 1rem; }
+.post-actions a { margin-right: 0.5rem; }
+.inline-form { display: inline; }
+.danger { background: #c33; color: #fff; border: none; border-radius: 3px; padding: 0.2rem 0.6rem; cursor: pointer; font-size: 0.9rem; }
+.danger:hover { background: #a22; }
+footer { border-top: 1px solid #ddd; padding-top: 0.75rem; margin-top: 2rem; color: #888; font-size: 0.9rem; }

examples/blog-site/views.scm

@@ -0,0 +1,466 @@
+(define-module (views)
+  #:use-module (htmlprag)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 match)
+  #:use-module (json)
+  #:use-module (model)
+  #:use-module (safsaf handler-wrappers csrf)
+  #:use-module (safsaf handler-wrappers sessions)
+  #:use-module (safsaf response-helpers)
+  #:use-module (safsaf router)
+  #:use-module (safsaf templating)
+  #:use-module (safsaf utils)
+  #:use-module (safsaf params)
+  #:use-module (web request)
+  #:use-module (webutils multipart)
+  #:export (make-blog-component))
+
+(define %demo-username "admin")
+(define %demo-password "password")
+
+(define %pool #f)
+(define %session-manager #f)
+(define %routes #f)
+
+;;;
+;;; JSON helpers
+;;;
+
+(define (post->json-alist post)
+  (match post
+    ((('id . id) ('title . title) ('body . body)
+      ('image-url . image-url) ('created-at . created-at))
+     `(("id"         . ,id)
+       ("title"      . ,title)
+       ("body"       . ,body)
+       ("image_url"  . ,(or image-url 'null))
+       ("created_at" . ,created-at)))))
+
+(define (post-summary->json-alist post)
+  (match post
+    ((('id . id) ('title . title) ('created-at . created-at))
+     `(("id"         . ,id)
+       ("title"      . ,title)
+       ("created_at" . ,created-at)))))
+
+;;;
+;;; View helpers
+;;;
+
+(define (render-field label name type value errors)
+  `(div (@ (class "field"))
+     (label ,label
+       ,(if (string=? type "textarea")
+            `(textarea (@ (name ,name) (rows "15") (cols "60"))
+                       ,value)
+            `(input (@ (name ,name) (type ,type) (value ,value)))))
+     ,@(map (lambda (err) `(p (@ (class "error")) ,err))
+            errors)))
+
+(define (form-errors params field-name)
+  (if params
+      (field-errors params field-name)
+      '()))
+
+(define (wants-json? request)
+  (eq? 'application/json
+       (negotiate-content-type request '(text/html application/json))))
+
+;;;
+;;; File upload helpers
+;;;
+
+(define upload-dir "./static/uploads")
+
+(define (ensure-upload-dir!)
+  (unless (file-exists? upload-dir)
+    (mkdir upload-dir)))
+
+(define (save-upload part)
+  (let* ((params (part-content-disposition-params part))
+         (filename (assoc-ref params 'filename)))
+    (if (or (not filename) (string-null? filename))
+        #f
+        (let* ((ext (let ((dot (string-rindex filename #\.)))
+                      (if dot (substring filename dot) "")))
+               (unique-name (string-append
+                             (number->string (current-time))
+                             "-"
+                             (number->string (random 1000000000))
+                             ext))
+               (file-path (string-append upload-dir "/" unique-name))
+               (url-path (string-append "/static/uploads/" unique-name)))
+          (ensure-upload-dir!)
+          (call-with-output-file file-path
+            (lambda (out)
+              (let ((body (part-body part)))
+                (let loop ()
+                  (let ((bv (get-bytevector-some body)))
+                    (unless (eof-object? bv)
+                      (put-bytevector out bv)
+                      (loop)))))))
+          url-path))))
+
+;;;
+;;; Layout
+;;;
+
+(define (logged-in?)
+  (and (current-session) #t))
+
+(define (base-layout title content-proc)
+  (let ((signed-in? (logged-in?)))
+    `(*TOP*
+      (*DECL* DOCTYPE html)
+      (html
+       (head
+        (meta (@ (charset "utf-8")))
+        (meta (@ (name "viewport")
+                (content "width=device-width, initial-scale=1")))
+        (title ,title " — Blog")
+        (link (@ (rel "stylesheet") (href "/static/style.css"))))
+       (body
+        (nav
+         (a (@ (href ,(path-for %routes 'index))) "Blog")
+         ,@(if signed-in?
+               `((a (@ (href ,(path-for %routes 'new-post))) "New Post"))
+               '())
+         ,@(if signed-in?
+               `((form (@ (method "POST") (action ,(path-for %routes 'logout))
+                          (class "nav-form"))
+                   ,(csrf-token-field)
+                   (button (@ (type "submit") (class "nav-link")) "Log out")))
+               `((a (@ (href ,(path-for %routes 'login))) "Log in"))))
+        (main ,content-proc)
+        (footer
+         (p "Safsaf blog example")))))))
+
+(define (page title shtml)
+  (streaming-html-response
+   (base-layout title
+     (lambda (port) (write-shtml-as-html shtml port)))))
+
+;;;
+;;; Auth
+;;;
+
+(define (require-login handler)
+  (lambda (request body-port)
+    (if (logged-in?)
+        (handler request body-port)
+        (if (wants-json? request)
+            (json-response (scm->json-string '(("error" . "unauthorized")))
+                           #:code 401)
+            (redirect-response (path-for %routes 'login))))))
+
+(define (login-page request body-port)
+  (if (logged-in?)
+      (redirect-response (path-for %routes 'index))
+      (login-form-page #f)))
+
+(define (login-form-page error)
+  (page "Log in"
+    `(div
+      (h1 "Log in")
+      ,@(if error
+            `((p (@ (class "error")) ,error))
+            '())
+      (form (@ (method "POST") (action ,(path-for %routes 'login-submit)))
+        ,(csrf-token-field)
+        ,(render-field "Username" "username" "text" "" '())
+        ,(render-field "Password" "password" "password" "" '())
+        (button (@ (type "submit")) "Log in"))
+      (p (@ (class "post-meta"))
+         "Demo credentials: admin / password"))))
+
+(define (handle-login request body-port)
+  (let* ((form (parse-form-body request body-port))
+         (params (parse-form-params
+                   `((username ,as-string #:required)
+                     (password ,as-string #:required))
+                   form)))
+    (if (any-invalid-params? params)
+        (login-form-page "Please fill in all fields")
+        (let ((username (assq-ref params 'username))
+              (password (assq-ref params 'password)))
+          (if (and (string=? username %demo-username)
+                   (string=? password %demo-password))
+              (redirect-response (path-for %routes 'index)
+                #:headers (list (session-set %session-manager
+                                             `((username . ,username)))))
+              (login-form-page "Invalid username or password"))))))
+
+(define (handle-logout request body-port)
+  (redirect-response (path-for %routes 'index)
+    #:headers (list (session-delete %session-manager))))
+
+;;;
+;;; Blog views — content-negotiated
+;;;
+
+(define (post-list-item post)
+  (match post
+    ((('id . id) ('title . title) ('created-at . date))
+     `(li (a (@ (href ,(path-for %routes 'show-post
+                                 `((id . ,(number->string id))))))
+              ,title)
+          " "
+          (span (@ (class "post-meta")) ,date)))))
+
+(define (list-posts request body-port)
+  (let ((posts (db-list-posts %pool)))
+    (if (wants-json? request)
+        (json-response
+         (scm->json-string (list->vector (map post-summary->json-alist posts))))
+        (page "Posts"
+          `(div
+            (h1 "Blog")
+            ,(if (null? posts)
+                 '(p "No posts yet.")
+                 `(ul ,@(map post-list-item posts))))))))
+
+(define (show-post request body-port)
+  (let* ((id-str (assoc-ref (current-route-params) 'id))
+         (id (and id-str (string->number id-str)))
+         (post (and id (db-get-post %pool id))))
+    (if (not post)
+        (if (wants-json? request)
+            (json-response (scm->json-string '(("error" . "not found")))
+                           #:code 404)
+            (not-found-response "Post not found"))
+        (if (wants-json? request)
+            (json-response (scm->json-string (post->json-alist post)))
+            (match post
+              ((('id . _) ('title . title) ('body . body)
+                ('image-url . image-url) ('created-at . date))
+               (page title
+                 `(div
+                   (h1 ,title)
+                   (p (@ (class "post-meta")) ,date)
+                   ,@(if (and image-url (string? image-url))
+                         `((img (@ (src ,image-url)
+                                   (alt ,title)
+                                   (class "header-image"))))
+                         '())
+                   (pre ,body)
+                   ,@(if (logged-in?)
+                         `((div (@ (class "post-actions"))
+                             (a (@ (href ,(path-for %routes 'edit-post
+                                                    `((id . ,id-str)))))
+                                "Edit")
+                             " "
+                             (form (@ (method "POST")
+                                      (action ,(path-for %routes 'post-actions
+                                                         `((id . ,id-str))))
+                                      (class "inline-form"))
+                               ,(csrf-token-field)
+                               (input (@ (type "hidden")
+                                         (name "_method") (value "DELETE")))
+                               (button (@ (type "submit") (class "danger"))
+                                       "Delete"))))
+                         '())
+                   (p (a (@ (href ,(path-for %routes 'index)))
+                         "Back to posts"))))))))))
+
+;;;
+;;; Create
+;;;
+
+(define (new-post-form-page result title-val body-val)
+  (page "New Post"
+    `(div
+      (h1 "New Post")
+      (form (@ (method "POST") (action ,(path-for %routes 'create-post))
+               (enctype "multipart/form-data"))
+        ,(csrf-token-field)
+        ,(render-field "Title" "title" "text"
+                       title-val (form-errors result 'title))
+        ,(render-field "Body" "body" "textarea"
+                       body-val (form-errors result 'body))
+        (div (@ (class "field"))
+          (label "Header Image"
+            (input (@ (name "image") (type "file")
+                      (accept "image/*")))))
+        (button (@ (type "submit")) "Create"))
+      (p (a (@ (href ,(path-for %routes 'index))) "Back")))))
+
+(define (new-post-form request body-port)
+  (new-post-form-page #f "" ""))
+
+(define (create-post request body-port)
+  (let* ((parts (parse-multipart-body request body-port))
+         (form (multipart-text-fields parts))
+         (params (parse-form-params
+                   `((title ,as-string #:required)
+                     (body  ,as-string #:required))
+                   form)))
+    (if (any-invalid-params? params)
+        (new-post-form-page params
+                            (or (assoc-ref form "title") "")
+                            (or (assoc-ref form "body") ""))
+        (let* ((title (assq-ref params 'title))
+               (body (assq-ref params 'body))
+               (image-part (parts-ref parts "image"))
+               (image-url (and image-part (save-upload image-part)))
+               (id (db-create-post! %pool title body image-url)))
+          (redirect-response
+           (path-for %routes 'show-post
+                     `((id . ,(number->string id)))))))))
+
+;;;
+;;; Edit / Update
+;;;
+
+(define (edit-post-form request body-port)
+  (let* ((id-str (assoc-ref (current-route-params) 'id))
+         (id (and id-str (string->number id-str)))
+         (post (and id (db-get-post %pool id))))
+    (if (not post)
+        (not-found-response "Post not found")
+        (match post
+          ((('id . _) ('title . title) ('body . body)
+            ('image-url . image-url) ('created-at . _))
+           (edit-post-form-page id-str #f title body))))))
+
+(define (edit-post-form-page id-str result title-val body-val)
+  (page "Edit Post"
+    `(div
+      (h1 "Edit Post")
+      (form (@ (method "POST")
+               (action ,(path-for %routes 'post-actions
+                                  `((id . ,id-str))))
+               (enctype "multipart/form-data"))
+        ,(csrf-token-field)
+        (input (@ (type "hidden") (name "_method") (value "PUT")))
+        ,(render-field "Title" "title" "text"
+                       title-val (form-errors result 'title))
+        ,(render-field "Body" "body" "textarea"
+                       body-val (form-errors result 'body))
+        (div (@ (class "field"))
+          (label "Header Image"
+            (input (@ (name "image") (type "file")
+                      (accept "image/*")))))
+        (button (@ (type "submit")) "Update"))
+      (p (a (@ (href ,(path-for %routes 'show-post
+                                `((id . ,id-str)))))
+            "Back")))))
+
+;;;
+;;; Update / Delete — core operations
+;;;
+;;; These take parsed data, not body-port.  Both the direct route handlers
+;;; (PUT, DELETE) and the _method dispatcher call these, so body reading
+;;; happens in exactly one place per request path.
+;;;
+
+(define (do-update-post request parts form)
+  "Validate and update the post identified by current-route-params.
+PARTS and FORM are already-parsed multipart data."
+  (let* ((id-str (assoc-ref (current-route-params) 'id))
+         (id (and id-str (string->number id-str)))
+         (post (and id (db-get-post %pool id))))
+    (if (not post)
+        (if (wants-json? request)
+            (json-response (scm->json-string '(("error" . "not found")))
+                           #:code 404)
+            (not-found-response "Post not found"))
+        (let ((params (parse-form-params
+                        `((title ,as-string #:required)
+                          (body  ,as-string #:required))
+                        form)))
+          (if (any-invalid-params? params)
+              (edit-post-form-page id-str params
+                                   (or (assoc-ref form "title") "")
+                                   (or (assoc-ref form "body") ""))
+              (let* ((title (assq-ref params 'title))
+                     (body  (assq-ref params 'body))
+                     (image-part (and parts (parts-ref parts "image")))
+                     (new-image-url (and image-part (save-upload image-part)))
+                     (image-url (or new-image-url
+                                    (assoc-ref post 'image-url))))
+                (db-update-post! %pool id title body image-url)
+                (if (wants-json? request)
+                    (json-response
+                     (scm->json-string (post->json-alist
+                                        (db-get-post %pool id))))
+                    (redirect-response
+                     (path-for %routes 'show-post
+                               `((id . ,id-str)))))))))))
+
+(define (do-delete-post request)
+  "Delete the post identified by current-route-params."
+  (let* ((id-str (assoc-ref (current-route-params) 'id))
+         (id (and id-str (string->number id-str)))
+         (deleted? (and id (db-delete-post! %pool id))))
+    (if (wants-json? request)
+        (if deleted?
+            (json-response (scm->json-string '(("deleted" . #t))))
+            (json-response (scm->json-string '(("error" . "not found")))
+                           #:code 404))
+        (if deleted?
+            (redirect-response (path-for %routes 'index))
+            (not-found-response "Post not found")))))
+
+;;;
+;;; Route handlers — each reads the body (if needed) then calls the core operation.
+;;;
+
+(define (update-post request body-port)
+  "PUT /posts/{id} — direct update for API clients and form submissions."
+  (let* ((parts (parse-multipart-body request body-port))
+         (form (multipart-text-fields parts)))
+    (do-update-post request parts form)))
+
+(define (delete-post request body-port)
+  "DELETE /posts/{id} — direct delete for API clients."
+  (do-delete-post request))
+
+;;;
+;;; _method dispatch — HTML forms POST here with a hidden _method field
+;;; to simulate PUT and DELETE.
+;;;
+
+(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)))))
+
+;;;
+;;; Component constructor
+;;;
+
+(define (make-blog-component pool session-manager)
+  (set! %pool pool)
+  (set! %session-manager session-manager)
+  (set! %routes (make-route-group '()))
+
+  (route-group-add-children! %routes
+    (list (route 'GET    '()                 list-posts       #:name 'index)
+          (route 'GET    '("login")          login-page       #:name 'login)
+          (route 'POST   '("login")          handle-login     #:name 'login-submit)
+          (route 'POST   '("logout")         handle-logout    #:name 'logout)
+          (route 'GET    '("posts" "new")    (require-login new-post-form)
+                 #:name 'new-post)
+          (route 'POST   '("posts")          (require-login create-post)
+                 #:name 'create-post)
+          (route 'GET    '("posts" id)       show-post        #:name 'show-post)
+          (route 'GET    '("posts" id "edit") (require-login edit-post-form)
+                 #:name 'edit-post)
+          ;; _method dispatch: HTML forms POST here with _method=PUT or DELETE.
+          (route 'POST   '("posts" id)       (require-login post-actions)
+                 #:name 'post-actions)
+          ;; Direct HTTP methods for API clients.
+          (route 'PUT    '("posts" id)       (require-login update-post)
+                 #:name 'update-post)
+          (route 'DELETE '("posts" id)       (require-login delete-post)
+                 #:name 'delete-post)))
+  %routes)

examples/paste-bin/paste-bin.scm

@@ -0,0 +1,107 @@
+(use-modules (htmlprag)
+             (logging logger)
+             (logging port-log)
+             ((oop goops) #:select (make))
+             (safsaf)
+             (safsaf handler-wrappers csrf)
+             (safsaf handler-wrappers logging)
+             (safsaf response-helpers)
+             (safsaf router)
+             (safsaf utils)
+             (safsaf params))
+
+;;;
+;;; Paste storage (in-memory)
+;;;
+
+(define %pastes (make-hash-table))
+(define %next-id 0)
+
+(define (store-paste! content)
+  "Store CONTENT and return its integer ID."
+  (let ((id %next-id))
+    (set! %next-id (1+ id))
+    (hashv-set! %pastes id content)
+    id))
+
+(define (fetch-paste id)
+  "Return the paste content for integer ID, or #f."
+  (hashv-ref %pastes id))
+
+;;;
+;;; Handlers
+;;;
+
+(define (paste-form-page errors content-val)
+  "Render the paste form, optionally with validation errors and prior input."
+  (html-response
+   `(div
+     (h1 "Paste Bin")
+     (form (@ (method "POST") (action "/pastes"))
+       ,(csrf-token-field)
+       ,@(map (lambda (err) `(p (@ (style "color: #c33")) ,err))
+              errors)
+       (textarea (@ (name "content") (rows "20") (cols "80"))
+                 ,content-val)
+       (br)
+       (button (@ (type "submit")) "Create Paste")))))
+
+(define (index-page request body-port)
+  (paste-form-page '() ""))
+
+(define (create-paste request body-port)
+  (let* ((form (parse-form-body request body-port))
+         (params (parse-form-params
+                   `((content ,as-string #:required))
+                   form)))
+    (if (any-invalid-params? params)
+        (paste-form-page
+         (field-errors params 'content)
+         (or (assoc-ref form "content") ""))
+        (let ((id (store-paste! (assq-ref params 'content))))
+          (redirect-response (string-append "/pastes/" (number->string id)))))))
+
+(define (show-paste request body-port)
+  (let* ((params (current-route-params))
+         (id-str (assoc-ref params 'id))
+         (id (string->number id-str))
+         (content (and id (fetch-paste id))))
+    (if content
+        (html-response
+         `(div
+           (h1 "Paste " ,id-str)
+           (pre ,content)
+           (p (a (@ (href "/")) "New paste"))))
+        (not-found-response "Paste not found"))))
+
+;;;
+;;; Logging setup
+;;;
+
+(define (setup-logging)
+  (let ((lgr (make <logger>))
+        (handler (make <port-log> #:port (current-error-port))))
+    (add-handler! lgr handler)
+    (set-default-logger! lgr)
+    (open-log! lgr)))
+
+(setup-logging)
+
+;;;
+;;; Routes and entry point
+;;;
+
+(define %port 8081)
+
+(define paste-routes
+  (wrap-routes
+   (list
+    (route 'GET '() index-page)
+    (route 'POST '("pastes") create-paste)
+    (route 'GET '("pastes" id) show-paste)
+    (route '* '* (lambda (request body-port) (not-found-response))))
+   logging-handler-wrapper
+   csrf-handler-wrapper))
+
+(format #t "Paste Bin listening on port ~a~%" %port)
+(run-safsaf paste-routes #:port %port)