aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/main.lisp100
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)