handler.scm (8423B) [raw]
1 ;; handler.scm -- define the routes for Spiffy 2 (import 3 spiffy 4 uri-common 5 intarweb 6 sxml-serializer 7 sql-null 8 (chicken string) 9 (chicken condition)) 10 11 (include "db.scm") 12 13 (define email '(a (@ (href "mailto:rsvp@jennex.org")) "rsvp@jennex.org")) 14 15 (define routes 16 ;; See uri-match for format: http://wiki.call-cc.org/eggref/5/uri-match#routes-format 17 ;; 18 ;; NOTE: wrap the route handlers in lambdas so that the REPL picks up 19 ;; changes on re-definition. 20 `(((/ "") (GET ,(lambda (c) (route-get-index c)))) 21 ((/ "rsvp") 22 (GET ,(lambda (c) (route-get-rsvp c))) 23 (POST ,(lambda (c) (route-post-rsvp c)))))) 24 25 (define (send-sxml sxml) 26 (send-response status: 'ok body: (serialize-sxml sxml))) 27 28 (define (template-page sxml) 29 `(html 30 (head (title "Alex and Jennie's Wedding") 31 (meta (@ (charset "utf-8"))) 32 (meta (@ (name "viewport") (content "width=device-width, initial-scale=1"))) 33 (link (@ (rel "icon") (type "image/png") (sizes "32x32") (href "/static/favicon-32x32.png"))) 34 (link (@ (rel "icon") (type "image/png") (sizes "16x16") (href "/static/favicon-16x16.png"))) 35 (link (@ (rel "stylesheet") (href "/style.css")))) 36 (body 37 (h1 (@ (class "index-title")) "Alex " (small "&") " Jennie") 38 (p (@ (class "subtitle")) "Tie the Knot") 39 (nav 40 (a (@ (href "https://jennex.org")) "Home") 41 (a (@ (href "https://jennex.org/story.html")) "Our Story") 42 (a (@ (href "/")) "RSVP") 43 (a (@ (href "https://jennex.org/event.html")) "Event") 44 (a (@ (href "https://jennex.org/travel.html")) "Travel") 45 (a (@ (href "https://jennex.org/registry.html")) "Registry")) 46 ,@sxml 47 (footer "Copyright 2022, Alex Karle (" (a (@ (href "https://jennex.org/license.html")) "License") ")")))) 48 49 50 (define (route-get-index c) 51 (send-sxml 52 (template-page 53 '((h2 "RSVP") 54 (p "Thanks for RSVP'ing! To start, please lookup the " 55 "name on your invitation.") 56 (form (@ (class "find-invite") (action "/rsvp")) 57 (input (@ (class "find-invite") (name "rsvp-name"))) 58 (button (@ (class "find-invite")) "Find Invitation")) 59 (p "Please let us know by DATE whether you can make it!"))))) 60 61 (define (guest-to-form g) 62 (define (input-name key) 63 `(name ,(conc (number->string (guest-id g)) "__" key))) 64 (define (get-going-attrs val) 65 `(,(input-name "going") 66 (value ,val) 67 (type "radio") 68 (required "true") 69 ,@(if (equal? (guest-going g) val) '((checked)) '()))) 70 (define (get-meal-attrs val) 71 `((value ,val) 72 ,@(if (equal? (guest-meal-choice g) val) '((selected)) '()))) 73 ;; TODO: add notes section for allergies, etc 74 `((div (@ (class "guest")) 75 (fieldset 76 (legend ,(guest-name g)) 77 (label (strong "Name: ") 78 (input (@ ,(input-name "name") (required "true") (value ,(guest-name g))))) 79 (p (strong "Will You be Attending?")) 80 (label (input (@ ,@(get-going-attrs 1))) "Yes!") 81 (br) 82 (label (input (@ ,@(get-going-attrs 0))) "No :(") 83 (br) 84 (label (@ (class "meal-choice")) 85 (strong "Meal Choice:") 86 (select (@ ,(input-name "meal-choice")) 87 (option (@ ,@(get-meal-attrs "")) "-- Please Select if Attending --") 88 (option (@ ,@(get-meal-attrs "chicken")) "Chicken") 89 (option (@ ,@(get-meal-attrs "beef")) "Beef") 90 (option (@ ,@(get-meal-attrs "vegetarian")) "Vegetarian") 91 (option (@ ,@(get-meal-attrs "vegan")) "Vegan"))))))) 92 93 (define (route-get-rsvp c) 94 ;; TODO: strip trailing spaces in names? (here and on save) 95 (call/cc 96 (lambda (c) 97 (with-exception-handler 98 (lambda (exn) 99 (print-error-message exn) 100 ;; TODO: only print stack trace if NOT a sqlite3 no-data exeption! 101 (print-call-chain) 102 (send-sxml 103 (template-page 104 `((h2 "RSVP") 105 (p "Sorry! We can't find anyone under that name. " 106 "Please double check the spelling and if it looks like a " 107 "mistake on our end email us at " ,email) 108 (p (a (@ (href "/")) "Back"))))) 109 (c #f)) 110 (lambda () 111 ;; TODO: consider a POST instead of GET to prevent people from sharing 112 ;; their edit links? 113 (let* ((q (uri-query (request-uri (current-request)))) 114 (name (alist-ref 'rsvp-name q))) 115 (send-sxml 116 (template-page 117 (let ((party (get-party-by-name name))) 118 `((h2 "RSVP") 119 (p "Great news! You're invited :) We can't wait to celebrate with you!") 120 (p "We've found the following guests under your name. For each, please " 121 "select whether you'll make it and your choice of meal.") 122 (form (@ (action "/rsvp") (method "POST")) 123 ,@(map guest-to-form (party-guests party)) 124 (h3 "Additional Information") 125 (label (@ (for "notes")) 126 "Anything else we should know? (Allergies, kids, ...)") 127 (textarea (@ (class "party-notes") 128 (name ,(conc (party-id party) "__notes")) 129 (rows 5)) 130 ,(let ((notes (party-notes party))) 131 (if (sql-null? notes) 132 "" 133 notes))) 134 (button (@ (class "party-update")) "Save")))))))))))) 135 136 (define key-to-setter 137 ;; Just an a-list of input names -> guest-setter functions 138 ;; (allowing the request to specify any string is dangerous) 139 `(("going" . ,guest-going-set!) 140 ("meal-choice" . ,guest-meal-choice-set!) 141 ("name" . ,guest-name-set!))) 142 143 (define (route-post-rsvp c) 144 (call/cc 145 (lambda (c) 146 (with-exception-handler 147 (lambda (exn) 148 (print-error-message exn) 149 (print-call-chain) 150 (send-sxml 151 (template-page 152 `((h2 "RSVP") 153 ;; TODO: log it better... 154 (p "There was an error saving your response please try again " 155 "and if it continues to fail, reach out to us at " ,email)))) 156 (c #f)) 157 (lambda () 158 ;; The data is in pairs of (ID__key . val), so the first thing to do 159 ;; is to walk through that data and build up a view of each guest 160 (let loop ((guests '()) 161 (fdata (read-urlencoded-request-data (current-request))) 162 (notes "")) 163 (if (null? fdata) ;; Done parsing all our form data 164 (begin 165 ;; This will raise if update-guest fails (so we get an error page) 166 (map update-guest (map cdr guests)) 167 (let* ((first-guest (cdadr guests)) 168 (first-name (guest-name first-guest)) 169 (edit-link (conc "/rsvp?rsvp-name=" (uri-encode-string first-name)))) 170 (update-party-notes (guest-party-id first-guest) notes) 171 (send-sxml 172 (template-page 173 `((h2 "RSVP") 174 (p "Success! Thanks for RSVP-ing.") 175 (p (a (@ (href ,edit-link))) "Edit your response") 176 (p (a (@ (href "https://jennex.org")) "Read more about the event"))))))) 177 (let* ((input (car fdata)) 178 (name (car input)) 179 (value (cdr input)) 180 (split (string-split (symbol->string name) "__")) 181 (id (string->number (car split))) 182 (cached-guest (alist-ref id guests)) 183 (key (cadr split)) 184 (setter! (alist-ref key key-to-setter equal?))) 185 ;; special case notes since it updates the party 186 (if (equal? key "notes") 187 (loop guests (cdr fdata) value) 188 (if cached-guest 189 (begin 190 (setter! cached-guest value) 191 (loop guests (cdr fdata) notes)) 192 (let ((guest (get-guest-by-id id))) 193 (setter! guest value) 194 (loop (cons (cons id guest) guests) (cdr fdata) notes))))))))))))