Christopher Baines
5b0e6397dc
All checks were successful
/ test (push) Successful in 9s
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.
466 lines
17 KiB
Scheme
466 lines
17 KiB
Scheme
(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)
|