commit 7fc93b61fd22f5899aacb369a5cafcd1818e4355 (patch)
parent 91e8cae0fc4cc52057210662f1ba7c0b8ec17413
Author: Alex Karle <alex@alexkarle.com>
Date: Mon, 14 Nov 2022 00:59:19 -0500
rsvp: Add basic POST handler for updating rsvps
This was a solid bit of effort in that before now I wasn't super
familiar with the (chicken condition) module. I even got myself
in an endless loop because I didn't (call/cc) my way out of the
exception handler -.-
Another fun surprise was that sqlite isn't actually strictly
typed? It lets you store strings in integer columns / is dynamically
typed! Surprise! I'm relatively happy with how it turned out though.
Diffstat:
| M | src/db.scm | | | 55 | +++++++++++++++++++++++++++++++++++-------------------- |
| M | src/handler.scm | | | 105 | +++++++++++++++++++++++++++++++++++++++++++++++++++++--------------------------- |
2 files changed, 105 insertions(+), 55 deletions(-)
diff --git a/src/db.scm b/src/db.scm
@@ -9,6 +9,14 @@
id name party-id going meal-choice
has-plus1 plus1-going plus1-meal-choice)
+(set-record-printer! guest
+ (lambda (x o)
+ (fprintf o "(id: ~A name: ~A going: ~A meal: ~A)"
+ (guest-id x)
+ (guest-name x)
+ (guest-going x)
+ (guest-meal-choice x))))
+
(define (get-guest-by-name name)
(apply make-guest
(first-row conn
@@ -23,6 +31,20 @@
plus1_meal_choice
FROM guests WHERE name = $name" name)))
+(define (get-guest-by-id id)
+ (apply make-guest
+ (first-row conn
+"SELECT
+ id,
+ name,
+ party_id,
+ going,
+ meal_choice,
+ has_plus1,
+ plus1_going,
+ plus1_meal_choice
+FROM guests WHERE id = $name" id)))
+
(define (get-guests-in-party pid)
(map-row make-guest conn
"SELECT
@@ -44,7 +66,7 @@ FROM guests WHERE party_id = $pid" pid))
(call/cc
(lambda (c)
(with-exception-handler
- (lambda (x) (c '()))
+ (lambda (x) (print-error-message exn) (c '()))
(lambda ()
(let* ((guest (get-guest-by-name name))
(party-id (guest-party-id guest)))
@@ -53,22 +75,15 @@ FROM guests WHERE party_id = $pid" pid))
(list guest))))))))
(define (update-guest g)
- (call/cc
- (lambda (c)
- (with-exception-handler
- (lambda (x) (print x) (c #f))
- (lambda ()
- (update conn "
-UPDATE guests SET
- name = $1,
- going = $2,
- meal_choice = $3,
- plus1_going = $4,
- plus1_meal_choice = $5
-WHERE id = $6"
- (guest-name g)
- (guest-going g)
- (guest-meal-choice g)
- (guest-plus1-going g)
- (guest-plus1-meal-choice g)
- (guest-id g)))))))
+ (update conn "
+ UPDATE guests SET
+ going = $2,
+ meal_choice = $3,
+ plus1_going = $4,
+ plus1_meal_choice = $5
+ WHERE id = $6"
+ (guest-going g)
+ (guest-meal-choice g)
+ (guest-plus1-going g)
+ (guest-plus1-meal-choice g)
+ (guest-id g)))
diff --git a/src/handler.scm b/src/handler.scm
@@ -5,10 +5,13 @@
intarweb
sxml-serializer
sql-null
- (chicken string))
+ (chicken string)
+ (chicken condition))
(load "db.scm")
+(define email '(a (@ (href "mailto:rsvp@jennex.org")) "rsvp@jennex.org"))
+
(define routes
;; See uri-match for format: http://wiki.call-cc.org/eggref/5/uri-match#routes-format
;;
@@ -55,46 +58,35 @@
(button "Lookup"))
(p "Please let us know by DATE whether you can make it!")))))
-(define (guest-to-form g)
- ;; Given a guest record, generate a SXML form for their settings
- ;; TODO: expand plus-1's
- (define (get-going-attrs val)
- `((name ,(conc (number->string (guest-id g)) "__going"))
- (value ,val)
- (type "radio")
- (required "true")
- ,@(let ((going (guest-going g)))
- (cond ((equal? val "no") (if (eq? going 0) '((checked)) '()))
- ((equal? val "yes") (if (eq? going 1) '((checked)) '()))
- ((equal? val "null") (if (sql-null? going) '((checked)) '()))
- (else (error "Bad val"))))))
+(define key-to-getter
+ `(("going" . ,guest-going)
+ ("meal-choice" . ,guest-meal-choice)))
- (define (get-meal-attrs val)
- `((name ,(conc (number->string (guest-id g)) "__meal_choice"))
+(define (guest-to-form g)
+ (define (get-attrs key val)
+ `((name ,(conc (number->string (guest-id g)) "__" key))
(value ,val)
(type "radio")
(required "true")
- ,@(if (equal? (guest-meal-choice g) val)
+ ,@(let ((getter (assoc key key-to-getter)))
+ (if (and getter (equal? ((cdr getter) g) val))
'((checked))
- '())))
-
+ '()))))
;; TODO: add notes section for allergies, etc
`((div (@ (class "guest"))
(h4 ,(guest-name g))
(fieldset
(legend "Will You be Attending?")
- (label (input (@ ,@(get-going-attrs "yes"))) "Yes!")
- (br)
- (label (input (@ ,@(get-going-attrs "no"))) "No :(")
+ (label (input (@ ,@(get-attrs "going" 1))) "Yes!")
(br)
- (label (input (@ ,@(get-going-attrs "null"))) "Not Sure Yet..."))
+ (label (input (@ ,@(get-attrs "going" 0))) "No :("))
(fieldset
(legend "Meal Choice")
- (label (input (@ ,@(get-meal-attrs "chicken"))) "Chicken")
+ (label (input (@ ,@(get-attrs "meal-choice" "chicken"))) "Chicken")
(br)
- (label (input (@ ,@(get-meal-attrs "beef"))) "Beef")
+ (label (input (@ ,@(get-attrs "meal-choice" "beef"))) "Beef")
(br)
- (label (input (@ ,@(get-meal-attrs "vegetarian"))) "Chicken")))))
+ (label (input (@ ,@(get-attrs "meal-choice" "vegetarian"))) "Vegetarian")))))
(define (route-get-rsvp c)
;; TODO: consider a POST instead of GET to prevent people from sharing
@@ -115,14 +107,57 @@
`((h2 "RSVP")
(p "Sorry! We can't find anyone under the name '" ,name
"'. Please double check the spelling and if it looks like a "
- "mistake on our end email us at "
- (a (@ (href "mailto:rsvp@jennex.org")) "rsvp@jennex.org") "."))))))))
+ "mistake on our end email us at " ,email))))))))
+
+
+(define key-to-setter
+ ;; Just an a-list of input names -> guest-setter functions
+ ;; (allowing the request to specify any string is dangerous)
+ `((going . ,guest-going-set!)
+ (meal-choice . ,guest-meal-choice-set!)
+ (plus1-going . ,guest-plus1-going-set!)
+ (plus1-meal-choice . ,guest-plus1-meal-choice-set!)))
(define (route-post-rsvp c)
- (let ((fdata (read-urlencoded-request-data (current-request))))
- (send-sxml
- (template-page
- `((h2 "RSVP")
- (p "Success! Thanks for RSVP-ing.")
- (p (a (@ (href "/rsvp")) "Edit your response"))
- (p (a (@ (href "https://jennex.org")) "Read more about the event")))))))
+ (call/cc
+ (lambda (c)
+ (with-exception-handler
+ (lambda (exn)
+ (print-error-message exn)
+ (send-sxml
+ (template-page
+ `((h2 "RSVP")
+ ;; TODO: log it better...
+ (p "There was an error saving your response please try again "
+ "and if it continues to fail, reach out to us at " ,email))))
+ (c #f))
+ (lambda ()
+ ;; The data is in pairs of (ID__key . val), so the first thing to do
+ ;; is to walk through that data and build up a view of each guest
+ (let loop ((guests '()) (fdata (read-urlencoded-request-data (current-request))))
+ (if (null? fdata) ;; Done parsing all our form data
+ (begin
+ ;; This will raise if update-guest fails (so we get an error page)
+ (for-each print (map update-guest (map cdr guests)))
+ (send-sxml
+ (template-page
+ `((h2 "RSVP")
+ (p "Success! Thanks for RSVP-ing.")
+ (p (a (@ (href "/")) "Edit your response"))
+ (p (a (@ (href "https://jennex.org")) "Read more about the event"))))))
+ (let* ((input (car fdata))
+ (name (car input))
+ (value (cdr input))
+ (split (string-split (symbol->string name) "__"))
+ (id (string->number (car split)))
+ (cached-guest (assoc id guests))
+ (key (string->symbol (cadr split)))
+ (setter! (cdr (assoc key key-to-setter))))
+ (if cached-guest
+ (begin
+ (print "setting to " value)
+ (setter! (cdr cached-guest) value)
+ (loop guests (cdr fdata)))
+ (let ((guest (get-guest-by-id id)))
+ (setter! guest value)
+ (loop (cons (cons id guest) guests) (cdr fdata))))))))))))
