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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(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))
|
