diff options
Diffstat (limited to 'main.rkt')
| -rw-r--r-- | main.rkt | 204 |
1 files changed, 204 insertions, 0 deletions
diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..f6a2abe --- /dev/null +++ b/main.rkt @@ -0,0 +1,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)))))))) |