first commit. welcome home.

.gitignore

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

README

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

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

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

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 '<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))))
+
+    

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

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

src/logging.lisp

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

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

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

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

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

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

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