more stuff -- lost track
This commit is contained in:
parent
cfb760c3b2
commit
456a66bb44
7 changed files with 58 additions and 33 deletions
|
@ -20,6 +20,7 @@
|
||||||
:components
|
:components
|
||||||
((:file "package")
|
((:file "package")
|
||||||
(:file "logging")
|
(:file "logging")
|
||||||
|
(:file "json")
|
||||||
(:file "db")
|
(:file "db")
|
||||||
(:file "auth")
|
(:file "auth")
|
||||||
(:file "matrix")
|
(:file "matrix")
|
||||||
|
|
|
@ -28,6 +28,8 @@
|
||||||
(to-check-hash (ironclad:byte-array-to-hex-string (generate-hash to-check passphrase-salt))))
|
(to-check-hash (ironclad:byte-array-to-hex-string (generate-hash to-check passphrase-salt))))
|
||||||
(equal to-check-hash passphrase-hash)))
|
(equal to-check-hash passphrase-hash)))
|
||||||
|
|
||||||
|
;; AUTH SESSION
|
||||||
|
|
||||||
(defvar *auth-sessions* (make-hash-table :test 'equal))
|
(defvar *auth-sessions* (make-hash-table :test 'equal))
|
||||||
|
|
||||||
(defclass auth-session ()
|
(defclass auth-session ()
|
||||||
|
@ -48,15 +50,24 @@
|
||||||
(defclass password-auth-session (auth-session)
|
(defclass password-auth-session (auth-session)
|
||||||
((stages :initform (list (make-instance 'password-auth-stage)))))
|
((stages :initform (list (make-instance 'password-auth-stage)))))
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
|
;; AUTH STAGE
|
||||||
(defclass auth-stage ()
|
(defclass auth-stage ()
|
||||||
((type :reader auth-stage-type)))
|
((type :reader auth-stage-type)))
|
||||||
|
|
||||||
(defclass password-auth-stage (auth-stage)
|
(defclass password-auth-stage (auth-stage)
|
||||||
((type :initform "m.login.password.")))
|
((type :initform "m.login.password.")))
|
||||||
|
|
||||||
(defgeneric process-input (auth-stage input))
|
(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."))
|
||||||
|
|
||||||
(defmethod process-input ((auth-stage password-auth-stage) input))
|
(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))))))
|
||||||
|
|
||||||
|
;;
|
||||||
|
|
||||||
(defun get-user-from-access-token (access-token)
|
(defun get-user-from-access-token (access-token)
|
||||||
(let ((device (get-device access-token)))
|
(let ((device (get-device access-token)))
|
||||||
|
@ -80,9 +91,14 @@
|
||||||
(continue-auth-session matrix-input)
|
(continue-auth-session matrix-input)
|
||||||
(start-auth-session matrix-input)))
|
(start-auth-session matrix-input)))
|
||||||
|
|
||||||
(defun start-auth-session (matrix-input)
|
;; (defun start-auth-session (matrix-input)
|
||||||
(let ((auth-session (make-instance 'password-auth-session)))
|
;; (let ((auth-session (make-instance 'password-auth-session)))
|
||||||
(setf (gethash (session-id auth-session) *auth-sessions*) auth-session)
|
;; (setf (gethash (session-id auth-session) *auth-sessions*) auth-session)
|
||||||
(json-response 401 (auth-session-plist auth-session))))
|
;; (json-response 401 (auth-session-plist auth-session))))
|
||||||
|
|
||||||
|
;; ENDPOINTS
|
||||||
|
|
||||||
|
(defun get-login (input)
|
||||||
|
(log-info input))
|
||||||
|
|
||||||
|
|
||||||
|
|
26
src/db.lisp
26
src/db.lisp
|
@ -1,9 +1,11 @@
|
||||||
(in-package :cl-matrix)
|
(in-package :cl-matrix-db)
|
||||||
|
|
||||||
(defmethod insert (dao-model)
|
(defmethod insert (dao-model)
|
||||||
(postmodern:with-connection cl-matrix-config:+database+
|
(postmodern:with-connection cl-matrix-config:+database+
|
||||||
(postmodern:insert-dao dao-model)))
|
(postmodern:insert-dao dao-model)))
|
||||||
|
|
||||||
|
;; USER
|
||||||
|
|
||||||
(defclass user ()
|
(defclass user ()
|
||||||
((id :col-type string :initarg :id :reader id)
|
((id :col-type string :initarg :id :reader id)
|
||||||
(password-hash :col-type string :initarg :password-hash :accessor password-hash))
|
(password-hash :col-type string :initarg :password-hash :accessor password-hash))
|
||||||
|
@ -11,13 +13,21 @@
|
||||||
(:keys id)
|
(:keys id)
|
||||||
(:table-name users))
|
(:table-name users))
|
||||||
|
|
||||||
(defun get-user (id)
|
(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))))
|
||||||
|
|
||||||
|
(defun get-user (identity)
|
||||||
(postmodern:with-connection cl-matrix-config:+database+
|
(postmodern:with-connection cl-matrix-config:+database+
|
||||||
(postmodern:get-dao 'user id)))
|
(postmodern:get-dao 'user (get-id identity))))
|
||||||
|
|
||||||
(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))
|
||||||
|
|
||||||
|
;; DEVICE
|
||||||
|
|
||||||
(defclass device ()
|
(defclass device ()
|
||||||
((user-id :col-type string :col-references ((user id)) :initarg :user-id :reader user-id)
|
((user-id :col-type string :col-references ((user id)) :initarg :user-id :reader user-id)
|
||||||
(id :col-type string :initarg :id :accessor id)
|
(id :col-type string :initarg :id :accessor id)
|
||||||
|
@ -31,16 +41,18 @@
|
||||||
(postmodern:with-connection cl-matrix-config:+database+
|
(postmodern:with-connection cl-matrix-config:+database+
|
||||||
(postmodern:get-dao 'device access-token)))
|
(postmodern:get-dao 'device access-token)))
|
||||||
|
|
||||||
(defun db-create-tables ()
|
;; UTILS
|
||||||
|
|
||||||
|
(defun create-tables ()
|
||||||
(postmodern:with-connection cl-matrix-config:+database+
|
(postmodern:with-connection cl-matrix-config:+database+
|
||||||
(postmodern:execute (postmodern:dao-table-definition 'user))
|
(postmodern:execute (postmodern:dao-table-definition 'user))
|
||||||
(postmodern:execute (postmodern:dao-table-definition 'device))))
|
(postmodern:execute (postmodern:dao-table-definition 'device))))
|
||||||
|
|
||||||
(defun db-drop-tables ()
|
(defun drop-tables ()
|
||||||
(postmodern:with-connection cl-matrix-config:+database+
|
(postmodern:with-connection cl-matrix-config:+database+
|
||||||
(postmodern:execute "DROP TABLE users;")
|
(postmodern:execute "DROP TABLE users;")
|
||||||
(postmodern:execute "DROP TABLE devices;")))
|
(postmodern:execute "DROP TABLE devices;")))
|
||||||
|
|
||||||
(defun db-seed ()
|
(defun seed ()
|
||||||
(let ((harry-dubois (make-user "@harry:rcm.org" (generate-hash-with-salt "martinaise"))))
|
(let ((harry-dubois (make-user "@harry:rcm.org" (cl-matrix::generate-hash-with-salt "martinaise"))))
|
||||||
(insert harry-dubois)))
|
(insert harry-dubois)))
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
(defparameter *running-server* nil)
|
(defparameter *running-server* nil)
|
||||||
|
|
||||||
(defun server-start ()
|
(defun start-server ()
|
||||||
(if *running-server*
|
(if *running-server*
|
||||||
(log-info "server already running")
|
(log-info "server already running")
|
||||||
(progn
|
(progn
|
||||||
|
@ -10,7 +10,7 @@
|
||||||
(clack:clackup 'router :server :woo))
|
(clack:clackup 'router :server :woo))
|
||||||
(log-info "server started"))))
|
(log-info "server started"))))
|
||||||
|
|
||||||
(defun server-stop ()
|
(defun stop-server ()
|
||||||
(if *running-server*
|
(if *running-server*
|
||||||
(progn
|
(progn
|
||||||
(clack:stop *running-server*)
|
(clack:stop *running-server*)
|
||||||
|
@ -18,6 +18,6 @@
|
||||||
(log-info "no running server to shutdown"))
|
(log-info "no running server to shutdown"))
|
||||||
(setq *running-server* nil))
|
(setq *running-server* nil))
|
||||||
|
|
||||||
(defun server-restart ()
|
(defun restart-server ()
|
||||||
(server-stop)
|
(stop-server)
|
||||||
(server-start))
|
(start-server))
|
||||||
|
|
|
@ -62,9 +62,6 @@
|
||||||
threepid-in-use)
|
threepid-in-use)
|
||||||
|
|
||||||
(defun versions (input)
|
(defun versions (input)
|
||||||
(json-response 200 '(:versions ("v1.1" "v1.2" "v1.3" "v1.4" "v1.5" "v1.6" "v1.7" "v1.8" "v1.9" "v1.10" "v1.11" "v1.12" "v1.13"))))
|
(json-response 200 '(:versions ("r0.0.1" "r0.1.0" "r0.2.0" "r0.3.0" "r0.4.0" "r0.5.0" "r0.6.0" "r0.6.1" "v1.1" "v1.2" "v1.3" "v1.4" "v1.5" "v1.6" "v1.7" "v1.8" "v1.9" "v1.10" "v1.11" "v1.12" "v1.13"))))
|
||||||
|
|
||||||
(defun get-logins (input)
|
|
||||||
(log-info input))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,10 @@
|
||||||
(defpackage cl-matrix-db
|
(defpackage cl-matrix-db
|
||||||
(:use #:cl))
|
(: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)))
|
||||||
|
|
|
@ -40,10 +40,8 @@
|
||||||
(defmethod handle-condition ((err matrix-error))
|
(defmethod handle-condition ((err matrix-error))
|
||||||
(json-response 400 `(:errcode ,(errcode err) :error ,(msg err))))
|
(json-response 400 `(:errcode ,(errcode err) :error ,(msg err))))
|
||||||
|
|
||||||
(define-condition route-not-found (error) ())
|
(defmethod handle-condition ((err unrecognized-error))
|
||||||
|
(json-response 404 `(:errcode ,(errcode err) :error ,(msg err))))
|
||||||
(defmethod handle-condition ((err route-not-found))
|
|
||||||
(json-response 404 nil))
|
|
||||||
|
|
||||||
(defun wrap-url-match (url-pattern handler)
|
(defun wrap-url-match (url-pattern handler)
|
||||||
(lambda (env)
|
(lambda (env)
|
||||||
|
@ -62,19 +60,17 @@
|
||||||
*routes*))
|
*routes*))
|
||||||
|
|
||||||
(defun router (env)
|
(defun router (env)
|
||||||
(log-info env)
|
(log-info (getf env :path-info))
|
||||||
(handler-case
|
(handler-case
|
||||||
(loop for route in *routes*
|
(loop for route in *routes*
|
||||||
when (funcall route env)
|
when (funcall route env)
|
||||||
return it
|
return it
|
||||||
finally (error 'route-not-found))
|
finally (error 'unrecognized-error))
|
||||||
(matrix-error (c)
|
(matrix-error (c)
|
||||||
(handle-condition c))
|
|
||||||
(route-not-found (c)
|
|
||||||
(handle-condition c))))
|
(handle-condition c))))
|
||||||
|
|
||||||
|
|
||||||
;; 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/login" get-logins)
|
(defroute :get "^/_matrix/client/v3/login" get-login)
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue