Got basic login flow working
This commit is contained in:
parent
456a66bb44
commit
bbf1e1e379
6 changed files with 92 additions and 25 deletions
|
@ -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")
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
41
src/db.lisp
41
src/db.lisp
|
@ -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)))
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)))
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue