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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
|
(import (chicken format) (srfi-1))
(import spiffy intarweb uri-common html-parser (chicken port))
(import (chicken io))
(import sqlite3)
(import srfi-69)
(import (chicken random))
(import (chicken process-context))
;; db open and create
(define db (open-database (or (get-environment-variable "DB_FILE") "/tmp/54itter.db")))
(when (zero? (first-result db "SELECT count(*) FROM sqlite_master WHERE type='table' AND name='posts'"))
(execute db "CREATE TABLE posts (
id TEXT PRIMARY KEY,
user_id TEXT,
content TEXT,
created_at DATETIME default current_timestamp,
parent_id TEXT
)")
(execute db "CREATE TABLE flush_votes (
user_id TEXT PRIMARY KEY,
created_at DATETIME default current_timestamp
)")
)
(define (create-post user content)
(let ([id (pseudo-random-integer 281474976710655)])
(execute db "insert into posts (id, user_id, content) values (?, ?, ?)"
id user content)))
(define (vote-to-flush user)
(execute db "insert or ignore into flush_votes (user_id) values (?)"
user))
(define (unvote user)
(execute db "delete from flush_votes where user_id = ?" user))
(define (vote-count) (first-result db "SELECT count(*) FROM flush_votes"))
(define (user-has-voted user) (= 1 (first-result db
"SELECT count(*) FROM flush_votes WHERE user_id = ?"
user)))
;;
;(define (read-request-string request)
; (let* ((p (request-port request))
; (len (header-value 'content-length (request-headers request)))
; (port (request-port request)))
; (read-u8vector len port)))
(define stylesheet (read-string #f
(open-input-file "./style.css" #:text)))
(define (top-posts) (map-row list db
"SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
FROM posts p
LEFT JOIN posts c ON c.id = p.parent_id
WHERE c.parent_id IS NULL
GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
ORDER BY count(c.id) DESC, p.created_at DESC LIMIT 25"))
(define (get-post post-id)
(first-row db
"SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
FROM posts p
LEFT JOIN posts c ON c.id = p.parent_id
WHERE p.id = ?
GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
ORDER BY count(c.id) DESC LIMIT 1"
post-id))
(define (get-child-posts post-id)
(map-row list db
"SELECT p.id, p.user_id, p.content, p.created_at, p.parent_id, count(c.id)
FROM posts p
LEFT JOIN posts c ON c.id = p.parent_id
WHERE c.parent_id IS ?
GROUP BY p.id, p.user_id, p.content, p.created_at, p.parent_id
ORDER BY count(c.id) DESC, p.created_at DESC LIMIT 25" post-id))
(define (delete-post post-id current-user)
(execute db "DELETE FROM posts WHERE id = ? AND user_id = ?" post-id current-user))
;(define (top-posts) (map-row list db
; "SELECT id, user_id, content, created_at
; FROM posts
; WHERE parent_id IS NULL
; ORDER BY created_at DESC LIMIT 25"))
(define (id p) (first p))
(define (user p) (second p))
(define (content p) (third p))
(define (created-at p) (fourth p))
(define (parent-id p) (fifth p))
(define (children-count p) (sixth p))
(define users (alist->hash-table '(("lawrence" . "pw") ("demo" . "pw") ("dan" . "pw"))))
(define apikeys (make-hash-table))
(define (login username password)
(let ([apikey (number->string (pseudo-random-integer 340282366920938463463374607431768211455))])
(hash-table-set! apikeys apikey username)
apikey))
(define (lookup-user apikey) (hash-table-ref/default apikeys apikey #f))
(define (get-current-user)
(let* ([headers (request-headers (current-request))]
[cookie (header-value 'cookie headers)]
[apikey (if cookie (cdr cookie) #f)])
(if apikey (lookup-user apikey) #f)))
(define (post current-user)
(lambda (p)
(let ([uri (string-append "/posts/" (id p))])
`(div (@ [class "post"] [id ,(id p)])
,(if (equal? current-user (user p))
`(a (@ [href ,(string-append uri "/delete")]
[class "delete-button"])
"[delete]")
'())
(p ,(content p))
(div [@ (class "post-info")]
(em "- " ,(user p))
(span (@ [style "float:right;"])
(a (@ [href ,uri] [style "margin-right:2px;"])
"[" ,(children-count p) " comments]")
,(created-at p)
))))))
(define new-post-form
`(form (@ [class "new-post-form"] [action "/"] [method "POST"])
(span
(textarea (@ [id "content"] [name "content"] [value ""] [rows "5"] [cols "50"])))
(input (@ [id "submit"] [type "submit"] [value "Post"]))))
(define (page inner)
(with-output-to-string (lambda ()
(sxml-display-as-html
`(html (head
(link (@ [rel "stylesheet"] [href "/style.css"]))
(meta (@ [name "viewport"] [content "width=device-width, initial-scale=1"])))
(body
; (h1 "Title")
; (a (@ [href "/"]) "Back")
,inner
))))))
(define login-form
`(form (@ [class "login-form"] [action "/login"] [method "POST"])
(div
(div (label (@ [for "username"]) "Username:")
(input (@ [type "text"] [id "username"] [name "username"] [value ""])))
(div (label (@ [for "password"]) "Password:")
(input (@ [type "password"] [id "password"] [name "password"] [value ""])))
(input (@ [id "submit"] [type "submit"] [value "Submit"])))))
(define (vote-to-flush-prompt)
(let ([prompts '("Flush it all away!"
"Drain the swamp!"
"Unclog the bog!"
"Vote for a Purge!")])
(list-ref prompts (pseudo-random-integer (length prompts)))))
(define (get-route-param route param)
(let ([pattern (second route)]
[path (uri-path (request-uri (current-request)))])
(first (find
(lambda (x) (equal? (second x) (string-append ":" param)))
(zip path pattern)))))
(define (posts-page current-user displayed-posts) (page
`(div
(em "Even Shitter than Twitter")
(br)
,(if current-user
(if (user-has-voted current-user)
'(a (@ [href "/unvote"]) unvote)
`(a (@ [href "/vote-to-flush"]) ,(vote-to-flush-prompt)))
'())
(div "Votes so far: " ,(vote-count))
(div
,(if current-user
'(a (@ [style "float:right;"] [href "/logout"]) logout)
'(a (@ [style "float:right;"] [href "/login"]) login))
(h2 "Posts")
,(if current-user new-post-form '())
,(if (null? displayed-posts)
"No posts yet!"
(map (post current-user) displayed-posts))
)
)))
(define routes
`(
(GET (/ "style.css") ,(lambda (rt)
(send-response
headers: `((content-type text/css))
status: 'ok
body: stylesheet
)))
(GET (/ "unvote") ,(lambda (rt)
(unvote (get-current-user))
(send-response
headers: `((location "/"))
status: 'see-other
)))
(GET (/ "vote-to-flush") ,(lambda (rt)
(let ([user (get-current-user)]) (when user (vote-to-flush user)))
(send-response
headers: `((location "/"))
status: 'see-other
)))
(GET (/ "login") ,(lambda (rt) (send-response
headers: '((content-type text/html))
status: 'ok
body: (page `(div
(a (@ [style "float:right;"] [href "/"]) back)
(h2 "Login")
,login-form)))))
(POST (/ "login") ,(lambda (rt)
(let* ([form-data (read-urlencoded-request-data (current-request))]
[username (cdr (assv 'username form-data))]
[password (cdr (assv 'password form-data))]
[apikey (login username password)])
(send-response
headers: `((location "/")
(set-cookie
#(("apikey" . ,apikey) ())))
status: 'see-other))))
(GET (/ "logout") ,(lambda (rt)
(send-response
headers: `((location "/")
(set-cookie
#(("apikey" . "") ()))) ; should also wipe server-side keys
status: 'see-other
)))
(POST (/ "") ,(lambda (rt)
(let* ([form-data (read-urlencoded-request-data (current-request))]
[content (cdr (assv 'content form-data))]
[user (get-current-user)]
[success? (if user (create-post user content) #f)])
(send-response
headers: '((location "/"))
status: 'see-other
))))
(GET (/ "") ,(lambda (rt)
(let ([current-user (get-current-user)]
[displayed-posts (top-posts)])
(send-response
headers: '((content-type text/html))
status: 'ok
body: (posts-page current-user displayed-posts)))))
(GET (/ "posts" ":id") ,(lambda (rt)
(let* ([current-user (get-current-user)]
[post-id (get-route-param rt "id")]
[post (get-post post-id)]
[comments (get-child-posts post-id)]
[displayed-posts (cons post comments)])
(send-response
headers: '((content-type text/html))
status: 'ok
body: (posts-page current-user displayed-posts)))))
; Has method GET so that it can be used from <a> tag links
(GET (/ "posts" ":id" "delete") ,(lambda (rt)
(let* ([current-user (get-current-user)]
[post-id (get-route-param rt "id")]
[succeeded? (delete-post post-id current-user)])
(if succeeded?
(send-response
headers: `((location "/"))
status: 'see-other
)
(send-status 'internal-server-error "Deletion Failed")))))
(GET (/ "posts") ,(lambda (rt)
(send-response
headers: `((location "/"))
status: 'see-other
)))
))
(define (route-patterns-match? req pat)
(and (= (length req) (length pat))
(every
(lambda (xy)
(let ([x (first xy)] [y (second xy)])
(or (equal? x y)
(and (string? y) (< 0 (string-length y))
(equal? #\: (string-ref y 0))))))
(zip req pat))))
(define (find-route uri method)
(find
(lambda (r) (and
(equal?
method
(first r))
(route-patterns-match?
(uri-path uri)
(second r))))
routes))
(define (handle continue)
(let* ((uri (request-uri (current-request)))
(method (request-method (current-request)))
(route (find-route uri method)))
(if route
((third route) route)
(begin (display uri ) (display method) (send-status 'not-found "Page Not Found")))))
(vhost-map `((".*" . ,handle)))
(start-server port: 7080)
|
