first commit. welcome home.
This commit is contained in:
commit
4850f6fec7
14 changed files with 446 additions and 0 deletions
9
.gitignore
vendored
Normal file
9
.gitignore
vendored
Normal file
|
@ -0,0 +1,9 @@
|
||||||
|
*.abcl
|
||||||
|
*.fasl
|
||||||
|
*.dx32fsl
|
||||||
|
*.dx64fsl
|
||||||
|
*.lx32fsl
|
||||||
|
*.lx64fsl
|
||||||
|
*.x86f
|
||||||
|
*~
|
||||||
|
.#*
|
9
README
Normal file
9
README
Normal 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
40
cl-matrix.asd
Normal 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
6
settings.lisp
Normal 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
88
src/auth.lisp
Normal 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
46
src/db.lisp
Normal 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
44
src/json.lisp
Normal 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
4
src/logging.lisp
Normal 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
23
src/main.lisp
Normal 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
70
src/matrix.lisp
Normal 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
9
src/models.lisp
Normal 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
7
src/package.lisp
Normal 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
80
src/routes.lisp
Normal 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
11
tests/main.lisp
Normal 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))))
|
Loading…
Add table
Reference in a new issue