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
|
#lang racket
(require net/mime-type)
(require net/uri-codec)
(require scgi)
(require xml)
(require "database.rkt")
(require "config.rkt")
(register-mime-type! 'woff2 "font/woff2")
(define session-user-id (make-parameter #f))
(define (respond #:code (code 200) title . body)
(display "Status: ")
(display code)
(display "\r\nContent-type: text/html\r\n\r\n")
(display "<!doctype html>")
(display (xexpr->string
`(html ((lang "en-US"))
(head
(meta ((charset "utf-8")))
(link ((rel "stylesheet") (href "/static/style.css")))
(title ,title))
(body
(div ((class "header-outer"))
(div ((class "header-inner"))
(div ((class "site-title"))
(h1 (a ((href "/")) ,site-title)))
,(if (session-user-id)
`(div ((class "signin-info"))
(p "Signed in as " ,(session-user-id) ".")
(p (a ((href "/sign-out")) "Sign out")))
`(div ((class "signin-info"))
(p "Not signed in.")
(p (a ((href "/sign-in")) "Sign in"))))))
(div ((class "content"))
,@body)
(div ((class "footer-outer"))
(div ((class "footer-inner"))
(p "Copyright 2024 Benji Dial.")
(p
(a ((href "https://git.benjidial.net/voting-site/"))
"Source code"))
(p
(a ((href "https://www.flaticon.com/free-icons/vote"))
"Vote icon by Freepik on Flaticon.")))))))))
(define (respond-redirect code to)
(display "Status: ")
(display code)
(display "\r\nLocation: ")
(display to)
(display "\r\n\r\n"))
(define (respond-home)
(respond "Home"
'(p "This is a test.")
(if (session-user-id)
`(p "Hello, " ,(session-user-id) ".")
(make-comment ""))))
(define (respond-sign-up user-id email bad-input)
(if (and user-id email)
(if (create-user user-id email)
(respond-redirect 303 (string-append "/sign-in?user-id=" user-id))
(respond-redirect 303 "/sign-up?bad-input=1"))
(respond "Sign Up"
'(h2 "Sign Up")
'(form
(label ((for "user-id")) "User ID:") " "
(input ((type "text") (id "user-id") (name "user-id"))) (br)
(label ((for "email")) "Email:") " "
(input ((type "text") (id "email") (name "email"))) " "
(input ((type "submit") (value "Sign up"))))
'(p "The user ID must be composed only of lowercase letters, numbers, and periods, and must have at least one lowercase letter.")
(if bad-input
'(p "Either that user ID or email is already in use, or the input did not fit the required format.")
(make-comment "")))))
(define (respond-sign-in user-id signin-key bad-user bad-key)
(cond
(signin-key
(if (verify-signin-key user-id signin-key)
(let ((session-id (create-session user-id)))
(display "Set-Cookie: session_id=")
(display session-id)
(display "; HttpOnly; SameSite=Strict; Secure\r\n")
(respond-redirect 303 "/"))
(respond-redirect 303 (string-append "/sign-in?user-id=" user-id "&bad-key=1"))))
(user-id
(if (user-exists user-id)
(begin
(when (no-outstanding-signin user-id)
(make-signin-key user-id))
(respond "Sign In"
'(h2 "Sign In")
`(p "An email with a signin key has been sent from " ,email-from " to the address associated with that user ID. Please enter the signin key below.")
`(form
(input ((type "hidden") (id "user-id") (name "user-id") (value ,user-id)))
(label ((for "signin-key")) "Signin key:") " "
(input ((type "text") (id "signin-key") (name "signin-key"))) " "
(input ((type "submit") (value "Sign in"))))
(if bad-key
'(p "That signin key was incorrect.")
(make-comment ""))))
(respond-redirect 303 "/sign-in?bad-user=1")))
(else
(respond "Sign In"
'(h2 "Sign In")
'(form
(label ((for "user-id")) "User ID:") " "
(input ((type "text") (id "user-id") (name "user-id"))) " "
(input ((type "submit") (value "Sign in"))))
(if bad-user
'(p "No user was found with that ID.")
(make-comment ""))
'(p "If you do not have an account, you may "
(a ((href "/sign-up")) "sign up")
".")))))
(define (respond-sign-out)
(when (session-user-id)
(remove-session (session-user-id)))
(respond-redirect 303 "/"))
(define (respond-not-found)
(respond #:code 404 "Not Found"
'(h2 "Not Found")
'(p "Could not find that page.")))
(define (respond-static p)
(if (file-exists? p)
(let* ((file (open-input-file p))
(content (port->bytes file #:close? #t)))
(display "Content-type: ")
(display (path-mime-type p))
(display "\r\n\r\n")
(display content))
(respond-not-found)))
(define (starts-with lst1 lst2)
(cond
((equal? lst2 '())
#t)
((equal? lst1 '())
#f)
((equal? (car lst1) (car lst2))
(starts-with (cdr lst1) (cdr lst2)))
(else
#f)))
(cgi
#:scgi-portnum 9000
#:request
(lambda ()
(let* ((uri-parts (string-split (cgi-request-uri) "?"))
(uri-path (string->path (car uri-parts))))
(unless (absolute-path? uri-path)
(error "cgi-request-uri not absolute"))
(let ((p (map path->string (cdr (explode-path (simplify-path uri-path)))))
(q
(if (pair? (cdr uri-parts))
(make-hash
(map
(lambda (s)
(let ((lst (string-split s "=")))
(cons
(uri-decode (car lst))
(if (equal? (cdr lst) '())
""
(uri-decode (cadr lst))))))
(string-split (cadr uri-parts) "&")))
(make-hash)))
(s
(if (cgi-http-cookie)
(if (string-prefix? (cgi-http-cookie) "session_id=")
(substring (cgi-http-cookie) 11)
#f)
#f)))
(parameterize ((session-user-id (if s (session-to-user-id s) #f)))
(cond
((equal? p '("favicon.ico"))
(respond-redirect 301 "/static/favicon.ico"))
((starts-with p '("static"))
(respond-static (apply build-path p)))
((equal? p '())
(respond-home))
((equal? p '("sign-in"))
(respond-sign-in
(hash-ref q "user-id" #f)
(hash-ref q "signin-key" #f)
(hash-ref q "bad-user" #f)
(hash-ref q "bad-key" #f)))
((equal? p '("sign-up"))
(respond-sign-up
(hash-ref q "user-id" #f)
(hash-ref q "email" #f)
(hash-ref q "bad-input" #f)))
((equal? p '("sign-out"))
(respond-sign-out))
(else
(respond-not-found))))))))
|