;; 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 *max-auth-header-length* 512)
(defparameter *max-email-length* 78)
(defparameter *max-full-name-length* 64)
(defparameter *max-id-length* 8)
(defparameter *max-mailing-address-length* 256)
(defparameter *max-path-length* 80)
(defparameter *max-phone-number-length* 20)
(defparameter *max-response-code-length* 6)
(defparameter *max-timestamp-length* 13)
(defparameter *max-title-length* 64)
(defparameter *max-vendor-name-length* 64)
(defparameter *max-website-length* 128)
(defparameter *min-email-length* 5) ; a@b.c
(defparameter *id-shape-regex* "[A-Z0-9]{4}-[A-Z0-9]{3}"
"Matches SwiggyTix IDs.")
(defun get-secrets-path ()
(if (equal (uiop:getenv "USER") "swtx")
(uiop:merge-pathnames* "secrets/" (sb-unix:user-homedir "swtx"))
(uiop:merge-pathnames* "../secrets/" (osicat:current-directory))))
(defun read-secret (key default-value)
(let* ((secrets-path (get-secrets-path))
(value (uiop:read-file-string
(uiop:merge-pathnames* key secrets-path))))
(if (and value (not (string= value "")))
(string-trim '(#\Space #\Tab #\Newline) value)
default-value)))
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun hash-to-alist (hash)
"Given a hashtable, return an association list."
(let ((result '()))
(maphash (lambda (k v) (push (cons k v) result)) hash)
result))
(defun alist-to-plist (alist &key (use-keywords nil))
"Converts an alist to a plist.
If use-keywords is non-nil, it will convert keys to keyword symbols."
(let ((plist '()))
(dolist (pair alist plist)
(let ((key (car pair))
(value (cdr pair)))
(push (if use-keywords
(intern (string-upcase key) :keyword)
key)
plist)
(push value plist)))
(nreverse plist)))
(defun string-replace (old new string)
(with-output-to-string (out)
(loop with old-len = (length old)
for start = 0 then (+ pos old-len)
for pos = (search old string :start2 start)
do (write-string string out :start start :end (or pos (length string)))
when pos do (write-string new out)
while pos)))
(defun stringify (bytes)
"Given a string of bytes representing a K in LMDB, drop the last
byte and return the string representation"
(map 'string #'code-char (subseq bytes 0 (1- (length bytes)))))
(defun string-starts-with (str prefix)
"T if str begins with prefix."
(cond
((= 0 (length prefix)) T)
((= 0 (length str)) nil)
(T
(and (eq (aref str 0) (aref prefix 0))
(string-starts-with
(subseq str 1)
(subseq prefix 1))))))
(defun drop-nil-values (alist)
(remove-if #'null alist :key #'cdr))
(defun drop-unlisted-attributes (alist settable-keys)
"Return the provided alist after having removed any entries without
a key in the unsettable keys list."
(flet ((filter (entry)
(member (car entry) settable-keys :test #'equal)))
(remove-if-not #'filter alist)))
(defun header-val (key request-headers max-length)
"Retrieve the value associated with 'key' from the provided
request-headers hash, clamped to the indicated max-length."
(let ((original-value (gethash key request-headers)))
(when (and original-value (typep original-value 'string))
(subseq original-value 0 (min max-length (length original-value))))))
(defun param-val (key alist max-length)
"Retrieve the value associated with key from alist and clamp the
string value to the indicated max-length."
(let ((original-value (cdr (assoc key alist :test #'equal))))
(when (and original-value (typep original-value 'string))
(subseq original-value 0 (min max-length (length original-value))))))
(defun looks-like-id-p (str)
"Returns T if the str appears to be a valid SwiggyTix entity id."
; Keep this in line with generate-id
(cl-ppcre:scan (format nil "^~A$" *id-shape-regex*) str))
(defun looks-like-timestamp-p (str)
"Returns T if the provided string starts with '3' or '4' followed by 9 digits.
universal timestamps starting with 3 will last until Fall of 2026. Timestamps
starting with 4 will last another ~31 years."
(cl-ppcre:scan "^[34]\\d{9}$" str))
(defmacro validation (attribute func msg)
"Throw a bad-attribute-value-error if (apply func attribute) returns nil,
include the provided msg in the error. Msg should contain a single format
marker to print the name of the provided attribute."
(let ((attribute-name-sym (gensym "attribute-name")))
`(unless (funcall ,func ,attribute)
(let ((,attribute-name-sym (mkstr (quote ,attribute))))
(error 'bad-attribute-value-error
:attribute-name ,attribute-name-sym
:details (format nil ,msg ,attribute-name-sym))))))
(defmacro validate-attribute-length (attribute max-length)
"Throw a bad-attribute-value error if attribute exceeds indicated length."
`(validation ,attribute
#'(lambda (x) (<= (length x) ,max-length))
"Provided ~A was too long."))
(defmacro validate-attribute-shape (attribute func)
"Throw a bad-attribute-value error if the provided func returns nil when
called with the provided attribute."
`(validation ,attribute ,func "Provided ~A was malformed."))
(defun account-type-from-key (key)
"Given a key, return the type of account associated with it.
Results may be symbols for 'HOST, 'ATTENDEE, 'VENDOR, 'REP, or nil"
(cond
((ppcre:scan (format nil "^h\\.~A\\." *id-shape-regex*) key) 'HOST)
((ppcre:scan (format nil "^a\\.~A\\." *id-shape-regex*) key) 'ATTENDEE)
((ppcre:scan (format nil "^v\\.~A\\.vr\\.~A\\."
*id-shape-regex* *id-shape-regex*) key) 'REP)
((ppcre:scan (format nil "^v\\.~A\\." *id-shape-regex*) key) 'VENDOR)
(T NIL)))
(defun extract-id-from-key (key-prefix key)
"Given a key prefix such as 'v.', 'vr.', 'a.'; extract the id from the
provided key or nil otherwise."
(multiple-value-bind (start-idx end-idx)
(cl-ppcre:scan (format nil "^~A~A\." key-prefix *id-shape-regex*) key)
; TODO Use capture groups
(when start-idx
(let ((id-part (subseq key (- (length key-prefix) 1) end-idx)))
(multiple-value-bind (id-start id-end)
(cl-ppcre:scan *id-shape-regex* id-part)
(subseq id-part id-start id-end))))))
(defvar *base-31-characters*
; 0-9, alphabet without vowels
(concatenate 'string "0123456789" "BCDFGHJKLMNPQRSTVWXYZ"))
(defun encode-base-31 (n)
"Given an integer, n, return a string representing its base 31 representation.
Base 31 here encodes digits using 0-9 and the letters:
B C D F G H J K L M N P Q R S T V W X Y Z.
For instance:
the decimal 10 would be encoded as B, 11 as C, 12 as D, 13 as F, and so on."
(if (zerop n)
"0"
(let ((result ""))
(loop while (plusp n) do
(setf result (concatenate 'string
(string (aref *base-31-characters*
(mod n 31)))
result))
(setf n (floor n 31)))
result)))
(defun decode-base-31 (s)
"Given a base-31 string, s, return the encoded integer value.
Base 31 here encodes digits using 0-9 and the letters:
B C D F G H J K L M N P Q R S T V W X Y Z.
For instance:
the decimal 10 would be encoded as B, 11 as C, 12 as D, 13 as F, and so on.
This function will throw a type-error if the provided string is not
a base 31 string."
(let ((result 0))
(loop for ch across s do
(setf result (+ (* result 31)
(position ch *base-31-characters*))))
result))
(defvar *swtx-epoch* (encode-universal-time 0 0 0 1 10 2023))
(defparameter *id-counter* 0)
(defun generate-id ()
(incf *id-counter*)
(let ((5-minute-increment
(truncate (- (get-universal-time) *swtx-epoch*) 300)))
(format nil "~4,,,'0@A-~3,,,'0@A"
(encode-base-31 5-minute-increment)
(encode-base-31 *id-counter*))))