From 7b89b4cd703ee1123f01e3ddba0ae24911baf410 Mon Sep 17 00:00:00 2001
From: Benji Dial <benji@benjidial.net>
Date: Wed, 7 Feb 2024 19:04:23 -0500
Subject: first commit

---
 database.rkt | 131 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 131 insertions(+)
 create mode 100644 database.rkt

(limited to 'database.rkt')

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))
-- 
cgit v1.2.3