Got basic login flow working

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")

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))))
+			    
 
     

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)))

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)

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)))

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
+  `(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)