From bbf1e1e379a02e02bd4b6c14a1bc6de440dabece Mon Sep 17 00:00:00 2001 From: dominik martinez Date: Thu, 13 Mar 2025 00:18:18 -0700 Subject: [PATCH] Got basic login flow working --- settings.lisp | 5 ++++- src/auth.lisp | 25 +++++++++++++++++++++---- src/db.lisp | 41 ++++++++++++++++++++++++++++++++++++----- src/matrix.lisp | 4 ++++ src/package.lisp | 8 +------- src/routes.lisp | 34 ++++++++++++++++++++++++++-------- 6 files changed, 92 insertions(+), 25 deletions(-) diff --git a/settings.lisp b/settings.lisp index 7708ed2..0f1a2f9 100644 --- a/settings.lisp +++ b/settings.lisp @@ -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") diff --git a/src/auth.lisp b/src/auth.lisp index 94bcd03..7d2ee85 100644 --- a/src/auth.lisp +++ b/src/auth.lisp @@ -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)))) + diff --git a/src/db.lisp b/src/db.lisp index 1112922..7b8ee71 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -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))) diff --git a/src/matrix.lisp b/src/matrix.lisp index 4c122b3..317e84e 100644 --- a/src/matrix.lisp +++ b/src/matrix.lisp @@ -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) diff --git a/src/package.lisp b/src/package.lisp index 28225ee..272a543 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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))) diff --git a/src/routes.lisp b/src/routes.lisp index e9ba987..a264d60 100644 --- a/src/routes.lisp +++ b/src/routes.lisp @@ -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 - (lambda (env &rest rest) - ;; innermost lambda expects env and path-args for rest - (funcall (function ,handler) (initialize-matrix-input rest env)))) - *routes*)) + `(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*) + (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)