diff options
| -rw-r--r-- | clpmfile.lock | 36 | ||||
| -rw-r--r-- | src/main.lisp | 212 |
2 files changed, 131 insertions, 117 deletions
diff --git a/clpmfile.lock b/clpmfile.lock index 9002400..a47fc2c 100644 --- a/clpmfile.lock +++ b/clpmfile.lock @@ -38,47 +38,47 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; :releases -("alexandria" :version "2021-12-09" :source "quicklisp" :systems ("alexandria")) +("alexandria" :version "2022-02-20" :source "quicklisp" :systems ("alexandria")) ("babel" :version "2020-09-25" :source "quicklisp" :systems ("babel")) -("bknr-datastore" :version "2019-12-27" :source "quicklisp" :systems +("bknr-datastore" :version "2022-02-20" :source "quicklisp" :systems ("bknr.datastore" "bknr.indices" "bknr.skip-list" "bknr.utils")) ("bordeaux-threads" :version "2020-06-10" :source "quicklisp" :systems ("bordeaux-threads")) ("cffi" :version "2021-04-11" :source "quicklisp" :systems ("cffi" "cffi-grovel" "cffi-toolchain")) -("chipz" :version "2021-08-07" :source "quicklisp" :systems ("chipz")) +("chipz" :version "2022-02-20" :source "quicklisp" :systems ("chipz")) ("chunga" :version "2020-04-27" :source "quicklisp" :systems ("chunga")) -("cl+ssl" :version "2021-12-30" :source "quicklisp" :systems ("cl+ssl")) +("cl+ssl" :version "2022-02-20" :source "quicklisp" :systems ("cl+ssl")) ("cl-annot" :version "2015-06-08" :source "quicklisp" :systems ("cl-annot")) ("cl-base64" :version "2020-10-16" :source "quicklisp" :systems ("cl-base64")) ("cl-change-case" :version "2021-04-11" :source "quicklisp" :systems ("cl-change-case")) ("cl-cookie" :version "2019-10-07" :source "quicklisp" :systems ("cl-cookie")) -("cl-fad" :version "2021-01-24" :source "quicklisp" :systems ("cl-fad")) +("cl-fad" :version "2022-02-20" :source "quicklisp" :systems ("cl-fad")) ("cl-interpol" :version "2020-12-20" :source "quicklisp" :systems ("cl-interpol")) -("cl-ppcre" :version "2019-05-21" :source "quicklisp" :systems +("cl-ppcre" :version "2022-02-20" :source "quicklisp" :systems ("cl-ppcre" "cl-ppcre-unicode")) -("cl-str" :version "2021-05-31" :source "quicklisp" :systems ("str")) +("cl-str" :version "2022-02-20" :source "quicklisp" :systems ("str")) ("cl-syntax" :version "2015-04-07" :source "quicklisp" :systems ("cl-syntax" "cl-syntax-annot")) ("cl-unicode" :version "2021-02-28" :source "quicklisp" :systems ("cl-unicode")) ("cl-utilities" :version "2010-10-07" :source "quicklisp" :systems ("cl-utilities")) -("closer-mop" :version "2021-12-30" :source "quicklisp" :systems ("closer-mop")) -("dexador" :version "2021-12-09" :source "quicklisp" :systems ("dexador")) +("closer-mop" :version "2022-02-20" :source "quicklisp" :systems ("closer-mop")) +("dexador" :version "2022-02-20" :source "quicklisp" :systems ("dexador")) ("dissect" :version "2021-05-31" :source "quicklisp" :systems ("dissect")) ("fast-http" :version "2019-10-07" :source "quicklisp" :systems ("fast-http")) ("fast-io" :version "2020-09-25" :source "quicklisp" :systems ("fast-io")) -("flexi-streams" :version "2021-08-07" :source "quicklisp" :systems +("flexi-streams" :version "2022-02-20" :source "quicklisp" :systems ("flexi-streams")) ("hunchentoot" :version "2020-06-10" :source "quicklisp" :systems ("hunchentoot")) -("ironclad" :version "2021-10-21" :source "quicklisp" :systems ("ironclad")) +("ironclad" :version "2022-02-20" :source "quicklisp" :systems ("ironclad")) ("jonathan" :version "2020-09-25" :source "quicklisp" :systems ("jonathan")) ("lambda-riffs" :version (:commit "f7b3c081f2361f7370c80e7ff4a432241f34ce55") :source :implicit-vcs :systems ("lambda-riffs")) -("lazybones" :version (:commit "c48ecda020797fe3fe65d55d02a8b72f6e7f19cb") +("lazybones" :version (:commit "70def00400c88f4d872a58b2f76449077ece22ca") :source :implicit-vcs :systems ("lazybones" "lazybones-hunchentoot")) ("lazybones-client" :version (:commit "92fe387b39d56f94e19d412c24a0c19a792f1ad1") :source :implicit-vcs @@ -87,7 +87,7 @@ ("lisp-namespace")) ("local-time" :version "2021-01-24" :source "quicklisp" :systems ("local-time")) ("md5" :version "2021-06-30" :source "quicklisp" :systems ("md5")) -("named-readtables" :version "2021-12-09" :source "quicklisp" :systems +("named-readtables" :version "2022-02-20" :source "quicklisp" :systems ("named-readtables")) ("oneliners.api-client.asd" :version :newest :source :implicit-file :systems ("oneliners.api-client")) @@ -96,7 +96,7 @@ ("proc-parse" :version "2019-08-13" :source "quicklisp" :systems ("proc-parse")) ("quri" :version "2021-06-30" :source "quicklisp" :systems ("quri")) ("rfc2388" :version "2018-08-31" :source "quicklisp" :systems ("rfc2388")) -("rove" :version "2021-12-09" :source "quicklisp" :systems ("rove")) +("rove" :version "2022-02-20" :source "quicklisp" :systems ("rove")) ("smart-buffer" :version "2021-10-21" :source "quicklisp" :systems ("smart-buffer")) ("split-sequence" :version "2021-05-31" :source "quicklisp" :systems @@ -117,13 +117,13 @@ ("trivial-mimes")) ("trivial-types" :version "2012-04-07" :source "quicklisp" :systems ("trivial-types")) -("trivial-utf-8" :version "2021-12-09" :source "quicklisp" :systems +("trivial-utf-8" :version "2022-02-20" :source "quicklisp" :systems ("trivial-utf-8")) ("unit-test" :version "2012-05-20" :source "quicklisp" :systems ("unit-test")) ("usocket" :version "2019-12-27" :source "quicklisp" :systems ("usocket")) ("uuid" :version "2020-07-15" :source "quicklisp" :systems ("uuid")) ("xsubseq" :version "2017-08-30" :source "quicklisp" :systems ("xsubseq")) -("yason" :version "2019-12-27" :source "quicklisp" :systems ("yason")) +("yason" :version "2022-02-20" :source "quicklisp" :systems ("yason")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -321,7 +321,9 @@ ((:system :name "cffi") (:system :name "trivial-features")) ((:system :name "babel") (:system :name "trivial-features"))) -("trivial-garbage" ((:system :name "cl+ssl") (:system :name "trivial-garbage"))) +("trivial-garbage" + ((:system :name "dexador") (:system :name "trivial-garbage")) + ((:system :name "cl+ssl") (:system :name "trivial-garbage"))) ("trivial-gray-streams" ((:system :name "yason") (:system :name "trivial-gray-streams")) diff --git a/src/main.lisp b/src/main.lisp index 979752f..9145a8a 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -24,8 +24,11 @@ (:metaclass db:persistent-class)) (defun invite-expiration (invite) - (+ +invite-lifetime+ - (created-at invite))) + "Returns a string representation of the expiration of an invite" + (multiple-value-bind (sec min hour date month year) (decode-universal-time + (+ +invite-lifetime+ + (created-at invite))) + (format nil "~2,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d" year month date hour min))) (defmethod json:%to-json ((invite invite)) (json:with-object @@ -85,6 +88,8 @@ (deftype runstyle () `(member :auto :manual)) +(defparameter +oneliner-brief-max-length+ 72) + (defclass oneliner (db:store-object) ((oneliner :accessor oneliner @@ -313,25 +318,15 @@ (a:when-let ((access (access-by-contributor contributor))) (revoke-access access)))) -(defun make-new-oneliner (contributor plist) - (with-plist - (oneliner tags brief explanation runstyle) plist - (unless brief - (http-err 400 "Oneliner requires a brief explanation")) - (unless oneliner - (http-err 400 "Oneliner cannot be blank")) - (when runstyle - (setf runstyle (a:make-keyword runstyle)) - (unless (typep runstyle 'runstyle) - (http-err 400 "Invalid runstyle."))) - (db:with-transaction () - (make-instance 'oneliner - :created-by contributor - :explanation (or explanation "") - :tags tags - :oneliner oneliner - :brief brief - :runstyle (or runstyle :auto))))) +(defun make-new-oneliner (contributor oneliner tags brief explanation runstyle) + (db:with-transaction () + (make-instance 'oneliner + :created-by contributor + :explanation (or explanation "") + :tags tags + :oneliner oneliner + :brief brief + :runstyle (or runstyle :auto)))) (defun flag-oneliner (oneliner &optional contributor) "Flag a oneliner for review. If locked, ensure that CONTRIBUTOR is an admin. Returns T or NIL." @@ -352,25 +347,20 @@ (db:with-transaction () (setf (lockedp oneliner) nil)))) -(defun edit-oneliner (ol contributor plist) - (when (or (not (lockedp ol)) (adminp contributor)) - (with-plist - (oneliner tags brief explanation runstyle) plist - (when runstyle - (setf runstyle (a:make-keyword runstyle)) - (unless (typep runstyle 'runstyle) - (http-err 400))) - (db:with-transaction () - (when oneliner - (setf (oneliner ol) oneliner)) - (when tags - (setf (oneliner-tags ol) tags)) - (when brief - (setf (oneliner-brief ol) brief)) - (when explanation - (setf (oneliner-explanation ol) explanation)) - (when runstyle - (setf (oneliner-runstyle ol) runstyle)))))) +(defun edit-oneliner (ol contributor &key oneliner tags brief explanation runstyle) + "Assumes each param, where given, has been validated." + (db:with-transaction () + (setf (last-edited-by ol) contributor) + (when oneliner + (setf (oneliner ol) oneliner)) + (when tags + (setf (oneliner-tags ol) tags)) + (when brief + (setf (oneliner-brief ol) brief)) + (when explanation + (setf (oneliner-explanation ol) explanation)) + (when runstyle + (setf (oneliner-runstyle ol) (a:make-keyword runstyle))))) ;;; NONTRANSACTIONAL DATABASE QUERIES @@ -434,49 +424,48 @@ (defun an-api-token (token) "An api token" - token) + (a:if-let (access (access-by-token token)) + access + (http-err 404))) ;;; ENDPOINT DEFINITIONS -(defendpoint* :post "/redeem/:invite an-invite-code:" - ((username a-string) - (password1 a-string) - (password2 a-string)) - () +(defendpoint* :post "/invite/redeem/:code an-invite-code:" () () "Redeem an [invite code](#invite-code) and create a new [contributor](#new-contributor-post-body)" - (unless (equal password1 password2) - (http-err 400 "Passwords dont match")) - (when (contributor-by-handle username) - (http-err 403 (format nil "The name ~a is already taken." username))) - (redeem-invite invite username password1) - "true") - -(defendpoint* :post "/token/:contributor a-user-handle:" - ((password a-string)) - () - "Authenticate a contributor and reply with an [api token](#access-token)" - (cond ((equal (pw-hash password (contributor-salt contributor)) - (hashed-pw contributor)) - (let ((token (a:if-let (access (access-by-contributor contributor)) - (api-token access) - (api-token (make-api-access contributor))))) - (to-json (list :token token)))) - (t - (http-err 401)))) + (with-plist (password1 password2 handle) (lzb:request-body) + (unless (equal password1 password2) + (http-err 400 "Passwords dont match")) + (when (contributor-by-handle username) + (http-err 403 (format nil "The name ~a is already taken." username))) + (redeem-invite code username password1) + "true")) + +(defendpoint* :post "/access" () () + "Authenticate a contributor and reply with an [API token](#access-token)" + (with-plist + (password handle) (lzb:request-body) + (a:if-let ((contributor (contributor-by-handle handle))) + (if (equal (pw-hash password (contributor-salt contributor)) + (hashed-pw contributor)) + (let ((token (a:if-let (access (access-by-contributor contributor)) + (api-token access) + (api-token (make-api-access contributor))))) + (to-json (list :token token))) + (http-err 401))))) (defun can-revoke-contributor (requesting-contributor target-contributor) "A contributor can revoke their own access, or an admin can revoke anybody's." (or (eq requesting-contributor target-contributor) (adminp requesting-contributor))) -(defendpoint* :post "/revoke/:contributor a-user-handle:" ((token an-api-token)) +(defendpoint* :delete "/access/:access an-api-token:" ((token an-api-token)) (:auth t) - "A contributor can revoke their own access (if for some reason their - API key ends up out of their control), or an admin can revoke - anybody's access token, forcing the to re-authenticate." - (if (can-revoke-contributor (request-contributor) contributor) - (revoke-access contributor) - (http-err 403))) + "Revoke access of CONTRIBUTOR" + (unless (can-revoke-contributor (request-contributor) (api-contributor access)) + (http-err 403)) + (revoke-access access) + "true") + (defun authorized-to-invite () "To make a new invite, a contributor must be authorized and must not @@ -485,15 +474,30 @@ have exceeded the invite limit." (or (adminp contributor) (can-invite-p contributor)))) -(defendpoint* :post "/make-invite" ((token an-api-token)) +(defendpoint* :post "/invite" ((token an-api-token)) (:auth 'authorized-to-invite) "On success, return an object containing a new [invite token](#invite-token)." - (to-json (make-new-invite (request-contributor)))) + (to-json (make-new-invite (api-contributor token)))) -(defendpoint* :post "/add-oneliner" ((token an-api-token)) +(defendpoint* :post "/oneliner" ((token an-api-token)) (:auth t) "Make a new [oneliner](#oneliner)." - (make-new-oneliner (request-contributor) (lzb:request-body)) + (with-plist + (oneliner tags brief explanation runstyle) (lzb:request-body) + (unless brief + (http-err 400 "Oneliner requires a brief explanation")) + (unless oneliner + (http-err 400 "Oneliner cannot be blank")) + (when runstyle + (setf runstyle (a:make-keyword runstyle)) + (unless (typep runstyle 'runstyle) + (http-err 400 "Invalid runstyle."))) + (make-new-oneliner (api-contributor token) + oneliner + tags + brief + explanation + runstyle)) "true") (defun admin-only () @@ -502,35 +506,45 @@ admin privileges are allowed to perform this action." (a:when-let (contributor (request-contributor)) (adminp contributor))) -(defendpoint* :patch "/lock/:oneliner a-oneliner-id:" ((token an-api-token)) +(defendpoint* :put "/oneliner/:oneliner a-oneliner-id:/locked" ((token an-api-token) + (value a-boolean)) (:auth 'admin-only) - "Locks a oneliner. Locked oneliners cannot be edited or flagged." - (lock-oneliner oneliner (request-contributor)) + "Sets the locked value of the specified oneliner" + (if value + (lock-oneliner oneliner (api-contributor token)) + (unlock-oneliner oneliner (api-contributor token))) "true") -(defendpoint* :patch "/unlock/:oneliner a-oneliner-id:" ((token an-api-token)) - (:auth 'admin-only) - "Unlocks a oneliner." - (unlock-oneliner oneliner (request-contributor)) - "true") +(defun validate-oneliner-edit-plist (plist) + (with-plist + (brief runstyle) plist + (when brief + (unless (<= (length brief) +oneliner-brief-max-length+) + (http-err 400 (format nil "Brief too long. Must be under ~a" +oneliner-brief-max-length+)))) + (when runstyle + (unless (typep (a:make-keyword runstyle) 'runstyle) + (http-err 400 (format nil "Invalid runstyle. Must be AUTO or MANUAL")))))) -(defendpoint* :patch "/edit/:oneliner a-oneliner-id:" ((token an-api-token)) +(defendpoint* :patch "/oneliner/:entry a-oneliner-id:/edit" ((token an-api-token)) (:auth t) "Edit the fields of a oneliner." - (if (edit-oneliner oneliner (request-contributor) (lzb:request-body)) - "true" - (http-err 403))) ;; in case it is locked + (when (and (lockedp entry) (not (adminp (api-contributor token)))) + (http-err 403)) + (validate-oneliner-edit-plist (lzb:request-body)) + (apply 'edit-oneliner entry (api-contributor token) (lzb:request-body)) + "true") -(defendpoint* :patch "/flag/:oneliner a-oneliner-id:" ((token an-api-token)) - () - "Flag the oneliner for review. Open to anyone." - (if (flag-oneliner oneliner (request-contributor)) - "true" - (http-err 403))) - -(defendpoint* :get "/search" ((tags a-csl) - (limit an-int) - (notflagged a-boolean)) +(defendpoint* :put "/oneliner/:entry a-oneliner-id:/flag" ((token an-api-token)) + (:auth t) + "Flag the oneliner for review." + (when (and (lockedp entry) (not (adminp (api-contributor token)))) + (http-err 403)) + (flag-oneliner entry (api-contributor token)) + "true") + +(defendpoint* :get "/oneliners" ((tags a-csl) + (limit an-int) + (notflagged a-boolean)) () "A search endpoint returning a JSON encoded array of Oneliner Entries. TAGS cannot be empty. Returns a [Search @@ -556,7 +570,6 @@ Result](#search-result) object." (defun uuid () (format nil "~a" (uuid:make-v1-uuid))) - (defun oneliner-mentions-any (ol keywords) "A case insensitive search for the presence of any of KEYWORDS in the oneliner OL." (with-slots (text breif explanation) ol @@ -566,7 +579,6 @@ Result](#search-result) object." thereis (search word breif :test #'char-equal) thereis (search word explanation :test #'char-equal)))) - (defun to-json (thing) (let ((jonathan:*false-value* :false) (jonathan:*null-value* :null)) |