1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
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))
|