first commit

author: Benji Dial <benji@benjidial.net> 2024-02-07 19:04:23 -0500
committer: Benji Dial <benji@benjidial.net> 2024-02-07 19:04:23 -0500
commit: 7b89b4cd703ee1123f01e3ddba0ae24911baf410 (patch)
tree: af4614d64b195b62b445591d020beb9391d644b9 /main.rkt
download: voting-site-7b89b4cd703ee1123f01e3ddba0ae24911baf410.tar.gz
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))))))))
author	Benji Dial <benji@benjidial.net>	2024-02-07 19:04:23 -0500
committer	Benji Dial <benji@benjidial.net>	2024-02-07 19:04:23 -0500
commit	7b89b4cd703ee1123f01e3ddba0ae24911baf410 (patch)
tree	af4614d64b195b62b445591d020beb9391d644b9 /main.rkt
download	voting-site-7b89b4cd703ee1123f01e3ddba0ae24911baf410.tar.gz