1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
(add-to-load-path (dirname (current-filename)))
;; (add-to-load-path "/home/jakob/Blog/dynamic")
(use-modules (base64)
(captcha)
(ice-9 binary-ports)
(json)
(srfi srfi-1)
(srfi srfi-11)
(srfi srfi-13)
(srfi srfi-26)
(squee)
(rnrs bytevectors)
(ice-9 match)
(web server)
(web request)
(web response)
(web uri))
;; Globals.
(define challenges (make-hash-table))
;; (define conn (connect-to-postgres-paramstring "dbname=jakob_comments"))
(define conn (connect-to-postgres-paramstring "dbname=jakob_rsvp"))
;; Util.
(define (acons-list k v alist)
"Add V to K to alist as list"
(let ((value (assoc-ref alist k)))
(if value
(let ((alist (alist-delete k alist)))
(acons k (cons v value) alist))
(acons k (list v) alist))))
(define (list->alist lst)
"Build a alist of list based on a list of key and values.
Multiple values can be associated with the same key"
(let next ((lst lst)
(out '()))
(if (null? lst)
out
(next (cdr lst) (acons-list (caar lst) (cdar lst) out)))))
(define (decode-form bv)
"Convert BV querystring or form data to an alist"
(define string (if (string? bv) bv (utf8->string bv)))
(define pairs (map (cut string-split <> #\=)
;; semi-colon and amp can be used as pair separator
(append-map (cut string-split <> #\;)
(string-split string #\&))))
(list->alist (map (match-lambda
((key value)
(cons (uri-decode key) (uri-decode value)))) pairs)))
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))
(define (not-found request)
(values (build-response #:code 404)
(string-append "Resource not found: "
(uri->string (request-uri request)))))
;;
(define (get-comments request body)
(values '((content-type . (application/json)))
(scm->json-string
'((title . "whoa buddy")
(author . "Jakob Kreuze")
(date . "2022-03-27")
(text . "bad take, bad take!")))))
(define (put-comment request body)
(display (decode-form body))
(newline)
(values '((content-type . (text/plain))) "Hello hacker!"))
(define (make-challenge request body)
(let-values (((uuid value image) (new-captcha)))
(hash-set! challenges uuid value)
(hash-for-each (lambda (x y) (display x) (newline)) challenges)
(values `((content-type . (application/base64))
(access-control-allow-origin . "*")
(x-captcha-id . ,uuid))
(base64-encode image))))
;; (define (valid-invite-code invitation)
;; (and (= (string-length))))
(define (generate-vanity-code)
(call-with-input-file "/dev/urandom"
(lambda (port)
(base64-encode (get-bytevector-n port 9)))))
(define (post-event-rsvp request body)
(let* ((params (json-string->scm (utf8->string body)))
(invitation-code (assoc-ref params "id"))
(name (assoc-ref params "name"))
(email (assoc-ref params "email"))
(attending (assoc-ref params "rsvp"))
(guests (assoc-ref params "guests")))
(cond ((not (and invitation-code name email attending guests))
(values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*")))
(scm->json-string
`((success . #f)
(error . "Invalid form data")))))
((> 1 (length (exec-query conn "SELECT event_id FROM invitations WHERE vanity = $1" (list invitation-code))))
(values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*")))
(scm->json-string
`((success . #f)
(error . "Invalid invitation code")))))
(else
(let* ((receipt-code (generate-vanity-code))
(event-id (caar (exec-query conn "SELECT event_id FROM invitations WHERE vanity = $1" (list invitation-code)))))
(exec-query conn "INSERT INTO rsvps (vanity, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6)" (list receipt-code event-id name email attending guests))
(values '((content-type . (application/json))
(Access-Control-Allow-Origin . "*"))
(scm->json-string
`((receipt . ,receipt-code)))))))))
(define (get-event-info request body)
(define (format-rsvp rsvp)
(match rsvp
((name email guests)
`((name . ,name)
(email . ,email)
(guests . ,guests)))))
(let* ((params (decode-form (uri-query (request-uri request))))
(invitation-code (car (assoc-ref params "i")))
(invitation (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1" (list invitation-code))))
(if (> 1 (length invitation))
(values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*")))
(scm->json-string
`((success . #f)
(error . "Invalid invitation code"))))
(let* ((capabilities (cadar invitation))
(event (exec-query conn "SELECT * FROM events WHERE id = $1" (list (caar invitation))))
(rsvps (exec-query conn "SELECT fullname, email, guests FROM rsvps WHERE event_id = $1" (list (caar invitation)))))
(match (car event)
((i_ title description date location)
(values '((content-type . (application/json))
(Access-Control-Allow-Origin . "*"))
(scm->json-string
`((title . ,title)
(description . ,description)
(image . #f)
(date . ,date)
(location . ,location)
,@(if (= 1 (logand (string->number capabilities) 1))
`((rsvps . ,(list->vector (map format-rsvp rsvps))))
'()))))))))))
(define (handle-api-request request body endpoint)
(display (cons (request-method request) endpoint))
(newline)
((match (cons (request-method request) endpoint)
;; ('(GET "challenge") make-challenge)
;; ('(GET "comments") get-comments)
;; ('(POST "comment") put-comment)
('(GET "rsvp" "event-info") get-event-info)
('(POST "rsvp") post-event-rsvp)
(_ (lambda (. args) (not-found request))))
request body))
(define (main-request-handler request body)
(let ((path (request-path-components request)))
(if (string= "api" (first path))
(handle-api-request request body (drop path 1))
(not-found request))))
(run-server main-request-handler 'http '(#:port 8081))
|
