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
|
||||
(: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")
|
||||
|
|
|
@ -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))))
|
||||
|
||||
|
||||
|
||||
|
|
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)
|
||||
(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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
Loading…
Add table
Reference in a new issue