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)