diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/main.lisp | 100 |
1 files changed, 74 insertions, 26 deletions
diff --git a/src/main.lisp b/src/main.lisp index c623336..4a0c2d1 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -46,11 +46,16 @@ :index-reader contributor-by-handle :documentation "The contributor's name. Must be unique among all other contributor names.") + (signature + :accessor contributor-signature + :initarg :signature + :initform "" + :documentation "A short piece of contributor flair. May contain a url.") (salt :reader contributor-salt :initform (uuid) :type string - :documentation "Per user salt for password hashing.") + :documentation "Per contributor salt for password hashing.") (hashed-pw :accessor hashed-pw :initform nil @@ -77,6 +82,12 @@ (with-plist (limit made) (contributor-invites contributor) (< made limit)))) +(defmethod json:%to-json ((obj contributor)) + (json:with-object + (json:write-key-value "handle" (contributor-handle obj)) + (json:write-key-value "signature" (contributor-signature obj)))) + + (defclass api-access (db:store-object) ((token :reader api-token @@ -110,7 +121,7 @@ directly. Hence, clients should copy the text of this oneliner to the clipboard if possible. Examples include ncurses applications, applications making use of readline, or those require extensive - user interaction.") + contributor interaction.") (tags :accessor oneliner-tags :initarg :tags @@ -150,7 +161,7 @@ (lockedp :accessor lockedp :initform nil - :documentation "Prevents editing until unliked. Only users with + :documentation "Prevents editing until unliked. Only contributors with admin priviliges can lock/unlock.")) (:metaclass db:persistent-class)) @@ -238,7 +249,7 @@ accounts. So keep it secret, keep it safe." () "Admins file formatted incorrectly. It should be a list of pairs of strings ((name pw) (name pw) ...)") (loop for (name pass) in admins unless (contributor-by-handle name) - do (make-new-admin-user name pass) + do (make-new-admin-contributor name pass) else do (format *error-output* "Did not make admin ~a." name))) (format *error-output* @@ -261,15 +272,14 @@ access to it. :INIT-ADMINS-FILE should be a file that contains a list of pairs of strings. This list is interpeted to be ((HANDLE1 PW1) (HANDLE2 PW2) -...) for admin users for this server. This file will be read and the -users will be made. You should destroy this file after the initial +...) for admin contributors for this server. This file will be read and the +contributors will be made. You should destroy this file after the initial boot up, subsequent boots will not need it, even if it remains mentioned in th config file. :SWANK-PORT, if provided, indicates that a swank server should be started, this will allow remote live debugging of the system. " - (handler-case (progn (assert (uiop:file-exists-p config-file)) @@ -389,6 +399,11 @@ started, this will allow remote live debugging of the system. (db:with-transaction () (setf (contributor-lockedp contributor) value))) +(defun set-signature (contributor signature) + "Set signature" + (db:with-transaction () + (setf (contributor-signature contributor) signature))) + (defun make-new-invite (&optional contributor) "Make and return a new invite object. " (db:with-transaction () @@ -399,11 +414,13 @@ started, this will allow remote live debugging of the system. (make-instance 'invite :from contributor)) (make-instance 'invite)))) -(defun redeem-invite (invite handle password) +(defun redeem-invite (invite handle password &optional sig) (db:with-transaction () - ;; make new user - (with-slots (salt hashed-pw) (make-instance 'contributor :handle handle) - (setf hashed-pw (pw-hash password salt))) + ;; make new contributor + (with-slots (salt hashed-pw signature) (make-instance 'contributor :handle handle) + (setf hashed-pw (pw-hash password salt)) + (when sig + (setf signature sig))) ;; increment the redeemed invite count on the contributor who made ;; it, if exists. (a:when-let (contributor (invite-from invite)) @@ -415,7 +432,7 @@ started, this will allow remote live debugging of the system. ;; finally, delete the invite. (db:delete-object invite))) -(defun make-new-admin-user (handle password) +(defun make-new-admin-contributor (handle password) (db:with-transaction () (with-slots (salt hashed-pw adminp) (make-instance 'contributor :handle handle) (setf hashed-pw (pw-hash password salt) @@ -539,7 +556,7 @@ started, this will allow remote live debugging of the system. invite (http-err 404))) -(defun a-user-handle (handle) +(defun a-contributor-by-handle (handle) "A Contributor's Handle" (a:if-let (contributor (contributor-by-handle handle)) contributor @@ -566,42 +583,71 @@ started, this will allow remote live debugging of the system. ;;; SOME PREDICATES +(defparameter +compiled-tag-and-handle-re+ + (ppcre:create-scanner "^[a-z0-9_\-]+$" + :single-line-mode t + :case-insensitive-mode t)) + +(defun valid-tag-p (tag) + (and (stringp tag) + (<= (length tag) 20) + (ppcre:scan +compiled-tag-and-handle-re+ tag))) (defun valid-contributor-handle-p (handle) (and (stringp handle) (<= 3 (length handle) 15) - (ppcre:scan "[a-zA-Z_0-9\-]+" handle))) + (ppcre:scan +compiled-tag-and-handle-re+ handle))) + +(defun valid-signature-p (signature) + (and (stringp signature) + (<= (length signature) +oneliner-brief-max-length+))) + + ;;; ENDPOINT DEFINITIONS -(defendpoint* :put "/contributor/:handle a-user-handle:/locked" ((value a-boolean) - (token an-api-token)) +(defendpoint* :get "/contributor/:who a-contributor-by-handle:" () () + (to-json who)) + +(defendpoint* :put "/contributor/:who a-contributor-by-handle:/locked" ((value a-boolean) + (token an-api-token)) (:auth 'admin-only) - (set-contributor-locked contributor value) + (set-contributor-locked who value) "true") -(defendpoint* :put "/contributor/:handle a-user-handle:/password" ((value a-string) - (repeated a-string) - (token an-api-token)) +(defendpoint* :put "/contributor/:who a-contributor-by-handle:/password" ((value a-string) + (repeated a-string) + (token an-api-token)) (:auth t) - (unless (or (eq handle (api-contributor token)) + (unless (or (eq who (api-contributor token)) (adminp (api-contributor token))) (http-err 403 "Cannot change that password.")) (unless (equalp value repeated) (http-err 400 "The two passwords do not match.")) - (update-password handle value) + (update-password who value) "true") +(defendpoint* :put "/contributor/:who a-contributor-by-handle:/signature" ((token an-api-token)) + (:auth t) + (unless (or (eq who (api-contributor token)) + (adminp (api-contributor token))) + (http-err 403)) + (with-plist (signature) (lzb:request-body) + (unless (valid-signature-p signature) + (http-err 400 "Bad signature")) + (set-signature who signature) + "true")) + (defendpoint* :post "/invite/redeem/:code an-invite-code:" () () "Redeem an [invite code](#invite-code) and create a new [contributor](#new-contributor-post-body)" - (with-plist (password1 password2 handle) (lzb:request-body) + (with-plist (password1 password2 handle signature) (lzb:request-body) (unless (equal password1 password2) (http-err 400 "Passwords dont match")) (unless (valid-contributor-handle-p handle) (http-err 400 (format nil "~a is not a valid contributor handle." handle))) (when (contributor-by-handle handle) (http-err 403 (format nil "The name ~a is already taken." handle))) - (redeem-invite code handle password1) + (redeem-invite code handle password1 signature) "true")) (defendpoint* :post "/access" () () @@ -643,13 +689,15 @@ have exceeded the invite limit." "On success, return an object containing a new [invite token](#invite-token)." (to-json (make-new-invite (api-contributor token)))) -(defparameter +explanation-wordcount-limit+ 550) +(defparameter +explanation-wordcount-limit+ 549) (defun validate-new-oneliner-plist (plist) (with-plist (oneliner tags brief runstyle explanation) plist (unless tags (http-err 400 "A oneliner requires tags")) + (unless (every 'valid-tag-p tags) + (http-err 400 "Some tags are malformed.")) (unless brief (http-err 400 "Oneliner requires a brief explanation")) (unless (<= (length brief) +oneliner-brief-max-length+) @@ -658,7 +706,7 @@ have exceeded the invite limit." (http-err 400 "Oneliner cannot be blank")) (when explanation (unless (<= (count #\space explanation) +explanation-wordcount-limit+) - (http-err 400 "Explanation is too long. Limit to around 500 words."))) + (http-err 400 "Explanation is too long. Limit to around 550 words."))) (when runstyle (setf runstyle (a:make-keyword runstyle)) (unless (typep runstyle 'runstyle) |