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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
(declaim (optimize (speed 0) (safety 3) (debug 3)))
(in-package :woodriverlessons)
(defparameter *authenticated-user-session-key* "authenticated-user")
(defclass auth-pkg (record-pkg)
()
(:documentation ""))
(defmethod insert-user ((auth-pkg auth-pkg) user)
(setf (*table user) (format nil
"auth.insert_user('~a', '~a', '~a', '~a', '~a', '~a', '~a')"
(username user)
(pwd user)
(first_name user)
(last_name user)
(email user)
(phone user)
(active user)))
(setf (id user) (caar (call-pg-function auth-pkg user)))
(id user))
(defmethod update-user ((auth-pkg auth-pkg) user)
(setf (*table user) (format nil
"auth.update_user(~a, '~a', '~a', '~a', '~a', '~a')"
(id user)
(username user)
(first_name user)
(last_name user)
(email user)
(phone user)))
(caar (call-pg-function auth-pkg user)))
(defmethod get-all-active-users ((auth-pkg auth-pkg))
(let ((user (make-instance 'user)))
(setf (*table user) "auth.get_all_active_users()")
(get-records auth-pkg user "first_name asc, last_name asc")))
(defmethod get-all-users ((auth-pkg auth-pkg))
(let ((user (make-instance 'user)))
(setf (*table user) "auth.get_all_users()")
(get-records auth-pkg user "first_name asc, last_name asc")))
(defmethod get-active-user-by-username-pwd ((auth-pkg auth-pkg) username pwd)
(let ((user (make-instance 'user)))
(setf (*table user) (format nil
"auth.get_active_user_by_username_pwd('~a', '~a')"
username
pwd))
(get-record auth-pkg user)))
(defmethod get-active-user-by-id ((auth-pkg auth-pkg) id)
(let ((user (make-instance 'user)))
(setf (*table user) (format nil "auth.get_active_user_by_id(~a)" id))
(get-record auth-pkg user)))
(defmethod get-user-by-id ((auth-pkg auth-pkg) id)
(let ((user (make-instance 'user)))
(setf (*table user) (format nil "auth.get_user_by_id(~a)" id))
(get-record auth-pkg user)))
(defmethod user-toggle-active ((auth-pkg auth-pkg) (user user))
(setf (*table user) (format nil "auth.user_toggle_active(~a)" (id user)))
(call-pg-function auth-pkg user))
(defmethod deactivate-user ((auth-pkg auth-pkg) (user user))
(setf (*table user) (format nil "auth.user_delete(~a)" (id user)))
(call-pg-function auth-pkg user))
(defmethod get-all-roles ((auth-pkg auth-pkg) (user user))
(let ((user-role (make-instance 'user-role
:*table (format nil
"auth.get_all_roles_for_user(~a)"
(id user)))))
(get-records auth-pkg user-role nil)))
(defmethod has-role ((auth-pkg auth-pkg) (user user) role)
(let ((user-role (make-instance 'user-role)))
(setf (*table user-role) (format nil (*table user-role) (id user) role))
(get-record auth-pkg user-role)))
(defmethod get-all-role-groups ((auth-pkg auth-pkg) (user user))
(let ((role-group (make-instance 'role-group)))
(setf (*table role-group) (format nil (*table role-group) (id user)))
(get-records auth-pkg role-group nil)))
(defmethod get-role-group-by-name ((auth-pkg auth-pkg) (user user) name)
(find-if (lambda (x)
(string= name (name x)))
(get-all-role-groups auth-pkg user)))
(defmethod get-active-role-groups ((auth-pkg auth-pkg) (user user))
(let ((role-group (make-instance 'role-group
:*table (format nil
"auth.get_active_role_groups_for_user(~a)"
(id user)))))
(get-records auth-pkg role-group nil)))
(defmethod insert-user-role-group ((auth-pkg auth-pkg) (user-role user-role))
(setf (*table user-role) (format nil
"auth.insert_user_role_group(~a, '~a')"
(user_id user-role)
(role_group_name user-role)))
(caar (call-pg-function auth-pkg user-role)))
(defmethod insert-registration ((auth-pkg auth-pkg) (registration registration))
(setf (*table registration) (format nil
"auth.insert_registration('~a', '~a', '~a', '~a')"
(first_name registration)
(last_name registration)
(email registration)
(role_groups registration)))
(setf (id registration) (caar (call-pg-function auth-pkg registration)))
(id registration))
(defmethod delete-role-groups ((auth-pkg auth-pkg) user)
(let ((role-group (make-instance 'role-group
:*table (format nil
"auth.delete_role_groups_for_user(~a)"
(id user)))))
(call-pg-function auth-pkg role-group)))
(defmethod get-registration-by-id ((auth-pkg auth-pkg) id)
(let ((registration (make-instance 'registration
:*table (format nil "auth.get_registration_by_id(~a)" id))))
(get-record auth-pkg registration)))
(defmethod get-registration-by-hash ((auth-pkg auth-pkg) hash)
(let ((registration (make-instance 'registration
:*table (format nil "auth.get_registration_by_hash('~a')" hash))))
(get-record auth-pkg registration)))
(defmethod registrations-gc ((auth-pkg auth-pkg))
(let ((registration (make-instance 'registration :*table "auth.registrations_gc()")))
(call-pg-function auth-pkg registration)))
(defmethod delete-registration ((auth-pkg auth-pkg) hash)
(let ((registration (make-instance 'registration
:*table (format nil "auth.delete_registration('~a')" hash))))
(call-pg-function auth-pkg registration)))
(defmethod update-profile ((auth-pkg auth-pkg) (user user))
(setf (*table user) (format nil
"auth.update_profile(~a, '~a', '~a', '~a', '~a', '~a')"
(id user)
(username user)
(first_name user)
(last_name user)
(email user)
(phone user)))
(call-pg-function auth-pkg user))
(defmethod update-password ((auth-pkg auth-pkg) (user user))
(setf (*table user) (format nil "auth.update_password(~a, '~a')" (id user) (pwd user)))
(call-pg-function auth-pkg user))
(defmacro with-valid-user ((session-name roles) error-body &body body)
"Runs `body' if there is a valid authenticated `user' in the
`user-session' whose roles match `roles', otherwise runs
`error-body'. If a valid `user' exists, it will be bound to
`session-name'."
`(let ((,session-name (get-session-object *authenticated-user-session-key*)))
(if ,session-name
(let* ((auth-pkg (make-instance 'auth-pkg))
(has-all-roles-p (let ((has-all-roles-p t))
(with-woodriverlessons-database
(loop for role in (if (listp ,roles) ,roles (list ,roles)) do
(when (not (has-role auth-pkg ,session-name role))
(setf has-all-roles-p nil)))
has-all-roles-p))))
(if has-all-roles-p
,@body
,error-body))
,error-body)))
(defun make-default-user ()
"Convenience function for making a new instance of `user' that has
its session key set to `authenticated-user', but has no privileges."
(make-instance 'user
:*session-key *authenticated-user-session-key*
:id 0
:first_name "Guest"
:last_name "User"))
(defun ensure-user-exists ()
"Ensures that there is an `authenticated-user' in the user session,
even if it's just a guest user."
(let ((user (get-session-object *authenticated-user-session-key*)))
(unless user
(setf user (make-default-user))
(set-user user))))
(defun get-user ()
"Convenience function for getting the `authenticated-user' from user
session."
(get-session-object *authenticated-user-session-key*))
(defun set-user (user)
"Convenience function for setting the `authenticated-user' into the
user session."
(setf (*table user) "auth.users")
(setf (pwd user) nil)
(set-session-object *authenticated-user-session-key* user))
|
