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/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)