#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 "") (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))))))))