Use only spaces
This commit is contained in:
parent
bbf1e1e379
commit
64130d5ccc
7 changed files with 68 additions and 68 deletions
|
@ -4,28 +4,28 @@
|
||||||
|
|
||||||
(defun generate-hash (passphrase salt)
|
(defun generate-hash (passphrase salt)
|
||||||
"Where PASSPHRASE is a string and SALT is a unsigned byte array or string, returns an unsigned byte array"
|
"Where PASSPHRASE is a string and SALT is a unsigned byte array or string, returns an unsigned byte array"
|
||||||
(let* ((salt (if (typep salt '(simple-array (unsigned-byte 8) (*)))
|
(let* ((salt (if (typep salt '(simple-array (unsigned-byte 8) (*)))
|
||||||
salt
|
salt
|
||||||
(ironclad:hex-string-to-byte-array salt)))
|
(ironclad:hex-string-to-byte-array salt)))
|
||||||
(kdf (ironclad:make-kdf :argon2id :block-count 19456))
|
(kdf (ironclad:make-kdf :argon2id :block-count 19456))
|
||||||
(passphrase-bytes (flexi-streams:string-to-octets passphrase :external-format :utf-8))
|
(passphrase-bytes (flexi-streams:string-to-octets passphrase :external-format :utf-8))
|
||||||
(hash (ironclad:derive-key kdf passphrase-bytes salt 2 16)))
|
(hash (ironclad:derive-key kdf passphrase-bytes salt 2 16)))
|
||||||
hash))
|
hash))
|
||||||
|
|
||||||
(defun generate-hash-with-salt (passphrase)
|
(defun generate-hash-with-salt (passphrase)
|
||||||
"Where PASSPHRASE is a string, returns a string '<hash>:<salt>'"
|
"Where PASSPHRASE is a string, returns a string '<hash>:<salt>'"
|
||||||
(let* ((salt (ironclad:make-random-salt))
|
(let* ((salt (ironclad:make-random-salt))
|
||||||
(hash (generate-hash passphrase salt)))
|
(hash (generate-hash passphrase salt)))
|
||||||
(format nil "~a:~a"
|
(format nil "~a:~a"
|
||||||
(ironclad:byte-array-to-hex-string hash)
|
(ironclad:byte-array-to-hex-string hash)
|
||||||
(ironclad:byte-array-to-hex-string salt))))
|
(ironclad:byte-array-to-hex-string salt))))
|
||||||
|
|
||||||
(defun check-password (to-check passphrase-hash-and-salt-string)
|
(defun check-password (to-check passphrase-hash-and-salt-string)
|
||||||
(let* ((split-passphrase-hash-and-salt (uiop:split-string
|
(let* ((split-passphrase-hash-and-salt (uiop:split-string
|
||||||
passphrase-hash-and-salt-string :separator ":"))
|
passphrase-hash-and-salt-string :separator ":"))
|
||||||
(passphrase-hash (first split-passphrase-hash-and-salt))
|
(passphrase-hash (first split-passphrase-hash-and-salt))
|
||||||
(passphrase-salt (second split-passphrase-hash-and-salt))
|
(passphrase-salt (second split-passphrase-hash-and-salt))
|
||||||
(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
|
;; AUTH SESSION
|
||||||
|
@ -40,8 +40,8 @@
|
||||||
|
|
||||||
(defmethod auth-session-plist ((auth-session auth-session))
|
(defmethod auth-session-plist ((auth-session auth-session))
|
||||||
(let ((plist (list :flows `(:stages ,(stages auth-session))
|
(let ((plist (list :flows `(:stages ,(stages auth-session))
|
||||||
:params (params auth-session)
|
:params (params auth-session)
|
||||||
:session (session-id auth-session))))
|
:session (session-id auth-session))))
|
||||||
(when (completed auth-session)
|
(when (completed auth-session)
|
||||||
(push (completed auth-session) plist)
|
(push (completed auth-session) plist)
|
||||||
(push :completed plist))
|
(push :completed plist))
|
||||||
|
@ -70,7 +70,7 @@ We're not signaling any conditions from here because depending on whether it's a
|
||||||
(defmethod process-input ((auth-stage (eql :|m.login.password|)) input)
|
(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 (get-user identifier))
|
(let* ((user (get-user identifier))
|
||||||
(password-hash (password-hash user)))
|
(password-hash (password-hash user)))
|
||||||
(check-password password password-hash))))
|
(check-password password password-hash))))
|
||||||
|
|
||||||
(defmethod process-input (auth-stage input)
|
(defmethod process-input (auth-stage input)
|
||||||
|
@ -81,16 +81,16 @@ We're not signaling any conditions from here because depending on whether it's a
|
||||||
(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)))
|
||||||
(if device
|
(if device
|
||||||
(get-user (user-id device)))))
|
(get-user (user-id device)))))
|
||||||
|
|
||||||
(defmacro with-authentication (input-var &body body)
|
(defmacro with-authentication (input-var &body body)
|
||||||
`(let* ((access-token (matrix-input-access-token ,input-var))
|
`(let* ((access-token (matrix-input-access-token ,input-var))
|
||||||
(user (if access-token (get-user-from-access-token access-token))))
|
(user (if access-token (get-user-from-access-token access-token))))
|
||||||
(setf (matrix-input-user ,input-var))
|
(setf (matrix-input-user ,input-var))
|
||||||
(if user
|
(if user
|
||||||
(progn
|
(progn
|
||||||
,@body)
|
,@body)
|
||||||
(handle-auth-session))))
|
(handle-auth-session))))
|
||||||
|
|
||||||
(defun get-auth-params (matrix-input)
|
(defun get-auth-params (matrix-input)
|
||||||
(getf (matrix-input-json-body matrix-input) :auth))
|
(getf (matrix-input-json-body matrix-input) :auth))
|
||||||
|
@ -114,8 +114,8 @@ We're not signaling any conditions from here because depending on whether it's a
|
||||||
(defun post-login (input)
|
(defun post-login (input)
|
||||||
(let ((json-body (matrix-input-json-body input)))
|
(let ((json-body (matrix-input-json-body input)))
|
||||||
(if (process-input (alex:make-keyword (getf json-body :type "")) json-body)
|
(if (process-input (alex:make-keyword (getf json-body :type "")) json-body)
|
||||||
(json-response 200 '(:msg "success!"))
|
(json-response 200 '(:msg "success!"))
|
||||||
(error 'forbidden-error))))
|
(error 'forbidden-error))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
14
src/db.lisp
14
src/db.lisp
|
@ -25,7 +25,7 @@
|
||||||
("m.id.thirdparty" (get-user-by-thirdparty identity))
|
("m.id.thirdparty" (get-user-by-thirdparty identity))
|
||||||
("m.id.phone" (get-user-by-phone identity))
|
("m.id.phone" (get-user-by-phone identity))
|
||||||
(otherwise (error 'unknown-error
|
(otherwise (error 'unknown-error
|
||||||
:msg (format nil "~a is not a valid identity type" type))))))
|
:msg (format nil "~a is not a valid identity type" type))))))
|
||||||
|
|
||||||
(defun get-user-by-user (identity)
|
(defun get-user-by-user (identity)
|
||||||
(postmodern:with-connection cl-matrix-config:+database+
|
(postmodern:with-connection cl-matrix-config:+database+
|
||||||
|
@ -47,12 +47,12 @@
|
||||||
(defun coerce-user-id (name)
|
(defun coerce-user-id (name)
|
||||||
(multiple-value-bind (match server-name) (ppcre:scan-to-strings *user-id-scanner* name)
|
(multiple-value-bind (match server-name) (ppcre:scan-to-strings *user-id-scanner* name)
|
||||||
(if match
|
(if match
|
||||||
(if (string-equal cl-matrix-config:+server-name+ (aref server-name 0))
|
(if (string-equal cl-matrix-config:+server-name+ (aref server-name 0))
|
||||||
name
|
name
|
||||||
(error 'unknown-error :msg "user id server name is not valid"))
|
(error 'unknown-error :msg "user id server name is not valid"))
|
||||||
(if (ppcre:scan *user-localpart-scanner* name)
|
(if (ppcre:scan *user-localpart-scanner* name)
|
||||||
(format nil "@~a:~a" name cl-matrix-config:+server-name+)
|
(format nil "@~a:~a" name cl-matrix-config:+server-name+)
|
||||||
(error 'unknown-error :msg "user id localpart is not valid")))))
|
(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))
|
||||||
|
|
|
@ -12,8 +12,8 @@
|
||||||
(plist-p element)
|
(plist-p element)
|
||||||
(let (result)
|
(let (result)
|
||||||
(alex:doplist (key val element result)
|
(alex:doplist (key val element result)
|
||||||
(push (plist-hash-table-recurse val) result)
|
(push (plist-hash-table-recurse val) result)
|
||||||
(push key result))
|
(push key result))
|
||||||
(alex:plist-hash-table result)))
|
(alex:plist-hash-table result)))
|
||||||
(
|
(
|
||||||
(listp element)
|
(listp element)
|
||||||
|
@ -27,9 +27,9 @@
|
||||||
(hash-table-p element)
|
(hash-table-p element)
|
||||||
(let ((result))
|
(let ((result))
|
||||||
(maphash (lambda (key val)
|
(maphash (lambda (key val)
|
||||||
(push (hash-table-plist-recurse val) result)
|
(push (hash-table-plist-recurse val) result)
|
||||||
(push (alex:make-keyword (string-upcase key)) result))
|
(push (alex:make-keyword (string-upcase key)) result))
|
||||||
element)
|
element)
|
||||||
result))
|
result))
|
||||||
(
|
(
|
||||||
(and (vectorp element) (not (stringp element)))
|
(and (vectorp element) (not (stringp element)))
|
||||||
|
@ -38,7 +38,7 @@
|
||||||
|
|
||||||
(defun json-plist (json)
|
(defun json-plist (json)
|
||||||
(let ((parsed (handler-case
|
(let ((parsed (handler-case
|
||||||
(jzon:parse json)
|
(jzon:parse json)
|
||||||
(error ()
|
(error ()
|
||||||
(error 'not-json-error)))))
|
(error 'not-json-error)))))
|
||||||
(hash-table-plist-recurse parsed)))
|
(hash-table-plist-recurse parsed)))
|
||||||
|
|
|
@ -6,15 +6,15 @@
|
||||||
(if *running-server*
|
(if *running-server*
|
||||||
(log-info "server already running")
|
(log-info "server already running")
|
||||||
(progn
|
(progn
|
||||||
(setq *running-server*
|
(setq *running-server*
|
||||||
(clack:clackup 'router :server :woo))
|
(clack:clackup 'router :server :woo))
|
||||||
(log-info "server started"))))
|
(log-info "server started"))))
|
||||||
|
|
||||||
(defun stop-server ()
|
(defun stop-server ()
|
||||||
(if *running-server*
|
(if *running-server*
|
||||||
(progn
|
(progn
|
||||||
(clack:stop *running-server*)
|
(clack:stop *running-server*)
|
||||||
(log-info "server shutdown"))
|
(log-info "server shutdown"))
|
||||||
(log-info "no running server to shutdown"))
|
(log-info "no running server to shutdown"))
|
||||||
(setq *running-server* nil))
|
(setq *running-server* nil))
|
||||||
|
|
||||||
|
|
|
@ -16,16 +16,16 @@
|
||||||
|
|
||||||
(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)
|
||||||
for snake = (loop for ch across name
|
for snake = (loop for ch across name
|
||||||
with result = (copy-seq name)
|
with result = (copy-seq name)
|
||||||
for i upfrom 0
|
for i upfrom 0
|
||||||
do (if (eql ch #\-) (setf (aref result i) #\_))
|
do (if (eql ch #\-) (setf (aref result i) #\_))
|
||||||
finally (return result))
|
finally (return result))
|
||||||
collecting `(define-condition ,(intern (format nil "~a-ERROR" (string-upcase name))) (matrix-error)
|
collecting `(define-condition ,(intern (format nil "~a-ERROR" (string-upcase name))) (matrix-error)
|
||||||
((errcode :initform ,(format nil "M_~a" snake))))
|
((errcode :initform ,(format nil "M_~a" snake))))
|
||||||
into defines
|
into defines
|
||||||
finally (return (append '(progn) defines))))
|
finally (return (append '(progn) defines))))
|
||||||
|
|
||||||
(make-matrix-errors
|
(make-matrix-errors
|
||||||
forbidden
|
forbidden
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
(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)))
|
||||||
|
|
|
@ -10,7 +10,7 @@
|
||||||
(defun get-access-token (env)
|
(defun get-access-token (env)
|
||||||
(destructuring-bind (&key headers query-string &allow-other-keys) env
|
(destructuring-bind (&key headers query-string &allow-other-keys) env
|
||||||
(let* ((auth-token-header (get-access-token-from-header (gethash "Authorization" headers)))
|
(let* ((auth-token-header (get-access-token-from-header (gethash "Authorization" headers)))
|
||||||
(auth-token-params (get-access-token-from-params (if query-string (quri:url-decode-params query-string)))))
|
(auth-token-params (get-access-token-from-params (if query-string (quri:url-decode-params query-string)))))
|
||||||
(or auth-token-header auth-token-params))))
|
(or auth-token-header auth-token-params))))
|
||||||
|
|
||||||
(defun received-method-p (method)
|
(defun received-method-p (method)
|
||||||
|
@ -47,12 +47,12 @@
|
||||||
(lambda (env)
|
(lambda (env)
|
||||||
(let ((matches (nth-value 1 (ppcre:scan-to-strings url-pattern (getf env :path-info)))))
|
(let ((matches (nth-value 1 (ppcre:scan-to-strings url-pattern (getf env :path-info)))))
|
||||||
(if matches
|
(if matches
|
||||||
(apply handler env (coerce matches 'list))))))
|
(apply handler env (coerce matches 'list))))))
|
||||||
|
|
||||||
(defun wrap-method-match (method handler)
|
(defun wrap-method-match (method handler)
|
||||||
(lambda (env)
|
(lambda (env)
|
||||||
(if (eql method (getf env :request-method))
|
(if (eql method (getf env :request-method))
|
||||||
(funcall handler env))))
|
(funcall handler env))))
|
||||||
|
|
||||||
(defparameter *routes* nil)
|
(defparameter *routes* nil)
|
||||||
|
|
||||||
|
@ -62,27 +62,27 @@
|
||||||
(wrap-method-match
|
(wrap-method-match
|
||||||
,method
|
,method
|
||||||
(wrap-url-match
|
(wrap-url-match
|
||||||
,url-pattern
|
,url-pattern
|
||||||
(lambda (env &rest rest)
|
(lambda (env &rest rest)
|
||||||
;; innermost lambda expects env and path-args for rest
|
;; innermost lambda expects env and path-args for rest
|
||||||
(funcall (function ,handler) (initialize-matrix-input rest env)))))
|
(funcall (function ,handler) (initialize-matrix-input rest env)))))
|
||||||
*routes*)
|
*routes*)
|
||||||
(push
|
(push
|
||||||
(wrap-method-match
|
(wrap-method-match
|
||||||
:options
|
:options
|
||||||
(wrap-url-match
|
(wrap-url-match
|
||||||
,url-pattern
|
,url-pattern
|
||||||
(lambda (env &rest rest)
|
(lambda (env &rest rest)
|
||||||
(json-response 200 '()))))
|
(json-response 200 '()))))
|
||||||
*routes*)))
|
*routes*)))
|
||||||
|
|
||||||
(defun router (env)
|
(defun router (env)
|
||||||
(log-info (getf env :path-info))
|
(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 'unrecognized-error))
|
finally (error 'unrecognized-error))
|
||||||
(matrix-error (c)
|
(matrix-error (c)
|
||||||
(handle-condition c))))
|
(handle-condition c))))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Reference in a new issue