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
(:use #:cl)
(:export :+database+))
(:export :+database+
:+server-name+))
(in-package :cl-matrix-config)
(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)
(: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
(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
(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)
(postmodern:with-connection cl-matrix-config:+database+
@ -16,12 +16,43 @@
(defun get-id (identity)
(cl-matrix::log-info (intern (getf identity :type "")))
(case (alex:make-keyword (getf identity :type ""))
(:|m.id.user| (getf identity :user))
(otherwise (error 'cl-matrix::forbidden-error))))
(:|m.id.user| (getf identity :user))))
(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: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)
(make-instance 'user :id id :password-hash password-hash))
@ -54,5 +85,5 @@
(postmodern:execute "DROP TABLE devices;")))
(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)))

View file

@ -10,6 +10,10 @@
((errcode :reader errcode)
(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)
(loop for name-maybe in names
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
(:use #:cl)
(:local-nicknames (:jzon :com.inuoe.jzon)
(:alex :alexandria)
(:db :cl-matrix-db)))
(:alex :alexandria)))

View file

@ -18,11 +18,11 @@
(eql method :put)))
(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
:path-args path-args
: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+
'(:access-control-allow-origin "*"
@ -49,15 +49,32 @@
(if matches
(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)
(defmacro defroute (method url-pattern handler)
`(push
(wrap-url-match ,url-pattern
`(progn
(push
(wrap-method-match
,method
(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*))
(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)
(log-info (getf env :path-info))
@ -73,4 +90,5 @@
;; earlier defined routes have lower precedence
(defroute :get "^/_matrix/client/versions$" versions)
(defroute :get "^/_matrix/client/v3/login" get-login)
(defroute :post "^/_matrix/client/v3/login" post-login)