first commit. welcome home.

This commit is contained in:
dominik martinez 2025-03-01 19:07:17 -08:00
commit 4850f6fec7
14 changed files with 446 additions and 0 deletions

9
.gitignore vendored Normal file
View file

@ -0,0 +1,9 @@
*.abcl
*.fasl
*.dx32fsl
*.dx64fsl
*.lx32fsl
*.lx64fsl
*.x86f
*~
.#*

9
README Normal file
View file

@ -0,0 +1,9 @@
# cl-matrix
## Usage
## Installation
## License
Licensed under the GPL-3.0-or-later License.

40
cl-matrix.asd Normal file
View file

@ -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)))

6
settings.lisp Normal file
View file

@ -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"))

88
src/auth.lisp Normal file
View file

@ -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 '<hash>:<salt>'"
(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))))

46
src/db.lisp Normal file
View file

@ -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)))

44
src/json.lisp Normal file
View file

@ -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)))

4
src/logging.lisp Normal file
View file

@ -0,0 +1,4 @@
(in-package :cl-matrix)
(defun log-info (msg)
(format t "[~a] ~a~%" (local-time:now) msg))

23
src/main.lisp Normal file
View file

@ -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))

70
src/matrix.lisp Normal file
View file

@ -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))

9
src/models.lisp Normal file
View file

@ -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))

7
src/package.lisp Normal file
View file

@ -0,0 +1,7 @@
(defpackage cl-matrix-db
(:use #:cl))
(defpackage cl-matrix
(:use #:cl)
(:local-nicknames (:jzon :com.inuoe.jzon)
(:alex :alexandria)))

80
src/routes.lisp Normal file
View file

@ -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)

11
tests/main.lisp Normal file
View file

@ -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))))