diff options
24 files changed, 511 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..dbf4200 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +database.db diff --git a/config.rkt b/config.rkt new file mode 100644 index 0000000..28b43ee --- /dev/null +++ b/config.rkt @@ -0,0 +1,23 @@ +#lang racket + +(provide + signin-key-time + session-time + site-title + email-server + email-port + email-user + email-password + email-from) + +(define signin-key-time 3600) +(define session-time 3600) + +(define site-title "Benji's Voting Site") + +(error "please fill out the email entries in config.rkt and then comment out this line") +(define email-server "smtp.example.org") +(define email-port 587) +(define email-user "noreply@example.org") +(define email-password "my super secret password") +(define email-from "noreply@example.org") diff --git a/database.rkt b/database.rkt new file mode 100644 index 0000000..a118b75 --- /dev/null +++ b/database.rkt @@ -0,0 +1,131 @@ +#lang racket + +(require koyo/random) +(require smtp) +(require db) + +(require "config.rkt") + +(provide + make-signin-key + create-user + verify-signin-key + create-session + user-exists + no-outstanding-signin + remove-session + session-to-user-id) + +(current-smtp-host email-server) +(current-smtp-port email-port) +(current-smtp-username email-user) +(current-smtp-password email-password) + +(define (valid-user-id str) + (let ((lst (map char->integer (string->list str)))) + (and + (for/or ((c lst)) + (and (>= c (char->integer #\a)) (<= c (char->integer #\z)))) + (for/and ((c lst)) + (or + (and (>= c (char->integer #\a)) (<= c (char->integer #\z))) + (and (>= c (char->integer #\0)) (<= c (char->integer #\9))) + (= c (char->integer #\.))))))) + +;nothing breaks if an invalid email is used, this is just used as a sanity check against form input +(define (valid-email str) + (string-contains? str "@")) + +(define dbc + (sqlite3-connect + #:database "database.db" + #:mode 'create)) + +(query-exec dbc + "CREATE TABLE IF NOT EXISTS users (user_id TEXT PRIMARY KEY, email TEXT UNIQUE NOT NULL, email_verified INTEGER NOT NULL)") +(query-exec dbc + "CREATE TABLE IF NOT EXISTS signin_keys (user_id TEXT PRIMARY KEY, key TEXT NOT NULL, expires INTEGER NOT NULL)") +(query-exec dbc + "CREATE TABLE IF NOT EXISTS sessions (session_id TEXT PRIMARY KEY, user_id TEXT UNIQUE NOT NULL, expires INTEGER NOT NULL)") + +;returns boolean +(define (email-verified user-id) + (query-maybe-value dbc "SELECT 1 FROM users WHERE user_id = $1 AND email_verified = 1" user-id)) + +(define (user-exists user-id) + (query-maybe-value dbc "SELECT 1 FROM users WHERE user_id = $1" user-id)) + +(define (no-outstanding-signin user-id) + (let ((expires (query-maybe-value dbc "SELECT expires FROM signin_keys WHERE user_id = $1" user-id))) + (if expires + (<= expires (current-seconds)) + #t))) + +(define (session-to-user-id session-id) + (let ((row (query-maybe-row dbc "SELECT user_id, expires FROM sessions WHERE session_id = $1" session-id))) + (if row + (let ((user-id (vector-ref row 0)) + (expires (vector-ref row 1))) + (if (> expires (current-seconds)) + user-id + #f)) + #f))) + +;returns nothing +(define (make-signin-key user-id) + (let ((key (generate-random-string)) + (expires (+ (current-seconds) signin-key-time)) + (email-to (query-value dbc "SELECT email FROM users WHERE user_id = $1" user-id))) + (with-handlers ((exn:fail? (lambda (_) (void)))) + (send-smtp-mail + (make-mail + "Login key" + (string-append "Your signin key is: " key "\nThis key is only valid for one signin. Do not share this key with anyone.") + #:from email-from + #:to `(,email-to)))) + (query-exec dbc + "REPLACE INTO signin_keys (user_id, key, expires) VALUES ($1, $2, $3)" user-id key expires))) + +;returns boolean +(define (email-in-use email) + (query-maybe-value dbc "SELECT 1 FROM users WHERE email = $1 AND email_verified = 1" email)) + +;returns boolean +(define (create-user user-id email) + (if (or + (email-verified user-id) + (email-in-use email) + (not (valid-user-id user-id)) + (not (valid-email email))) + #f + (begin + (query-exec dbc "DELETE FROM users WHERE user_id = $1 OR email = $2" user-id email) + (query-exec dbc + "INSERT INTO users (user_id, email, email_verified) VALUES ($1, $2, 0)" user-id email) + (make-signin-key user-id) + #t))) + +;returns boolean +(define (verify-signin-key user-id key) + (let ((expires + (query-maybe-value dbc + "SELECT expires FROM signin_keys WHERE user_id = $1 AND key = $2" user-id key))) + (if expires + (begin + (query-exec dbc "DELETE FROM signin_keys WHERE user_id = $1" user-id) + (> expires (current-seconds))) + #f))) + +;returns session id +(define (create-session user-id) + (let ((session-id (generate-random-string)) + (expires (+ (current-seconds) session-time))) + (query-exec dbc "DELETE FROM sessions WHERE user_id = $1" user-id) + (query-exec dbc + "REPLACE INTO sessions (session_id, user_id, expires) VALUES ($1, $2, $3)" + session-id user-id expires) + (query-exec dbc "UPDATE users SET email_verified = 1 WHERE user_id = $1" user-id) + session-id)) + +(define (remove-session user-id) + (query-exec dbc "DELETE FROM sessions WHERE user_id = $1" user-id)) diff --git a/database.txt b/database.txt new file mode 100644 index 0000000..c591fb1 --- /dev/null +++ b/database.txt @@ -0,0 +1,19 @@ +the following tables exist in the database: + +CREATE TABLE users ( + user_id TEXT PRIMARY KEY, + email TEXT UNIQUE NOT NULL, + email_verified INTEGER NOT NULL +) + +CREATE TABLE signin_keys ( + user_id TEXT PRIMARY KEY, + key TEXT NOT NULL, + expires INTEGER NOT NULL +) + +CREATE TABLE sessions ( + session_id TEXT PRIMARY KEY + user_id TEXT UNIQUE NOT NULL, + expires INTEGER NOT NULL +) 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)))))))) diff --git a/readme.txt b/readme.txt new file mode 100644 index 0000000..652a1ef --- /dev/null +++ b/readme.txt @@ -0,0 +1,36 @@ +=== voting-site === + +This is the source of the website at vote.benjidial.net. + +=== dependencies === + +This code is written in Racket and requires a few packages. On Debian, you can +get all of the dependencies by running the following commands: + sudo apt install racket + raco pkg install koyo scgi smtp + +=== running === + +The server can be run with `racket main.rkt`. This will start a scgi server +on port 9000. You will need an SCGI-compatible web server. For example, with +nginx, you can make a server entry with: + server { + location / { + include scgi_params; + scgi_pass localhost:9000; + } + } + +=== attribution === + +The files static/CrimsonPro-*.woff2 are from + https://github.com/Fonthausen/CrimsonPro +and are licensed under the Open Font License, version 1.1. +This license can be found at: + https://github.com/Fonthausen/CrimsonPro/blob/master/OFL.txt + +The file static/favicon.ico is from + https://www.flaticon.com/free-icons/vote +and is licensed under the Flaticon license. +This license can be found at: + https://www.freepikcompany.com/legal#nav-flaticon diff --git a/static/CrimsonPro-Black.woff2 b/static/CrimsonPro-Black.woff2 Binary files differnew file mode 100644 index 0000000..ef9eb5b --- /dev/null +++ b/static/CrimsonPro-Black.woff2 diff --git a/static/CrimsonPro-BlackItalic.woff2 b/static/CrimsonPro-BlackItalic.woff2 Binary files differnew file mode 100644 index 0000000..2135dd2 --- /dev/null +++ b/static/CrimsonPro-BlackItalic.woff2 diff --git a/static/CrimsonPro-Bold.woff2 b/static/CrimsonPro-Bold.woff2 Binary files differnew file mode 100644 index 0000000..1f3feba --- /dev/null +++ b/static/CrimsonPro-Bold.woff2 diff --git a/static/CrimsonPro-BoldItalic.woff2 b/static/CrimsonPro-BoldItalic.woff2 Binary files differnew file mode 100644 index 0000000..1c4b6ee --- /dev/null +++ b/static/CrimsonPro-BoldItalic.woff2 diff --git a/static/CrimsonPro-ExtraBold.woff2 b/static/CrimsonPro-ExtraBold.woff2 Binary files differnew file mode 100644 index 0000000..cfa601e --- /dev/null +++ b/static/CrimsonPro-ExtraBold.woff2 diff --git a/static/CrimsonPro-ExtraBoldItalic.woff2 b/static/CrimsonPro-ExtraBoldItalic.woff2 Binary files differnew file mode 100644 index 0000000..fad98e2 --- /dev/null +++ b/static/CrimsonPro-ExtraBoldItalic.woff2 diff --git a/static/CrimsonPro-ExtraLight.woff2 b/static/CrimsonPro-ExtraLight.woff2 Binary files differnew file mode 100644 index 0000000..ac3d103 --- /dev/null +++ b/static/CrimsonPro-ExtraLight.woff2 diff --git a/static/CrimsonPro-ExtraLightItalic.woff2 b/static/CrimsonPro-ExtraLightItalic.woff2 Binary files differnew file mode 100644 index 0000000..a0b7490 --- /dev/null +++ b/static/CrimsonPro-ExtraLightItalic.woff2 diff --git a/static/CrimsonPro-Italic.woff2 b/static/CrimsonPro-Italic.woff2 Binary files differnew file mode 100644 index 0000000..977dc69 --- /dev/null +++ b/static/CrimsonPro-Italic.woff2 diff --git a/static/CrimsonPro-Light.woff2 b/static/CrimsonPro-Light.woff2 Binary files differnew file mode 100644 index 0000000..8d4ffad --- /dev/null +++ b/static/CrimsonPro-Light.woff2 diff --git a/static/CrimsonPro-LightItalic.woff2 b/static/CrimsonPro-LightItalic.woff2 Binary files differnew file mode 100644 index 0000000..5dfee09 --- /dev/null +++ b/static/CrimsonPro-LightItalic.woff2 diff --git a/static/CrimsonPro-Medium.woff2 b/static/CrimsonPro-Medium.woff2 Binary files differnew file mode 100644 index 0000000..739ad7a --- /dev/null +++ b/static/CrimsonPro-Medium.woff2 diff --git a/static/CrimsonPro-MediumItalic.woff2 b/static/CrimsonPro-MediumItalic.woff2 Binary files differnew file mode 100644 index 0000000..3583867 --- /dev/null +++ b/static/CrimsonPro-MediumItalic.woff2 diff --git a/static/CrimsonPro-Regular.woff2 b/static/CrimsonPro-Regular.woff2 Binary files differnew file mode 100644 index 0000000..cbc9d82 --- /dev/null +++ b/static/CrimsonPro-Regular.woff2 diff --git a/static/CrimsonPro-SemiBold.woff2 b/static/CrimsonPro-SemiBold.woff2 Binary files differnew file mode 100644 index 0000000..be60d1e --- /dev/null +++ b/static/CrimsonPro-SemiBold.woff2 diff --git a/static/CrimsonPro-SemiBoldItalic.woff2 b/static/CrimsonPro-SemiBoldItalic.woff2 Binary files differnew file mode 100644 index 0000000..8982118 --- /dev/null +++ b/static/CrimsonPro-SemiBoldItalic.woff2 diff --git a/static/favicon.ico b/static/favicon.ico Binary files differnew file mode 100644 index 0000000..a9a9dc3 --- /dev/null +++ b/static/favicon.ico diff --git a/static/style.css b/static/style.css new file mode 100644 index 0000000..d96635a --- /dev/null +++ b/static/style.css @@ -0,0 +1,97 @@ +:root { + --main-bg: white; + --nav-bg: lightgray; + --main-fg: black; + --links: #3271e7; +} + +@font-face { + font-family: 'Crimson Pro'; + src: url(/static/CrimsonPro-Regular.woff2) format('woff2'); +} + +@font-face { + font-family: 'Crimson Pro'; + font-weight: bold; + src: url(/static/CrimsonPro-Bold.woff2) format('woff2'); +} + +body { + background-color: var(--main-bg); + margin: 0px; + color: var(--main-fg); +} + +.header-outer { + height: 80px; + position: fixed; + top: 0px; +} + +.footer-outer { + height: 60px; + position: fixed; + bottom: 0px; +} + +.header-outer, .footer-outer { + background-color: var(--nav-bg); + width: 100%; +} + +.header-inner, .footer-inner { + max-width: 800px; + margin: auto; + padding-top: 20px; + padding-bottom: 20px; + display: flex; +} + +.header-inner { + justify-content: space-between; +} + +.footer-inner { + justify-content: flex-start; + gap: 20px; +} + +.header-inner h1, .header-inner p, .footer-inner p { + margin: 0px; +} + +.header-inner h1 a { + color: var(--main-fg); +} + +.header-inner .login-info { + text-align: right; +} + +.content { + padding-top: 80px; + padding-bottom: 60px; + max-width: 800px; + margin: auto; +} + +h1, h2, p, label, input { + font-family: 'Crimson Pro'; +} + +h1 { + font-size: 36px; +} + +h2 { + font-size: 27px; +} + +p, label, input { + font-size: 18px; +} + +a { + text-decoration: none; + color: var(--links); +} |