Got basic login flow working

This commit is contained in:
dominik martinez 2025-03-13 00:18:18 -07:00
parent 456a66bb44
commit bbf1e1e379
6 changed files with 92 additions and 25 deletions

View file

@ -1,6 +1,9 @@
(defpackage cl-matrix-config (defpackage cl-matrix-config
(:use #:cl) (:use #:cl)
(:export :+database+)) (:export :+database+
:+server-name+))
(in-package :cl-matrix-config) (in-package :cl-matrix-config)
(defvar +database+ '("cl_matrix_dev" "cl_matrix_dev" "cl_matrix_dev" "localhost")) (defvar +database+ '("cl_matrix_dev" "cl_matrix_dev" "cl_matrix_dev" "localhost"))
(defvar +server-name+ "localhost:5000")

View file

@ -61,11 +61,20 @@
(defgeneric process-input (auth-stage input) (defgeneric process-input (auth-stage input)
(:documentation (:documentation
"Process the plist INPUT as specified by AUTH-STAGE. Return two values, the first being T if the input is successful, NIL if not. The second value is when the first is NIL and there's additional information regarding the failure.")) "Process the plist INPUT as specified by AUTH-STAGE. \
(defmethod process-input ((auth-stage (eql '|m.login.password|)) input) Return two values, the first being T if the input is successful, NIL if not. \
The second value is when the first is NIL and there's additional information regarding the failure. \
We're not signaling any conditions from here because depending on whether it's a user-interactive authorization or plain login will affect response."))
(defmethod process-input ((auth-stage (eql :|m.login.password|)) input)
(destructuring-bind (&key identifier password &allow-other-keys) input (destructuring-bind (&key identifier password &allow-other-keys) input
(let ((user (db:get-user identifier)))))) (let* ((user (get-user identifier))
(password-hash (password-hash user)))
(check-password password password-hash))))
(defmethod process-input (auth-stage input)
(error 'unknown-error :msg (format nil "invalid auth type: ~a" auth-stage)))
;; ;;
@ -99,6 +108,14 @@
;; ENDPOINTS ;; ENDPOINTS
(defun get-login (input) (defun get-login (input)
(log-info input)) (declare (ignore input))
(json-response 200 '(:flows ((:type "m.login.password")))))
(defun post-login (input)
(let ((json-body (matrix-input-json-body input)))
(if (process-input (alex:make-keyword (getf json-body :type "")) json-body)
(json-response 200 '(:msg "success!"))
(error 'forbidden-error))))

View file

@ -1,4 +1,4 @@
(in-package :cl-matrix-db) (in-package :cl-matrix)
(defmethod insert (dao-model) (defmethod insert (dao-model)
(postmodern:with-connection cl-matrix-config:+database+ (postmodern:with-connection cl-matrix-config:+database+
@ -16,12 +16,43 @@
(defun get-id (identity) (defun get-id (identity)
(cl-matrix::log-info (intern (getf identity :type ""))) (cl-matrix::log-info (intern (getf identity :type "")))
(case (alex:make-keyword (getf identity :type "")) (case (alex:make-keyword (getf identity :type ""))
(:|m.id.user| (getf identity :user)) (:|m.id.user| (getf identity :user))))
(otherwise (error 'cl-matrix::forbidden-error))))
(defun get-user (identity) (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+ (postmodern:with-connection cl-matrix-config:+database+
(postmodern:get-dao 'user (get-id identity)))) (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) (defun make-user (id password-hash)
(make-instance 'user :id id :password-hash password-hash)) (make-instance 'user :id id :password-hash password-hash))
@ -54,5 +85,5 @@
(postmodern:execute "DROP TABLE devices;"))) (postmodern:execute "DROP TABLE devices;")))
(defun seed () (defun seed ()
(let ((harry-dubois (make-user "@harry:rcm.org" (cl-matrix::generate-hash-with-salt "martinaise")))) (let ((harry-dubois (make-user (coerce-user-id "harry") (cl-matrix::generate-hash-with-salt "martinaise"))))
(insert harry-dubois))) (insert harry-dubois)))

View file

@ -10,6 +10,10 @@
((errcode :reader errcode) ((errcode :reader errcode)
(msg :initarg :msg :initform "" :reader msg))) (msg :initarg :msg :initform "" :reader msg)))
(defmethod print-object ((e matrix-error) stream)
(print-unreadable-object (e stream :type t)
(format stream "~a" (msg e))))
(defmacro make-matrix-errors (&rest names) (defmacro make-matrix-errors (&rest names)
(loop for name-maybe in names (loop for name-maybe in names
for name = (string name-maybe) for name = (string name-maybe)

View file

@ -1,10 +1,4 @@
(defpackage cl-matrix-db
(:use #:cl)
(:local-nicknames (:alex :alexandria))
(:export :get-user))
(defpackage cl-matrix (defpackage cl-matrix
(:use #:cl) (:use #:cl)
(:local-nicknames (:jzon :com.inuoe.jzon) (:local-nicknames (:jzon :com.inuoe.jzon)
(:alex :alexandria) (:alex :alexandria)))
(:db :cl-matrix-db)))

View file

@ -18,11 +18,11 @@
(eql method :put))) (eql method :put)))
(defun initialize-matrix-input (path-args env) (defun initialize-matrix-input (path-args env)
(destructuring-bind (&key raw-body method &allow-other-keys) env (destructuring-bind (&key raw-body request-method &allow-other-keys) env
(make-matrix-input (make-matrix-input
:path-args path-args :path-args path-args
:access-token (get-access-token env) :access-token (get-access-token env)
:json-body (if (received-method-p method) (json-plist raw-body) nil)))) :json-body (if (received-method-p request-method) (json-plist raw-body) nil))))
(defvar +matrix-headers+ (defvar +matrix-headers+
'(:access-control-allow-origin "*" '(:access-control-allow-origin "*"
@ -49,15 +49,32 @@
(if matches (if matches
(apply handler env (coerce matches 'list)))))) (apply handler env (coerce matches 'list))))))
(defun wrap-method-match (method handler)
(lambda (env)
(if (eql method (getf env :request-method))
(funcall handler env))))
(defparameter *routes* nil) (defparameter *routes* nil)
(defmacro defroute (method url-pattern handler) (defmacro defroute (method url-pattern handler)
`(push `(progn
(wrap-url-match ,url-pattern (push
(lambda (env &rest rest) (wrap-method-match
;; innermost lambda expects env and path-args for rest ,method
(funcall (function ,handler) (initialize-matrix-input rest env)))) (wrap-url-match
*routes*)) ,url-pattern
(lambda (env &rest rest)
;; innermost lambda expects env and path-args for rest
(funcall (function ,handler) (initialize-matrix-input rest env)))))
*routes*)
(push
(wrap-method-match
:options
(wrap-url-match
,url-pattern
(lambda (env &rest rest)
(json-response 200 '()))))
*routes*)))
(defun router (env) (defun router (env)
(log-info (getf env :path-info)) (log-info (getf env :path-info))
@ -73,4 +90,5 @@
;; earlier defined routes have lower precedence ;; earlier defined routes have lower precedence
(defroute :get "^/_matrix/client/versions$" versions) (defroute :get "^/_matrix/client/versions$" versions)
(defroute :get "^/_matrix/client/v3/login" get-login) (defroute :get "^/_matrix/client/v3/login" get-login)
(defroute :post "^/_matrix/client/v3/login" post-login)