From 4850f6fec7a6df5d869432774407a20d1ada911a Mon Sep 17 00:00:00 2001 From: dominik martinez Date: Sat, 1 Mar 2025 19:07:17 -0800 Subject: [PATCH] first commit. welcome home. --- .gitignore | 9 +++++ README | 9 +++++ cl-matrix.asd | 40 ++++++++++++++++++++++ settings.lisp | 6 ++++ src/auth.lisp | 88 ++++++++++++++++++++++++++++++++++++++++++++++++ src/db.lisp | 46 +++++++++++++++++++++++++ src/json.lisp | 44 ++++++++++++++++++++++++ src/logging.lisp | 4 +++ src/main.lisp | 23 +++++++++++++ src/matrix.lisp | 70 ++++++++++++++++++++++++++++++++++++++ src/models.lisp | 9 +++++ src/package.lisp | 7 ++++ src/routes.lisp | 80 +++++++++++++++++++++++++++++++++++++++++++ tests/main.lisp | 11 ++++++ 14 files changed, 446 insertions(+) create mode 100644 .gitignore create mode 100644 README create mode 100644 cl-matrix.asd create mode 100644 settings.lisp create mode 100644 src/auth.lisp create mode 100644 src/db.lisp create mode 100644 src/json.lisp create mode 100644 src/logging.lisp create mode 100644 src/main.lisp create mode 100644 src/matrix.lisp create mode 100644 src/models.lisp create mode 100644 src/package.lisp create mode 100644 src/routes.lisp create mode 100644 tests/main.lisp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b9fa3c1 --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +*.abcl +*.fasl +*.dx32fsl +*.dx64fsl +*.lx32fsl +*.lx64fsl +*.x86f +*~ +.#* diff --git a/README b/README new file mode 100644 index 0000000..7aa75d2 --- /dev/null +++ b/README @@ -0,0 +1,9 @@ +# cl-matrix + +## Usage + +## Installation + +## License + +Licensed under the GPL-3.0-or-later License. diff --git a/cl-matrix.asd b/cl-matrix.asd new file mode 100644 index 0000000..4729b65 --- /dev/null +++ b/cl-matrix.asd @@ -0,0 +1,40 @@ +(asdf:defsystem "cl-matrix" + :version "0.0.1" + :author "Dominik Martinez" + :maintainer "Dominik Martinez" + :mailto "dominikmartinez@pm.me" + :license "GPL-3.0-or-later" + :depends-on ("woo" + "clack" + "snooze" + "com.inuoe.jzon" + "local-time" + "alexandria" + "cl-ppcre" + "postmodern" + "ironclad" + "flexi-streams" + "frugal-uuid") + :components ((:file "settings") + (:module "src" + :components + ((:file "package") + (:file "logging") + (:file "db") + (:file "auth") + (:file "matrix") + (:file "routes") + (:file "main")))) + :description "A Matrix server written in Common Lisp." + :in-order-to ((asdf:test-op (asdf:test-op "cl-matrix/tests")))) + +(asdf:defsystem "cl-matrix/tests" + :author "Dominik Martinez" + :license "GPL-3.0-or-later" + :depends-on ("cl-matrix" + "rove") + :components ((:module "tests" + :components + ((:file "main")))) + :description "Test system for cl-matrix" + :perform (asdf:test-op (op c) (symbol-call :rove :run c))) diff --git a/settings.lisp b/settings.lisp new file mode 100644 index 0000000..7708ed2 --- /dev/null +++ b/settings.lisp @@ -0,0 +1,6 @@ +(defpackage cl-matrix-config + (:use #:cl) + (:export :+database+)) +(in-package :cl-matrix-config) + +(defvar +database+ '("cl_matrix_dev" "cl_matrix_dev" "cl_matrix_dev" "localhost")) diff --git a/src/auth.lisp b/src/auth.lisp new file mode 100644 index 0000000..51723f5 --- /dev/null +++ b/src/auth.lisp @@ -0,0 +1,88 @@ +(in-package :cl-matrix) + +;; PASSWORD HASHING + +(defun generate-hash (passphrase salt) + "Where PASSPHRASE is a string and SALT is a unsigned byte array or string, returns an unsigned byte array" + (let* ((salt (if (typep salt '(simple-array (unsigned-byte 8) (*))) + salt + (ironclad:hex-string-to-byte-array salt))) + (kdf (ironclad:make-kdf :argon2id :block-count 19456)) + (passphrase-bytes (flexi-streams:string-to-octets passphrase :external-format :utf-8)) + (hash (ironclad:derive-key kdf passphrase-bytes salt 2 16))) + hash)) + +(defun generate-hash-with-salt (passphrase) + "Where PASSPHRASE is a string, returns a string ':'" + (let* ((salt (ironclad:make-random-salt)) + (hash (generate-hash passphrase salt))) + (format nil "~a:~a" + (ironclad:byte-array-to-hex-string hash) + (ironclad:byte-array-to-hex-string salt)))) + +(defun check-password (to-check passphrase-hash-and-salt-string) + (let* ((split-passphrase-hash-and-salt (uiop:split-string + passphrase-hash-and-salt-string :separator ":")) + (passphrase-hash (first split-passphrase-hash-and-salt)) + (passphrase-salt (second split-passphrase-hash-and-salt)) + (to-check-hash (ironclad:byte-array-to-hex-string (generate-hash to-check passphrase-salt)))) + (equal to-check-hash passphrase-hash))) + +(defvar *auth-sessions* (make-hash-table :test 'equal)) + +(defclass auth-session () + ((stages :initarg :stages :accessor stages) + (completed :initform '() :accessor completed) + (params :initarg :params :initform '() :accessor params) + (session-id :initform (frugal-uuid:to-string (frugal-uuid:make-v4)) :reader session-id))) + +(defmethod auth-session-plist ((auth-session auth-session)) + (let ((plist (list :flows `(:stages ,(stages auth-session)) + :params (params auth-session) + :session (session-id auth-session)))) + (when (completed auth-session) + (push (completed auth-session) plist) + (push :completed plist)) + plist)) + +(defclass password-auth-session (auth-session) + ((stages :initform (list (make-instance 'password-auth-stage))))) + +(defclass auth-stage () + ((type :reader auth-stage-type))) + +(defclass password-auth-stage (auth-stage) + ((type :initform "m.login.password."))) + +(defgeneric process-input (auth-stage input)) + +(defmethod process-input ((auth-stage password-auth-stage) input)) + +(defun get-user-from-access-token (access-token) + (let ((device (get-device access-token))) + (if device + (get-user (user-id device))))) + +(defmacro with-authentication (input-var &body body) + `(let* ((access-token (matrix-input-access-token ,input-var)) + (user (if access-token (get-user-from-access-token access-token)))) + (setf (matrix-input-user ,input-var)) + (if user + (progn + ,@body) + (handle-auth-session)))) + +(defun get-auth-params (matrix-input) + (getf (matrix-input-json-body matrix-input) :auth)) + +(defun handle-auth-session (matrix-input) + (if (get-auth-params matrix-input) + (continue-auth-session matrix-input) + (start-auth-session matrix-input))) + +(defun start-auth-session (matrix-input) + (let ((auth-session (make-instance 'password-auth-session))) + (setf (gethash (session-id auth-session) *auth-sessions*) auth-session) + (json-response 401 (auth-session-plist auth-session)))) + + diff --git a/src/db.lisp b/src/db.lisp new file mode 100644 index 0000000..e64dc81 --- /dev/null +++ b/src/db.lisp @@ -0,0 +1,46 @@ +(in-package :cl-matrix) + +(defmethod insert (dao-model) + (postmodern:with-connection cl-matrix-config:+database+ + (postmodern:insert-dao dao-model))) + +(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-user (id) + (postmodern:with-connection cl-matrix-config:+database+ + (postmodern:get-dao 'user id))) + +(defun make-user (id password-hash) + (make-instance 'user :id id :password-hash password-hash)) + +(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))) + +(defun db-create-tables () + (postmodern:with-connection cl-matrix-config:+database+ + (postmodern:execute (postmodern:dao-table-definition 'user)) + (postmodern:execute (postmodern:dao-table-definition 'device)))) + +(defun db-drop-tables () + (postmodern:with-connection cl-matrix-config:+database+ + (postmodern:execute "DROP TABLE users;") + (postmodern:execute "DROP TABLE devices;"))) + +(defun db-seed () + (let ((harry-dubois (make-user "@harry:rcm.org" (generate-hash-with-salt "martinaise")))) + (insert harry-dubois))) diff --git a/src/json.lisp b/src/json.lisp new file mode 100644 index 0000000..b4d8e09 --- /dev/null +++ b/src/json.lisp @@ -0,0 +1,44 @@ +(in-package :cl-matrix) + +(defun plist-json (plist) + (jzon:stringify (plist-hash-table-recurse plist))) + +(defun plist-p (l) + (and (listp l) (evenp (length l)) (keywordp (first l)))) + +(defun plist-hash-table-recurse (element) + (cond + ( + (plist-p element) + (let (result) + (alex:doplist (key val element result) + (push (plist-hash-table-recurse val) result) + (push key result)) + (alex:plist-hash-table result))) + ( + (listp element) + (mapcar 'plist-hash-table-recurse element)) + (t element))) + + +(defun hash-table-plist-recurse (element) + (cond + ( + (hash-table-p element) + (let ((result)) + (maphash (lambda (key val) + (push (hash-table-plist-recurse val) result) + (push (alex:make-keyword (string-upcase key)) result)) + element) + result)) + ( + (and (vectorp element) (not (stringp element))) + (map 'list 'hash-table-plist-recurse element)) + (t element))) + +(defun json-plist (json) + (let ((parsed (handler-case + (jzon:parse json) + (error () + (error 'not-json-error))))) + (hash-table-plist-recurse parsed))) diff --git a/src/logging.lisp b/src/logging.lisp new file mode 100644 index 0000000..4090786 --- /dev/null +++ b/src/logging.lisp @@ -0,0 +1,4 @@ +(in-package :cl-matrix) + +(defun log-info (msg) + (format t "[~a] ~a~%" (local-time:now) msg)) diff --git a/src/main.lisp b/src/main.lisp new file mode 100644 index 0000000..0549569 --- /dev/null +++ b/src/main.lisp @@ -0,0 +1,23 @@ +(in-package #:cl-matrix) + +(defparameter *running-server* nil) + +(defun server-start () + (if *running-server* + (log-info "server already running") + (progn + (setq *running-server* + (clack:clackup 'router :server :woo)) + (log-info "server started")))) + +(defun server-stop () + (if *running-server* + (progn + (clack:stop *running-server*) + (log-info "server shutdown")) + (log-info "no running server to shutdown")) + (setq *running-server* nil)) + +(defun server-restart () + (server-stop) + (server-start)) diff --git a/src/matrix.lisp b/src/matrix.lisp new file mode 100644 index 0000000..85efb4c --- /dev/null +++ b/src/matrix.lisp @@ -0,0 +1,70 @@ +(in-package :cl-matrix) + +(defstruct matrix-input + path-args + access-token + json-body + user) + +(define-condition matrix-error (error) + ((errcode :reader errcode) + (msg :initarg :msg :initform "" :reader msg))) + +(defmacro make-matrix-errors (&rest names) + (loop for name-maybe in names + for name = (string name-maybe) + for snake = (loop for ch across name + with result = (copy-seq name) + for i upfrom 0 + do (if (eql ch #\-) (setf (aref result i) #\_)) + finally (return result)) + collecting `(define-condition ,(intern (format nil "~a-ERROR" (string-upcase name))) (matrix-error) + ((errcode :initform ,(format nil "M_~a" snake)))) + into defines + finally (return (append '(progn) defines)))) + +(make-matrix-errors + forbidden + unknown-token + missing-token + user-locked + user-suspended + bad-json + not-json + not-found + limit-exceeded + unrecognized + unknown + unauthorized + user-deactivated + user-in-user + invalid-username + room-in-use + invalid-room-state + threepid-in-use + threepid-not-found + threepid-auth-failed + threepid-denied + server-not-trusted + unsupported-room-version + incompatible-room-version + bad-state + guest-access-forbidden + captcha-needed + captcha-invalid + missing-param + invalid-param + too-large + exclusive + resource-limit-exceeded + cannot-leave-server-notice-room + threepid-medium-not-supported + threepid-in-use) + +(defun versions (input) + (json-response 200 '(:versions ("v1.1" "v1.2" "v1.3" "v1.4" "v1.5" "v1.6" "v1.7" "v1.8" "v1.9" "v1.10" "v1.11" "v1.12" "v1.13")))) + +(defun get-logins (input) + (log-info input)) + + diff --git a/src/models.lisp b/src/models.lisp new file mode 100644 index 0000000..f8d4143 --- /dev/null +++ b/src/models.lisp @@ -0,0 +1,9 @@ +(in-package :cl-matrix) + +(defclass user () + ((id :col-type string :initarg :id :accessor id) + (password-hash :col-type string :initarg :password-hash :accessor password-hash)) + (:metaclass postmodern:dao-class) + (:keys id)) + + diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..dcc8fd0 --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,7 @@ +(defpackage cl-matrix-db + (:use #:cl)) + +(defpackage cl-matrix + (:use #:cl) + (:local-nicknames (:jzon :com.inuoe.jzon) + (:alex :alexandria))) diff --git a/src/routes.lisp b/src/routes.lisp new file mode 100644 index 0000000..e945f02 --- /dev/null +++ b/src/routes.lisp @@ -0,0 +1,80 @@ +(in-package :cl-matrix) + +(defun get-access-token-from-params (params-alist) + (cdr (assoc "access_token" params-alist :test 'equal))) + +(defun get-access-token-from-header (header) + (when header + (aref (nth-value 1 (ppcre:scan-to-strings "^Bearer (.+)$" header)) 0))) + +(defun get-access-token (env) + (destructuring-bind (&key headers query-string &allow-other-keys) env + (let* ((auth-token-header (get-access-token-from-header (gethash "Authorization" headers))) + (auth-token-params (get-access-token-from-params (if query-string (quri:url-decode-params query-string))))) + (or auth-token-header auth-token-params)))) + +(defun received-method-p (method) + (or (eql method :post) + (eql method :put))) + +(defun initialize-matrix-input (path-args env) + (destructuring-bind (&key raw-body method &allow-other-keys) env + (make-matrix-input + :path-args path-args + :access-token (get-access-token env) + :json-body (if (received-method-p method) (json-plist raw-body) nil)))) + +(defvar +matrix-headers+ + '(:access-control-allow-origin "*" + :access-control-allow-methods "GET, POST, PUT, DELETE, OPTIONS" + :access-control-allow-headers "X-Requested-With, Content-Type, Authorization")) + +(defun json-response (code plist &optional headers) + `(,code ,(append '(:content-type "application/json") headers +matrix-headers+) (,(plist-json plist)))) + +(defgeneric handle-condition (condition)) + +(defmethod handle-condition (condition) + (json-response 500 `(:error ,(format nil "~a" condition)))) + +(defmethod handle-condition ((err matrix-error)) + (json-response 400 `(:errcode ,(errcode err) :error ,(msg err)))) + +(define-condition route-not-found (error) ()) + +(defmethod handle-condition ((err route-not-found)) + (json-response 404 nil)) + +(defun wrap-url-match (url-pattern handler) + (lambda (env) + (let ((matches (nth-value 1 (ppcre:scan-to-strings url-pattern (getf env :path-info))))) + (if matches + (apply handler env (coerce matches 'list)))))) + +(defparameter *routes* nil) + +(defmacro defroute (method url-pattern handler) + `(push + (wrap-url-match ,url-pattern + (lambda (env &rest rest) + ;; innermost lambda expects env and path-args for rest + (funcall (function ,handler) (initialize-matrix-input rest env)))) + *routes*)) + +(defun router (env) + (log-info env) + (handler-case + (loop for route in *routes* + when (funcall route env) + return it + finally (error 'route-not-found)) + (matrix-error (c) + (handle-condition c)) + (route-not-found (c) + (handle-condition c)))) + + +;; earlier defined routes have lower precedence +(defroute :get "^/_matrix/client/versions$" versions) +(defroute :get "^/_matrix/client/login" get-logins) + diff --git a/tests/main.lisp b/tests/main.lisp new file mode 100644 index 0000000..38b89ba --- /dev/null +++ b/tests/main.lisp @@ -0,0 +1,11 @@ +(defpackage cl-matrix/tests/main + (:use :cl + :cl-matrix + :rove)) +(in-package :cl-matrix/tests/main) + +;; NOTE: To run this test file, execute `(asdf:test-system :cl-matrix)' in your Lisp. + +(deftest test-target-1 + (testing "should (= 1 1) to be true" + (ok (= 1 1))))