89 lines
3.3 KiB
Common Lisp
89 lines
3.3 KiB
Common Lisp
(in-package :cl-matrix)
|
|
|
|
(defmethod insert (dao-model)
|
|
(postmodern:with-connection cl-matrix-config:+database+
|
|
(postmodern:insert-dao dao-model)))
|
|
|
|
;; USER
|
|
|
|
(defclass user ()
|
|
((id :col-type string :initarg :id :reader id)
|
|
(password-hash :col-type string :initarg :password-hash :accessor password-hash))
|
|
(:metaclass postmodern:dao-class)
|
|
(:keys id)
|
|
(:table-name users))
|
|
|
|
(defun get-id (identity)
|
|
(cl-matrix::log-info (intern (getf identity :type "")))
|
|
(case (alex:make-keyword (getf identity :type ""))
|
|
(:|m.id.user| (getf identity :user))))
|
|
|
|
(defun get-user (identity)
|
|
(destructuring-bind (&key type &allow-other-keys) identity
|
|
(alex:switch (type :test 'string-equal)
|
|
("m.id.user" (get-user-by-user identity))
|
|
("m.id.thirdparty" (get-user-by-thirdparty identity))
|
|
("m.id.phone" (get-user-by-phone identity))
|
|
(otherwise (error 'unknown-error
|
|
:msg (format nil "~a is not a valid identity type" type))))))
|
|
|
|
(defun get-user-by-user (identity)
|
|
(postmodern:with-connection cl-matrix-config:+database+
|
|
(destructuring-bind (&key user &allow-other-keys) identity
|
|
(postmodern:get-dao 'user (coerce-user-id user)))))
|
|
|
|
(defun get-user-by-thirdparty (identity)
|
|
(error 'unknown-error :msg "unimplemented identity type"))
|
|
|
|
(defun get-user-by-phone (identity)
|
|
(error 'unknown-error :msg "unimplemented identity type"))
|
|
|
|
(defparameter *user-id-scanner*
|
|
(ppcre:create-scanner "^@[a-z\\d.=_\/+-]+:((?:(?:\\d{1,3}\.\\d{1,3}\.\\d{1,3}\.\\d{1,3})|(?:\[[a-fA-F\\d:.]{2,45}\])|(?:[a-zA-Z\\d.-]{1,255}))(?::\\d{1,5})?)$"))
|
|
|
|
(defparameter *user-localpart-scanner*
|
|
(ppcre:create-scanner "^[a-z\\d.=_\/+-]+$"))
|
|
|
|
(defun coerce-user-id (name)
|
|
(multiple-value-bind (match server-name) (ppcre:scan-to-strings *user-id-scanner* name)
|
|
(if match
|
|
(if (string-equal cl-matrix-config:+server-name+ (aref server-name 0))
|
|
name
|
|
(error 'unknown-error :msg "user id server name is not valid"))
|
|
(if (ppcre:scan *user-localpart-scanner* name)
|
|
(format nil "@~a:~a" name cl-matrix-config:+server-name+)
|
|
(error 'unknown-error :msg "user id localpart is not valid")))))
|
|
|
|
(defun make-user (id password-hash)
|
|
(make-instance 'user :id id :password-hash password-hash))
|
|
|
|
;; DEVICE
|
|
|
|
(defclass device ()
|
|
((user-id :col-type string :col-references ((user id)) :initarg :user-id :reader user-id)
|
|
(id :col-type string :initarg :id :accessor id)
|
|
(access-token :col-type string :initarg access-token :accessor access-token)
|
|
(refresh-token :col-type string :initarg refresh-token :accessor refresh-token))
|
|
(:metaclass postmodern:dao-class)
|
|
(:keys access-token)
|
|
(:table-name devices))
|
|
|
|
(defun get-device (access-token)
|
|
(postmodern:with-connection cl-matrix-config:+database+
|
|
(postmodern:get-dao 'device access-token)))
|
|
|
|
;; UTILS
|
|
|
|
(defun create-tables ()
|
|
(postmodern:with-connection cl-matrix-config:+database+
|
|
(postmodern:execute (postmodern:dao-table-definition 'user))
|
|
(postmodern:execute (postmodern:dao-table-definition 'device))))
|
|
|
|
(defun drop-tables ()
|
|
(postmodern:with-connection cl-matrix-config:+database+
|
|
(postmodern:execute "DROP TABLE users;")
|
|
(postmodern:execute "DROP TABLE devices;")))
|
|
|
|
(defun seed ()
|
|
(let ((harry-dubois (make-user (coerce-user-id "harry") (cl-matrix::generate-hash-with-salt "martinaise"))))
|
|
(insert harry-dubois)))
|