;; Copyright (c) 2024, SWGY, Inc. <ron@sw.gy>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;
(in-package :swtx)
(defparameter *CONF-UUID* "3b739e27-73dc-4e58-ba3e-4c5b9435caf8")
;;;;;;;;;;;;;;;;;
;; Utilities ;;
;;;;;;;;;;;;;;;;;
(defun get-from-db (db k)
"Return the value associated with the key, k."
(with-txn (:write nil)
(g3t db k)))
(defun get-db-stats ()
(let ((stats (make-hash-table))
(db-stats (lmdb:env-statistics))
(db-info (lmdb:env-info))
people-db-stats auth-db-stats interaction-db-stats)
(setf (gethash "db-page-size" stats) (getf db-stats :page-size))
(setf (gethash "db-depth" stats) (getf db-stats :depth))
(setf (gethash "db-branch-pages" stats) (getf db-stats :branch-pages))
(setf (gethash "db-leaf-pages" stats) (getf db-stats :leaf-pages))
(setf (gethash "db-overflow-pages" stats)
(getf db-stats :overflow-pages))
(setf (gethash "db-entries" stats) (getf db-stats :entries))
(setf (gethash "db-last-txn-id" stats) (getf db-info :last-txn-id))
(setf (gethash "db-max-readers" stats)
(getf db-info :maximum-readers))
(setf (gethash "db-num-readers" stats) (getf db-info :n-readers))
(setf (gethash "db-map-size" stats) (getf db-info :map-size))
(with-txn (:write nil)
(setf people-db-stats (lmdb:db-statistics *people-db*))
(setf auth-db-stats (lmdb:db-statistics *auth-db*))
(setf interaction-db-stats (lmdb:db-statistics *interactions-db*)))
(let ((people-hash (make-hash-table))
(auth-hash (make-hash-table))
(interaction-hash (make-hash-table)))
(setf (gethash "depth" people-hash) (getf people-db-stats :depth))
(setf (gethash "entries" people-hash)
(getf people-db-stats :entries))
(setf (gethash "people-db" stats) people-hash)
(setf (gethash "depth" auth-hash) (getf auth-db-stats :depth))
(setf (gethash "entries" auth-hash)
(getf auth-db-stats :entries))
(setf (gethash "auth-db" stats) auth-hash)
(setf (gethash "depth" interaction-hash)
(getf interaction-db-stats :depth))
(setf (gethash "entries" interaction-hash)
(getf interaction-db-stats :entries))
(setf (gethash "interaction-db" stats) interaction-hash)
stats)))
(defun list-associated-accounts (db &key email)
"Given an email address and a reference to the people-db, list all associated
accounts by providing their full keys."
(let (result)
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(loop initially
(lmdb:cursor-first c)
do (when (null (cursor-key c)) (return))
; Scan for every key matching '*\.email$'
; For each located result, check if value == email
; If value matches, add the key to the result set.
(let ((key (stringify (cursor-key c))))
(if (and (ppcre:scan "\\.email$" key)
(string= email (cursor-value c)))
(setf result (cons key result))))
(unless (lmdb:cursor-next c)
(return)))))
result
))
(defun load-interactions (db &key prefix)
"Load all interactions from the database matching the provided prefix."
(let (result)
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(when (lmdb:cursor-set-range prefix c)
(loop do (when (null (cursor-key c)) (return))
(unless (string-starts-with (stringify (cursor-key c)) prefix)
(return))
(setf result
(cons (make-interaction-from-key
(stringify (cursor-key c)))
result))
(unless (cursor-next c) (return))))
result))))
(defun load-from-db (db &key key-prefix id attributes alist-constructor)
"Load the challenge with the indicated challenge id from the auth database."
(when (looks-like-id-p id)
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(let ((entity-label (format nil "~A.~A" key-prefix id))
(located-attributes (make-hash-table)))
(multiple-value-bind (key _value found-p)
(cursor-set-range entity-label c)
(declare (ignore _value))
(when (and found-p (string-starts-with (stringify key) entity-label))
(loop while (string-starts-with (stringify key) entity-label)
do (let ((k (stringify (cursor-key c))))
(dolist (attribute attributes)
(when (equal (format nil "~A.~A" entity-label attribute) k)
(setf (gethash attribute located-attributes) (cursor-value c))))
; Sometimes there is no next entry
(unless (lmdb:cursor-next c) (return))))
(funcall alist-constructor
id (hash-to-alist located-attributes)))))))))
;;;;;;;;;;;;;;;;;;
;; Base Classes ;;
;;;;;;;;;;;;;;;;;;
(defclass swtx-entity ()
((conference-id :allocation :class :initform *CONF-UUID* :reader conference-id
:documentation
"The conference ID is a singular and immutable aspect of an instance of the
SwiggyTix system. Conference IDs are uniquely generated for each conference
using the SwiggyTix system.")
(id :initarg :id :reader id
:documentation
"The id for an instance must be unique among all instances of that type. It
is used as the unique part of the full key in the kv store.")
(key-prefix :allocation :class :reader key-prefix
:documentation
"The key-prefix provides a convenient and consistent way to ensure all keys
stored in the kv store have the same prefix among instances of the same class.")
(settable-attributes :allocation :class :reader settable-attributes
:documentation
"These attributes may be modified after originally being set. Any attribute not
explicitly mentioned by name in this list will be ignored in updates. "))
(:documentation
"SwiggyTix entities all derive from this base class.
The basic SwiggyTix entity is identified by an id and associated with a certain
conference by a conference id. Both of these attributes are immutable. An
entity should never fundamentally change its id and the nature of our
software makes conferences into distinct universes.
Implementing a new entity
-------------------------
1. Implement a construction function
For class 'foo', define make-foo to return a completely built instance.
This function should always take an id parameter followed by keyword args
for all of the required attributes.
2. Implement print object method
For class 'foo', define print-object ((f foo) stream). Use
print-unreadable object in the implementation.
3. Implement 'to-hash' :around method
For class 'foo', define method to-hash :around ((f foo)). Begin the method
with 'let ((generic-form (call-next-method)))', then use '(setf (gethash))'
calls to enhance the generic form. Finally, return the enhanced hash.
This to-hash method is used to serialize the entity for returning to the
client.
4. Implement 'to-kv-alist' method
For class 'foo', define method to-kv-alist ((f foo)). The keys of the alist
being built will be used as keys in the underlying kv store. As such, take
care to use heirarchical grouping from the left. See the 'person' impl for
an example.
5. For classes with settable attributes, implement 'to-alist' method.
This method should return an alist with keys that exactly match the
attribute name. The result will be filtered against the list of settable
attributes for the class, then 'apply'd to the construction function.
6. Implemet an alist constructor.
For class 'foo', define foo-from-alist taking two parameters, an id and
an alist of attributes and values.
"))
(defun make-swtx-entity (conf-id ent-id)
"Create a SwiggyTix entity with the provided conference-id and entity-id."
(make-instance 'swtx-entity :conference-id conf-id :id ent-id))
(defmethod print-object ((ent swtx-entity) stream)
(print-unreadable-object (ent stream :type (type-of ent) :identity t)
(format stream "conference-id: ~A, id: ~A"
(conference-id ent) (id ent))))
(defmethod to-hash ((ent swtx-entity))
"Given a SwiggyTix entity, serialize it into a simple map form. Derived
classes implement :around to add their information to the generated map."
(let ((m (make-hash-table)))
(setf (gethash "conference-id" m) (conference-id ent))
(setf (gethash "id" m) (id ent))
m))
(defmethod write-to-db (db (ent swtx-entity) &key (overwrite nil))
; Drop nils is critical here. The library dies while trying
; to request 128GB of ram if it find a nil value!
(format T "Writing ~A to db ~%" ent)
(let ((alist-repr (drop-nil-values (to-kv-alist ent))))
(with-txn (:write t)
(dolist (entry alist-repr)
(put db (car entry) (cdr entry) :overwrite overwrite)))))
(defclass person (swtx-entity)
((email :initarg :email :reader email)
(name :initarg :name :accessor name)
(phone-number :initarg :phone-number :accessor phone-number)
(mailing-address :initarg :mailing-address :accessor mailing-address)
(company :initarg :company :accessor company)
(title :initarg :title :accessor title)
(settable-attributes
:allocation :class :initform
(list "name" "phone-number" "mailing-address" "company" "title")))
(:documentation "Base class for person-type things.
In the universe of SwiggyTix, a person has an email address. They may also
have names, contact information, and company affiliations. Only the email
address is immutable, as this is used as a stand-in for user identity."))
(defmethod print-object ((p person) stream)
(print-unreadable-object (p stream :type (type-of p) :identity t)
(format stream "key-prefix: ~A, conference-id: ~A, id: ~A, email: ~A,\
name: ~A, phone-number: ~A, mailing-address: ~A, company: ~A, title: ~A"
(key-prefix p) (conference-id p) (id p)
(email p) (name p)
(phone-number p) (mailing-address p)
(company p) (title p))))
(defmethod to-hash :around ((p person))
"Given a person, serialize the instance into an alist ready for json."
(let ((generic-form (call-next-method)))
(setf (gethash "id" generic-form) (id p))
(setf (gethash "email" generic-form) (email p))
(setf (gethash "name" generic-form) (name p))
(setf (gethash "phone-number" generic-form) (phone-number p))
(setf (gethash "mailing-address" generic-form) (mailing-address p))
(setf (gethash "company" generic-form) (company p))
(setf (gethash "title" generic-form) (title p))
generic-form))
(defmethod to-alist ((p person))
"Given a person, return an alist with of instance attributes"
(with-accessors ((pre key-prefix)
(email email)
(name name)
(phone-number phone-number)
(mailing-address mailing-address)
(company company)
(title title)) p
`(("email" . ,email)
("name" . ,name)
("phone-number" . ,phone-number)
("mailing-address" . ,mailing-address)
("company" . ,company)
("title" . ,title))))
(defmethod to-kv-alist ((p person))
"Given a person, return an alist with keys and values for insertion
into the backing kv database.
For persons, this list is:
[prefix].[id].email
[prefix].[id].name
[prefix].[id].phone-number
[prefix].[id].mailing-address
[prefix].[id].company
[prefix].[id].title
"
(with-accessors ((pre key-prefix)
(id id)
(email email)
(name name)
(phone-number phone-number)
(mailing-address mailing-address)
(company company)
(title title)) p
`(
(,(format nil "~A.~A.email" pre id) . ,email)
(,(format nil "~A.~A.name" pre id) . ,name)
(,(format nil "~A.~A.phone-number" pre id) . ,phone-number)
(,(format nil "~A.~A.mailing-address" pre id) . ,mailing-address)
(,(format nil "~A.~A.company" pre id) . ,company)
(,(format nil "~A.~A.title" pre id) . ,title))))
(defun person-plist-from-alist (alist)
(let ((email (param-val "email" alist *max-email-length*))
(name (param-val "name" alist *max-full-name-length*))
(phone-number (param-val "phone-number" alist *max-phone-number-length*))
(mailing-address (param-val "mailing-address" alist *max-mailing-address-length*))
(company (param-val "company" alist *max-vendor-name-length*))
(title (param-val "title" alist *max-title-length*)))
(list :email email :name name :phone-number phone-number
:mailing-address mailing-address :company company
:title title)))
;;;;;;;;;;;;;;
;; Vendor ;;
;;;;;;;;;;;;;;
(defclass vendor (swtx-entity)
((email :initarg :email :accessor email)
(name :initarg :name :accessor name)
(website :initarg :website :accessor website)
(mailing-address :initarg :mailing-address :accessor mailing-address)
(key-prefix :initform "v" :allocation :class)
(settable-attributes
:allocation :class :initform
(list "name" "website" "mailing-address")))
(:documentation "A vendor attends a conference in order to present materials
to attendees. A vendor is a company that is staffed by vendor reps. A vendor
may contact event hosts to request lead data from attendees or vendor
interactions."))
(defmethod print-object ((v vendor) stream)
(print-unreadable-object (v stream :type (type-of v) :identity t)
(format stream "~A, ~A, ~A, ~A"
(name v) (email v) (website v) (mailing-address v))))
(defmethod to-hash :around ((v vendor))
"Given a person, serialize the instance into an alist ready for json."
(let ((generic-form (call-next-method)))
(setf (gethash "id" generic-form) (id v))
(setf (gethash "email" generic-form) (email v))
(setf (gethash "name" generic-form) (name v))
(setf (gethash "website" generic-form) (website v))
(setf (gethash "mailing-address" generic-form) (mailing-address v))
generic-form))
(defmethod to-alist ((v vendor))
(with-accessors ((id id) (name name) (email email) (website website)
(mailing-address mailing-address)) v
`(("email" . ,email)
("name" . ,name)
("website" . ,website)
("mailing-address" . ,mailing-address))))
(defmethod to-kv-alist ((v vendor))
"Given a vendor, return an alist suitable for writing to the kv db.
For vendors, this specifically includes keys:
v.[id].name
v.[id].email
v.[id].website
v.[id].mailing-address
"
(with-accessors ((id id) (name name) (email email) (website website)
(mailing-address mailing-address)) v
`((,(format nil "v.~A.email" id) . ,email)
(,(format nil "v.~A.name" id) . ,name)
(,(format nil "v.~A.website" id) . ,website)
(,(format nil "v.~A.mailing-address" id) . ,mailing-address))))
(defun make-vendor (id &key email name website mailing-address)
(validate-attribute-shape id #'looks-like-id-p)
(validate-attribute-length email *max-email-length*)
(validate-attribute-length name *max-vendor-name-length*)
(validate-attribute-length website *max-website-length*)
(validate-attribute-length mailing-address *max-mailing-address-length*)
(make-instance 'vendor
:id id :email email :name name :website website
:mailing-address mailing-address))
(defun vendor-from-alist (id alist)
(let ((email (param-val "email" alist *max-email-length*))
(name (param-val "name" alist *max-vendor-name-length*))
(website (param-val "website" alist *max-website-length*))
(mailing-address (param-val "mailing-address" alist *max-mailing-address-length*)))
(make-vendor id :email email :name name
:website website
:mailing-address mailing-address)))
(defun load-all-vendors (db)
"Given a people-db instance, load all vendor entries and return that list."
(let ((vendor-list nil)
(current-vendor nil))
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(multiple-value-bind (key _value found-p)
(cursor-set-range "v." c) ; Set the cursor to the vendor entries
(declare (ignore _value))
(loop while (and found-p (string-starts-with (stringify key) "v."))
do (let* ((id (extract-id-from-key "v." ; "v" for vendor
(stringify (cursor-key c))))
(key-prefix (format nil "v.~A." id)))
(setq current-vendor (load-vendor db id))
(when current-vendor
(setq vendor-list (cons current-vendor vendor-list)))
; Skip forward to the next vendor
(loop while (and
(lmdb:cursor-next c)
(string-starts-with
(stringify (cursor-key c)) key-prefix)))
(unless (lmdb:cursor-next c) (return)))))))
vendor-list))
(defun load-vendor (db id)
"Given a people-db instance and an associated id, return the located
vendor or nil if the id is not found."
(load-from-db db :key-prefix "v"
:id id :alist-constructor #'vendor-from-alist
:attributes '("email" "name" "website" "mailing-address")))
(defmethod update ((v vendor) update-list)
"Given an alist of property updates, update those properties that can
be changed and return a new updated instance."
(let* ((id (id v))
(existing-attributes (to-alist v))
(settables (settable-attributes v))
(updates (drop-unlisted-attributes update-list settables))
(vendor-properties
(alist-to-plist (append updates existing-attributes)
:use-keywords t)))
(apply #'make-vendor (cons id vendor-properties))))
;;;;;;;;;;
;; Host ;;
;;;;;;;;;;
(defclass host (person)
((key-prefix :allocation :class :initform "h"))
(:documentation "A host is associated with the conference and provides
admistrative functions for the event."))
(defun make-host (id &key email name phone-number
mailing-address company title)
(validate-attribute-length email *max-email-length*)
(validate-attribute-length name *max-full-name-length*)
(validate-attribute-length phone-number *max-phone-number-length*)
(validate-attribute-length mailing-address *max-mailing-address-length*)
(validate-attribute-length company *max-vendor-name-length*)
(validate-attribute-length title *max-title-length*)
(validate-attribute-shape id #'looks-like-id-p)
(make-instance 'host
:id id :email email :name name
:phone-number phone-number
:mailing-address mailing-address
:company company :title title))
(defun host-from-alist (id alist)
(let ((person-properties (person-plist-from-alist alist)))
(apply #'make-host (append (list id) person-properties))))
(defun load-host (db id)
"Given a people-db instance and an associated id, return the located
host or nil if the id is not found."
(load-from-db db :alist-constructor #'host-from-alist
:key-prefix "h" :id id
:attributes '("email" "name" "phone-number" "mailing-address"
"company" "title")))
(defun load-all-hosts (db)
"Given a people-db instance, load all host entries and return that list."
(let ((host-prefix "h.")
(host-list nil)
(current-host nil))
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(multiple-value-bind (key _value found-p)
(cursor-set-range host-prefix c) ; Set the cursor to the host entries
(declare (ignore _value))
(loop while (and found-p (string-starts-with (stringify key)
host-prefix))
do (let* ((id (extract-id-from-key
host-prefix (stringify (cursor-key c))))
(key-prefix (format nil "~A~A." host-prefix id)))
(setq current-host (load-host db id))
(when current-host
(setq host-list
(cons current-host host-list)))
; Skip forward to the next one
(loop while (and
(lmdb:cursor-next c)
(string-starts-with
(stringify (cursor-key c)) key-prefix)))
(unless (lmdb:cursor-next c) (return)))))))
host-list))
(defmethod update ((h host) update-list)
"Given an alist of property updates, update those properties that can
be changed and return a new updated instance."
(let* ((id (id h))
(existing-attributes (to-alist h))
(settables (settable-attributes h))
(updates (drop-unlisted-attributes update-list settables))
(person-properties (person-plist-from-alist (append updates existing-attributes))))
(apply #'make-host (cons id person-properties))))
;;;;;;;;;;;;;;
;; Attendee ;;
;;;;;;;;;;;;;;
(defclass attendee (person)
((key-prefix :allocation :class :initform "a"))
(:documentation "A person registered to attend a SwiggyTix event.
Attendees can participate in vendor interactions. Attendees are able to
administer their own writable attributes. They cannot delete themselves."))
(defun make-attendee (id &key email name phone-number
mailing-address company title)
(validate-attribute-length email *max-email-length*)
(validate-attribute-length name *max-full-name-length*)
(validate-attribute-length phone-number *max-phone-number-length*)
(validate-attribute-length mailing-address *max-mailing-address-length*)
(validate-attribute-length company *max-vendor-name-length*)
(validate-attribute-length title *max-title-length*)
(validate-attribute-shape id #'looks-like-id-p)
(make-instance 'attendee
:id id :email email :name name
:phone-number phone-number
:mailing-address mailing-address
:company company :title title))
(defun attendee-from-alist (id alist)
(let ((person-properties (person-plist-from-alist alist)))
(apply #'make-attendee (append (list id) person-properties))))
(defun load-attendee (db id)
"Given a people-db instance and an associated id, return the located
attendee or nil if the id is not found."
(load-from-db db :alist-constructor #'attendee-from-alist
:key-prefix "a" :id id
:attributes '("email" "name" "phone-number" "mailing-address"
"company" "title")))
(defun load-all-attendees (db)
"Given a people-db instance, load all attendee entries and return that list."
(let ((attendee-list nil)
(current-attendee nil))
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(multiple-value-bind (key _value found-p)
(cursor-set-range "a." c) ; Set the cursor to the attendee entries
(declare (ignore _value))
(loop while (and found-p (string-starts-with (stringify key) "a."))
do (let* ((id (extract-id-from-key "a."
(stringify (cursor-key c))))
(key-prefix (format nil "a.~A." id)))
(setq current-attendee (load-attendee db id))
(when current-attendee
(setq attendee-list
(cons current-attendee attendee-list)))
; Skip forward to the next one
(loop while (and
(lmdb:cursor-next c)
(string-starts-with
(stringify (cursor-key c)) key-prefix)))
(unless (lmdb:cursor-next c) (return)))))))
attendee-list))
(defmethod update ((a attendee) update-list)
"Given an alist of property updates, update those properties that can
be changed and return a new updated instance."
(let* ((id (id a))
(existing-attributes (to-alist a))
(settables (settable-attributes a))
(updates (drop-unlisted-attributes update-list settables))
(person-properties (person-plist-from-alist (append updates existing-attributes))))
(apply #'make-attendee (cons id person-properties))))
;;;;;;;;;;;;;;;;;;
;; Vendor Rep ;;
;;;;;;;;;;;;;;;;;;
(defclass vendor-rep (person)
((vendor-id :initarg :vendor-id :reader vendor-id)
(point-of-contact-p :initarg :point-of-contact-p :accessor point-of-contact-p
:documentation "T if this vendor rep is a
point-of-contact for their company.")
(key-prefix :allocation :class :initform "vr")
(settable-attributes
:allocation :class :initform
(list "name" "phone-number" "mailing-address" "company"
"title" "point-of-contact-p")))
(:documentation "A vendor-rep is a person associated with a vendor. The
vendor-rep will take part in vendor-interaction instances. Vendor-reps also
serve as the point of contact for a particular vendor."))
(defun make-rep (id &key vendor-id email name phone-number mailing-address
company title point-of-contact-p)
(validate-attribute-shape id #'looks-like-id-p)
(validate-attribute-shape vendor-id #'looks-like-id-p)
(validate-attribute-length email *max-email-length*)
(validate-attribute-length name *max-full-name-length*)
(validate-attribute-length phone-number *max-phone-number-length*)
(validate-attribute-length mailing-address *max-mailing-address-length*)
(validate-attribute-length company *max-vendor-name-length*)
(validate-attribute-length title *max-title-length*)
(validate-attribute-length point-of-contact-p 1)
(make-instance 'vendor-rep
:id id
:vendor-id vendor-id
:email email
:name name
:phone-number phone-number
:mailing-address mailing-address
:company company
:title title
:point-of-contact-p point-of-contact-p))
(defmethod to-alist :around ((vr vendor-rep))
(with-accessors ((vendor-id vendor-id)
(poc point-of-contact-p)) vr
(let ((person-result (call-next-method))
(vendor-rep-result `(("vendor-id" . ,vendor-id)
("point-of-contact-p" . ,poc))))
(append person-result vendor-rep-result))))
(defmethod to-kv-alist :around ((vr vendor-rep))
"Vendor reps are scoped within their associated vendor. As such, the keys
for a vendor are of the form:
v.[vendor-id].vr.[id].[name, email, etc]
"
(with-accessors ((id id) (vendor-id vendor-id)
(pre key-prefix) (poc point-of-contact-p)) vr
(let ((person-result (call-next-method))
(vendor-rep-result
`((,(format nil "~A.~A.vendor-id" pre id) . ,vendor-id)
(,(format nil "~A.~A.point-of-contact-p" pre id) . ,poc))))
(flet ((key-prefixer (entry)
(let ((old-key (car entry))
(v (cdr entry)))
; TODO: Swap hardcoded 'v' with the 'key-prefix' of the vendor class
; http://metamodular.com/CLOS-MOP/class-prototype.html
`(,(format nil "v.~A.~A" vendor-id old-key) . ,v))))
(mapcar #'key-prefixer (append person-result vendor-rep-result))))))
(defmethod to-hash :around ((r vendor-rep))
"Given a vendor rep, serialize the instance into an alist ready for json."
(let ((generic-form (call-next-method)))
(setf (gethash "vendor-id" generic-form) (vendor-id r))
(setf (gethash "point-of-contact-p" generic-form) (point-of-contact-p r))
generic-form))
(defmethod load-all-vendor-reps (db vendor-id)
"Given a people-db instance, load all vendor rep entries and return that list."
(let ((vendor-key-prefix (format nil "v.~A.vr." vendor-id))
(rep-list nil)
(current-rep nil))
(with-txn (:write nil)
(lmdb:with-cursor (c db)
(multiple-value-bind (_key _value found-p)
(cursor-set-range vendor-key-prefix c)
(declare (ignore _value _key))
(loop while (and found-p
(string-starts-with
(stringify (cursor-key c)) vendor-key-prefix))
do (let* ((id (extract-id-from-key vendor-key-prefix
(stringify (cursor-key c))))
(key-prefix (format nil
"~A~A." vendor-key-prefix id)))
(setq current-rep (load-rep db vendor-id id))
(when current-rep
(setq rep-list (cons current-rep rep-list)))
; Skip forward to the next vendor
(loop while (string-starts-with
(stringify (cursor-key c))
key-prefix)
do (cursor-next c)))
(unless (lmdb:cursor-next c) (return))
))))
rep-list))
(defun load-rep (db vendor-id rep-id)
"Given a people-db instance and an associated vendor-id and rep-id, return the
located vendor rep or nil if the id is not found."
(when (and (looks-like-id-p vendor-id) (looks-like-id-p rep-id))
(load-from-db db
:alist-constructor #'rep-from-alist
:key-prefix (format nil "v.~A.vr" vendor-id)
:id rep-id
:attributes '("email" "name" "phone-number"
"vendor-id" "mailing-address"
"company" "title" "point-of-contact-p"))))
(defun rep-from-alist (id alist)
(let ((person-properties (person-plist-from-alist alist))
(vendor-id (param-val "vendor-id" alist *max-id-length*))
(point-of-contact-p (param-val "point-of-contact-p" alist 1)))
(apply #'make-rep (append
(list id :vendor-id vendor-id
:point-of-contact-p point-of-contact-p)
person-properties))))
(defmethod update ((r vendor-rep) update-list)
"Given an alist of property updates, update those properties that can
be changed and return a new updated instance."
(let* ((id (id r))
(existing-attributes (to-alist r))
(settables (settable-attributes r))
(updates (drop-unlisted-attributes update-list settables))
(person-properties
(alist-to-plist (append updates existing-attributes)
:use-keywords t)))
(apply #'make-rep (cons id person-properties))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Vendor Rep Interactions ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass interaction ()
((key-prefix :allocation :class :initform "i")
(vendor-id :initarg :vendor-id :reader vendor-id
:documentation
"The id for the vendor to which the representative belongs.")
(rep-id :initarg :rep-id :reader rep-id
:documentation
"The id for the vendor representative that tok part in the interaction.")
(attendee-id :initarg :attendee-id :reader attendee-id
:documentation
"The id for the attendee that took part in the interaction.")
(ts :initarg :ts :reader ts
:documentation
"Universal timestamp indicating when the interaction occurred."))
(:documentation
"The interaction class represents an interaction between a vendor rep and an
attendee at a specific point in time."))
(defun make-interaction (&key vendor-id rep-id attendee-id ts)
"Create a new interaction instance."
(validate-attribute-shape vendor-id #'looks-like-id-p)
(validate-attribute-shape rep-id #'looks-like-id-p)
(validate-attribute-shape attendee-id #'looks-like-id-p)
(validate-attribute-shape ts #'looks-like-timestamp-p)
(make-instance 'interaction :vendor-id vendor-id
:rep-id rep-id :attendee-id attendee-id :ts ts))
(defun make-interaction-from-key (key)
"Given an lmdb key, build the associated interaction object. If the provided
key does not contain the required parts, or the provided IDs look off, nil is
returned."
; The key is of the form i.<vendor-id>.<rep-id>.<attendee-id>.<ts>
(let* ((parts (cl-ppcre:split "\\." key))
(key-prefix (first parts))
(vendor-id (second parts))
(rep-id (third parts))
(attendee-id (fourth parts))
(timestamp (fifth parts)))
(when (and (equal "i" key-prefix)
(looks-like-id-p vendor-id)
(looks-like-id-p rep-id)
(looks-like-id-p attendee-id)
(looks-like-timestamp-p timestamp))
(make-interaction :vendor-id vendor-id :rep-id rep-id
:attendee-id attendee-id :ts timestamp))))
(defmethod print-object ((i interaction) stream)
(print-unreadable-object (i stream :type (type-of i) :identity t)
(with-accessors ((vid vendor-id) (rid rep-id)
(aid attendee-id) (ts ts)) i
(format stream "vendor-id: ~A, rep-id: ~A, attendee-id: ~A, ts: ~A"
vid rid aid ts))))
(defmethod to-hash ((i interaction))
(let ((generic-form (make-hash-table)))
(setf (gethash "vendor-id" generic-form) (vendor-id i))
(setf (gethash "rep-id" generic-form) (rep-id i))
(setf (gethash "attendee-id" generic-form) (attendee-id i))
(setf (gethash "ts" generic-form) (ts i))
generic-form))
(defmethod to-key ((i interaction))
"The vendor interaction becomes a single row in the kv database of the form:
i.<vendor-id>.<rep-id>.<attendee-id>.<ts>"
(format nil "i.~A.~A.~A.~A"
(vendor-id i) (rep-id i) (attendee-id i) (ts i)))
(defmethod write-to-db (interaction-db (i interaction)
&key (overwrite nil))
"Write the provided interaction to the database."
(declare (ignore overwrite))
(with-txn (:write t)
(put interaction-db (to-key i) "t")))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Challenges ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass challenge (swtx-entity)
((valid-until :initarg :valid-until :reader valid-until
:documentation
"This challenge is only valid up to the timestamp indicated in this slot. Any
attempt to resolve the challenge after this timestamp will fail.")
(key-prefix :initform "c" :allocation :class)
(settable-attributes :initform nil :allocation :class)
(response-code :initarg :response-code :reader response-code
:documentation
"The response-code is used to successfully resolve the challenge. When a
challenge is created, the browser is sent back the created challenge id.
Separately, an email is sent out containing the response code. To resolve the
challenge, the browser later provides both the challenge ID and the response
code, proving access to the recipient email address.")
(path :initarg :path :reader path
:documentation
"The path attribute indicates the HTTP verb and URL path this challenge
is being used to authenticate. For example:
* 'GET /api/vendors/1695153040-1203/auth'
* 'PUT /api/attendees/1695153040-9284'
In order to perform the request indicated by the path attribute, the
challenge must be resolved successfully.")
(email :initarg :email :reader email
:documentation
"This attribute is the email address that is sent the response code. "))
(:documentation "The challenge class provides a means of authenticating users
before performing sensitive actions. The response code should never be sent
to the client, but instead emailed or sent via SMS."))
(defun make-challenge (id valid-until response-code path email)
"Make a new challenge instance with the provided values."
(make-instance 'challenge :id id :valid-until valid-until :path path
:response-code response-code :email email))
(defun challenge-from-alist (id alist)
(let ((valid-until (param-val "valid-until" alist *max-timestamp-length*))
(path (param-val "path" alist *max-path-length*))
(response-code (param-val "response-code" alist *max-response-code-length*))
(email (param-val "email" alist *max-email-length*)))
(make-challenge id valid-until response-code path email)))
(defmethod print-object ((c challenge) stream)
(print-unreadable-object (c stream :type (type-of c) :identity t)
(format stream "valid-until: ~A response-code: ~A path: ~A email: ~A"
(valid-until c) (response-code c) (path c) (email c))))
(defmethod to-hash :around ((c challenge))
"Hash the challenge. Omit the response code."
(let ((generic-form (call-next-method)))
(setf (gethash "valid-until" generic-form) (valid-until c))
(setf (gethash "email" generic-form) (email c))
(setf (gethash "path" generic-form) (path c))
generic-form))
(defmethod to-kv-alist ((c challenge))
"Given a challenge instance, return an alist with keys and values for
insertion into the backing kv database.
For challenges, this list is:
[prefix].[id].email
[prefix].[id].path
[prefix].[id].response-code
[prefix].[id].valid-until
"
(with-accessors ((pre key-prefix)
(id id)
(email email)
(path path)
(valid-until valid-until)
(response-code response-code)) c
`(
(,(format nil "~A.~A.email" pre id) . ,email)
(,(format nil "~A.~A.path" pre id) . ,path)
(,(format nil "~A.~A.response-code" pre id) .
,(format nil "~6,'0d" response-code))
(,(format nil "~A.~A.valid-until" pre id) .
,(format nil "~10,'0d" valid-until)))))
(defun dump-challenges (auth-db)
(with-txn (:write nil)
(lmdb:with-cursor (c auth-db)
(when (lmdb:cursor-first c)
(format T "~A ~A ~%" (stringify (cursor-key c)) (cursor-value c))
(loop while (lmdb:cursor-next c)
do (format T "~A ~A ~%"
(stringify (cursor-key c)) (cursor-value c)))))))
(defun get-challenge-count-for-email (auth-db email)
"Given an email address, return the number of challenges
associated with it."
(when email
(let ((total 0)
(si-label (format nil "ce.~A." email)))
(with-txn (:write nil)
(lmdb:with-cursor (c auth-db)
(multiple-value-bind (_key _value found-p)
(cursor-set-range si-label c)
(declare (ignore _key _value))
(when found-p
(loop while (string-starts-with
(stringify (cursor-key c))
si-label)
do (progn
(setf total (+ 1 total)))
(unless (cursor-next c) (return)))
))))
total)))
(defmethod write-to-db :after (db (c challenge) &key (overwrite nil))
"After writing the challenge to the db, add an entry to the secondary index"
(declare (ignore overwrite))
(let ((challenge-id (id c))
(email (email c)))
(with-txn (:write t)
(put db (format nil "ce.~A.~A" email challenge-id) "hi"))))
(defun delete-expired-challenges (auth-db universal-time)
"Given the auth db and a universal time, delete all challenge records
that are expired prior to the universal time."
(with-txn (:write t)
(lmdb:with-cursor (c auth-db)
(when (lmdb:cursor-first c)
(loop while (cursor-key c)
do (progn
(let ((key (stringify (cursor-key c)))
email)
(cond ((string-starts-with key "c.")
; Extract the challenge key
(let* ((challenge-id (extract-id-from-key "c." key))
; Build the 'valid-until' key
(valid-until-k
(format nil "c.~A.valid-until" challenge-id))
; Pull the valid until key
(valid-until
(lmdb:cursor-set-key valid-until-k c))
(email-k
(format nil "c.~A.email" challenge-id))
(path-k
(format nil "c.~A.path" challenge-id))
(response-code-k
(format nil "c.~A.response-code" challenge-id))
)
; Check against provided universal time
; if expired
(cond ((and valid-until
(< (parse-integer valid-until)
universal-time))
; build and delete all sub-keys
; email, path, response-code, valid-until
;
(when (lmdb:cursor-set-key email-k c)
(setf email (lmdb:cursor-value c))
(lmdb:cursor-del c))
; Delete entry in secondary index
(when (and email
(lmdb:cursor-set-key
(format nil "ce.~A.~A"
email challenge-id) c))
(lmdb:cursor-del c))
(when (lmdb:cursor-set-key path-k c)
(lmdb:cursor-del c))
(when (lmdb:cursor-set-key response-code-k c)
(lmdb:cursor-del c))
(when (lmdb:cursor-set-key valid-until-k c)
(lmdb:cursor-del c))
; Send the cursor back to first
(lmdb:cursor-first c))
(t (unless (cursor-next) (return)))
)))
(t (unless (cursor-next c) (return)))))))))))
(defun delete-challenge (auth-db id)
"Delete the challenge with the associated ID. Also updates the 'ce'
secondary index to remove references to this challenge."
(when (looks-like-id-p id)
(with-txn (:write T)
(lmdb:with-cursor (c auth-db)
(let ((challenge-label (format nil "c.~A" id))
(challenge-email-label (format nil "c.~A.email" id))
email)
(multiple-value-bind (_key _value found-p)
(cursor-set-range challenge-label c)
(declare (ignore _key _value))
(when (and found-p (string-starts-with (stringify (cursor-key c))
challenge-label))
(loop while (string-starts-with (stringify (cursor-key c))
challenge-label)
do (progn
(when (equal (stringify (cursor-key c))
challenge-email-label)
; Store the email when it's discovered
(setf email (cursor-value c)))
(lmdb:cursor-del c)
(unless (lmdb:cursor-next c) (return)))))
(when email ; If an email was set, delete the secondary index
(lmdb:cursor-set-key (format nil "ce.~A.~A" email id) c)
(lmdb:cursor-del c))))))))
(defun delete-all-challenges (auth-db)
"Clear the challenges database"
(with-txn (:write T)
(lmdb:with-cursor (c auth-db)
(when (lmdb:cursor-first c)
(loop while t
do (progn
(lmdb:cursor-del c)
(unless (lmdb:cursor-next c) (return))))))))
(defun load-challenge (auth-db id)
"Load the challenge with the indicated challenge id from the auth database."
(when (looks-like-id-p id)
(load-from-db auth-db :alist-constructor #'challenge-from-alist
:attributes '("email" "path" "valid-until" "response-code")
:id id :key-prefix "c")))