diff options
| -rw-r--r-- | clpmfile.lock | 10 | ||||
| -rw-r--r-- | src/main.lisp | 372 |
2 files changed, 336 insertions, 46 deletions
diff --git a/clpmfile.lock b/clpmfile.lock index e3fdf30..db2995d 100644 --- a/clpmfile.lock +++ b/clpmfile.lock @@ -67,7 +67,7 @@ ("jonathan" :version "2020-09-25" :source "quicklisp" :systems ("jonathan")) ("lambda-riffs" :version (:commit "f7b3c081f2361f7370c80e7ff4a432241f34ce55") :source :implicit-vcs :systems ("lambda-riffs")) -("lazybones" :version (:commit "aec0893df2f4bb8fa8da7c71cb8dca09c0bd5f86") +("lazybones" :version (:commit "5bf29467cae32ca2a2aba866a77c228e0b237e0e") :source :implicit-vcs :systems ("lazybones" "lazybones-hunchentoot")) ("lisp-namespace" :version "2021-10-21" :source "quicklisp" :systems ("lisp-namespace")) @@ -209,16 +209,12 @@ ("lambda-riffs" ((:system :name "oneliners.api") (:system :name "lambda-riffs")) - (t - (:project :name "lambda-riffs" :commit - "f7b3c081f2361f7370c80e7ff4a432241f34ce55" :source :implicit-vcs))) + (t (:project :name "lambda-riffs" :branch "master" :source :implicit-vcs))) ("lazybones" ((:system :name "oneliners.api") (:system :name "lazybones-hunchentoot")) ((:system :name "lazybones-hunchentoot") (:system :name "lazybones")) - (t - (:project :name "lazybones" :commit - "aec0893df2f4bb8fa8da7c71cb8dca09c0bd5f86" :source :implicit-vcs))) + (t (:project :name "lazybones" :branch "master" :source :implicit-vcs))) ("lisp-namespace" ((:system :name "lazybones") (:system :name "lisp-namespace"))) diff --git a/src/main.lisp b/src/main.lisp index 8d01e4a..1411aa1 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -1,7 +1,7 @@ (defpackage oneliners.api (:use :cl) (:local-nicknames (#:lzb #:lazybones) - (#:a #:alexandria) + (#:a #:alexandria-2) (#:db #:bknr.datastore)) (:import-from #:lazybones #:defendpoint* @@ -9,9 +9,170 @@ #:http-err)) (in-package :oneliners.api) +;;; DATA + +(defclass contributor (db:store-object) + ((handle + :accessor contributor-handle + :initarg :handle + :initform (error "Contributors must have a name.") + :index-type bknr.indices:string-unique-index + :index-reader contributor-by-handle) + (contributor-salt + :reader contributor-salt + :initform (uuid) + :type string + :documentation "Per user salt for password hashing.") + (hashed-pw + :accessor hashed-pw + :initform nil + :type string + :documentation "Hashed password for this contributor. Note, this + value is hashed with the server salt and the contributor-salt.")) + (:metaclass db:persistent-class)) + +(defclass api-access (db:store-object) + ((token + :reader api-token + :initarg :token + :index-type bknr.indices:string-unique-index + :index-reader access-by-token) + (contributor + :reader api-contributor + :initarg :contributor + :index-type bknr.indices:unique-index + :index-reader access-by-contributor)) + (:metaclass db:persistent-class)) + +(defgeneric revoke-access (what) + (:documentation "Effectively deletes an api-access instance.") + (:method ((access api-access)) + (db:with-transaction () + (db:delete-object access))) + (:method ((token string)) + (a:when-let ((access (access-by-token token))) + (revoke-access access))) + (:method ((contributor contributor)) + (a:when-let ((access (access-by-contributor contributor))) + (revoke-access access)))) + +(defclass oneliner (db:store-object) + ((text + :accessor oneliner-text + :initarg :oneliner + :initform (error "Onliner required")) + (command + :accessor oneliner-command + :initarg :command + :index-type bknr.indices:hash-index + :index-initargs (:test 'equal) + :index-reader oneliners-by-command) + (brief + :accessor oneliner-brief + :initarg :brief + :initform "" + :documentation "A short description of the oneliner.") + (description + :accessor oneliner-description + :initarg :description + :initform "") + (created-at + :reader created-at + :initform (get-universal-time)) + (edit-history + :accessor edit-history + :initform nil + :documentation "A list of (WHO WHEN WHAT)") + (flagged-by + :accessor flagged-by + :initform nil + :documentation "NIL or :anonymous or a CONTRIBUTOR object.") + (audited-by + :accessor audited-by + :initform nil + :documentation "NIL or a CONTRIBUTOR object. Indicates that a user + has approved of this oneliner.")) + (:metaclass db:persistent-class)) + +(defclass query-results-page (db:store-object) + ((limit + :initarg :limit) + (to-page + :initarg :to-page) + (remaining + :initarg :remaining) + (last-access + :initarg :last-access) + (key + :initarg key + :index-type bknr.indices:string-unique-index + :index-reader page-by-key)) + (:metaclass db:persistent-class)) + +(defun make-next-page (limit to-page) + (let ((key (uuid))) + (make-instance 'query-results-page + :key key + :limit limit + :to-page to-page + :remaining (length to-page) + :last-access (get-universal-time)) + key)) + +(defun fetch-next-page (pagekey &key (attrib-name :oneliners)) + "Return next page in a search query, or throw an error if there is + no such page / the page has expired." + (a:if-let (qrp (page-by-key pagekey)) + (db:with-transaction () + (with-slots (limit to-page remaining last-access) qrp + (let* ((n-to-send (min limit remaining)) + (to-return (subseq to-page 0 n-to-send))) + (decf remaining n-to-send) + (if (plusp remaining) + (setf to-page (nthcdr n-to-send to-page) + last-access (get-universal-time)) + (db:delete-object qrp)) + (list :page (if (plusp remaining) pagekey :null) + attrib-name to-return)))) + (error "No page for key ~a" pagekey))) + +(defparameter +qrp-lifetime+ 300 ; five minutes + "Number of seconds query-results-page instances live in the + application state.") + +(defun expired-page-p (qrp &optional (current-time (get-universal-time))) + (when (typep qrp 'query-results-page) + (> (- current-time (slot-value qrp 'last-access)) + +qrp-lifetime+))) + + ;;; SERVICE CONTROL (defvar *server* nil) +(defvar *cleaning-thread* nil) +(defvar *runningp* nil) +(defvar *instance-salt* "change me") + +(defparameter +data-store-directory-name+ + "onliners-api-datastore") + + + +(defun data-store-path (store-dir) + (let ((store-dir (or store-dir (pathname-directory (user-homedir-pathname))))) + (make-pathname + :directory (append store-dir (list +data-store-directory-name+))))) + +(defun initialize-datastore (store-dir) + (ensure-directories-exist (data-store-path store-dir)) + (make-instance + 'db:mp-store + :directory (data-store-path store-dir) + :subsystems (list (make-instance 'db:store-object-subsystem)))) + +(defun ensure-datastore (store-dir) + (unless (boundp 'db:*store*) + (initialize-datastore store-dir))) (defun ensure-server (port address) (unless *server* @@ -20,26 +181,57 @@ (lzb:set-canned-response *server* 404 "Not Found" "text/plain") (lzb:set-canned-response *server* 500 "Server Error" "text/plain"))) -(defun start (&optional (port 8888) (address "127.0.0.1")) +(defun start + (&key + (port 8888) + (address "127.0.0.1") + (salt "change me") + store-dir) + (setf *instance-salt* salt ) + (ensure-datastore store-dir) (ensure-server port address) (lzb:install-app *server* (lzb:app)) - (lzb:start-server *server*)) + (lzb:start-server *server*) + (setf *runningp* t) + (start-cleaning-thread)) + +(defun start-cleaning-thread (&key (run-period 45)) + ;; thread not stopped properly. + (when (and *cleaning-thread* (bt:thread-alive-p *cleaning-thread*)) + (bt:destroy-thread *cleaning-thread*)) + (setf *cleaning-thread* + (bt:make-thread + (lambda () + (loop while *runningp* + do (handler-case (routine-cleaning) + (error (e) (print e))) + (sleep run-period)))))) (defun stop () + (setf *runningp* nil) (when *server* (lzb:stop-server *server*))) +(defun routine-cleaning () + (let ((now (get-universal-time))) + (db:with-transaction () + (dolist (qrp (db:store-objects-with-class 'query-results-page)) + (when (expired-page-p qrp now) + (db:delete-object qrp)))))) + + ;;; API DEFINITION AND PROVISIONING (defparameter +oneliners-description+ "TBD") -(lzb:provision-app () - :title "Oneliners Wiki API" - :version "0.0.1" - :desc +oneliners-description+ - :content-type "application/json" - :auth 'api-token-authorization) +(defun init-app () + (lzb:provision-app () + :title "Oneliners Wiki API" + :version "0.0.1" + :desc +oneliners-description+ + :content-type "application/json" + :auth 'api-token-authorization)) (defun api-token-authorization () "TBD" @@ -48,32 +240,67 @@ ;;; ENDPOINT DEFINITIONS (defendpoint* :get "/search" () - "A search endpoint returning a JSON encoded array of Command Entries. + "A search endpoint returning a JSON encoded array of Oneliner Entries. /search accepts the following query parameters: -- command : The name of a command. E.g. `ls`, `grep`, `netcat`. -- keywords : A comma-separated list of words that may appear in the title or description of a command entry, e.t. `'foo,bar,goo,zar,moo_blar' -- limit : An integer, limiting the number of results returned. Defaults to 10. -- recent : 0 for false 1 for true; sorts results by how recently they were added. Defaults to 0. -- nextpage : 0 for false 1 for true; requests that the query be accompanied by a nextpage key -- page : a nextpage token that will continue from a previous search. These expire after 10 minutes. +- command : The name of a command. E.g. `ls`, `grep`, `netcat`. +- keywords : A comma-separated list of words that may appear in the title or description of a command entry, e.t. `'foo,bar,goo,zar,moo_blar' +- limit : An integer, limiting the number of results returned. Defaults to 10. +- nextpage : true or false; requests that the query be accompanied by a nextpage key +- page : a nextpage token that will continue from a previous search. These expire after 10 minutes. +- notFlagged : true or false; defaults to false. true filters out oneliners that have been flagged. +- onlyAudited : true or false; defaults to false. true filters out oneliners that have not been audited. -**Note** that either `command` or `keyword` parameters are required. +**Note**: either command or keywords are required. " - (http-ok "[]")) + (lzb:map-parameters + ((command identity) + (keywords parse-cls) + (limit parse-integer) + (nextpage true-or-false) + (page identity) + (notflagged true-or-false) + (onlyaudited true-or-false)) + (cond + ;; if page is incluced, ignore everything, fetch the next page, and return it. + (page + (http-ok (to-json (fetch-next-page page)))) + + ;; otherwise one of command keywords are required + ((or command keywords) + (let* ((limit + (or limit 10)) + (results + (query-oneliners :command command + :keywords keywords + :notflagged notflagged + :onlyaudited onlyaudited)) + (limited-results + (if (> limit (length results)) results + (subseq results 0 limit)))) + (http-ok + (to-json + (if nextpage + (list + :page (make-next-page limit (nthcdr limit results)) + :oneliners limited-results) + (list :oneliners limited-results)))))) + ;; if neither was supplied, return a 400 + (t + (http-err 400))))) -(defendpoint* :put "/command/:command command-by-id:" (:auth t) - "Updates a command entry in the wiki database." +(defendpoint* :put "/oneliner/:oneliner object-with-id:" (:auth t) + "Updates a oneliner entry in the wiki database." (cond - (command - (update-commmand command (lzb:request-body)) ; throws an error if fails, triggering a 500 + (oneliner + (update-oneliner oneliner (lzb:request-body)) ; throws an error if fails, triggering a 500 (http-ok "true")) - (t (http-err 404)))) ;no command with the given id. + (t (http-err 404)))) ;no oneliner with the given id. -(defendpoint* :post "/command" (:auth t) - "Adds a new command entry to the wiki database." - (a:if-let (new-command (add-command-to-db (lzb:request-body))) +(defendpoint* :post "/oneliner" (:auth t) + "Adds a new oneliner entry to the wiki database." + (a:if-let (new-oneliner (add-oneliner-to-db (lzb:request-body))) (http-ok "{}") ; dummy implementation (http-err 400))) @@ -83,26 +310,93 @@ ;;; HELPERS -(defun command-by-id (id-string) - "An integer id of a command." - (list :a-dummy-command id-string)) +(defun slot-name-of (class name) + "Returns the symbol naming a slot in the class class. Returns NIL if +there is no such slot. Useful for converting keywords into slot +names. NAME must be a symbol or a string." + (assert (or (stringp name) (symbolp name))) + (let ((name (if (symbolp name) (symbol-name name) name))) + (loop for slot-def in (closer-mop:class-slots (find-class class)) + for slot-name = (closer-mop:slot-definition-name slot-def) + when (string-equal name (symbol-name slot-name)) + return slot-name))) -(defun valid-command-update-data-p (jsonplist) - "Checks the fields of jsonplist, return t if they are sufficient to update a command entry." +(defun object-with-id (id-string) + "Integer id of the entity desired." + (db:store-object-with-id (parse-integer id-string))) + +(defun valid-oneliner-update-data-p (jsonplist) + "Checks the fields of jsonplist, return t if they are sufficient to update a oneliner entry." jsonplist);; dummy implementation -(defun update-commmand (command json-body) +(defun update-oneliner (oneliner json-body) "Accepts a decoded json body, a plist, and " - (assert (valid-command-update-data-p json-body)) - (list command json-body)) ;; dummy implmenetation + (assert (valid-oneliner-update-data-p json-body)) + (list oneliner json-body)) ;; dummy implmenetation -(defun valid-command-init-data-p (plist) - "dchecks the fields in plist,returns t if they are sufficient to create a new command." +(defun valid-oneliner-init-data-p (plist) + "dchecks the fields in plist,returns t if they are sufficient to create a new oneliner." plist);; dummy implementation -(defun add-command-to-db (json-plist) - "adds a new command to the database, returning it upon success " - (assert (valid-command-init-data-p json-plist)) +(defun add-oneliner-to-db (json-plist) + "adds a new oneliner to the database, returning it upon success " + (assert (valid-oneliner-init-data-p json-plist)) :dummy-ok) +(defun pw-hash (plaintext salt) + (flexi-streams:octets-to-string + (ironclad:digest-sequence + :sha3 + (flexi-streams:string-to-octets (concatenate 'string salt plaintext) :external-format :utf-8)) + :external-format :latin1)) + +(defun uuid () + (format nil "~a" (uuid:make-v1-uuid))) + + +(defun parse-cls (s) + "parse comman separated list." + (mapcar #'str:trim (str:split "," s))) + + +(defun parse-true-or-false (s) + (cond ((string-equal s "true") t) + ((string-equal s "false") nil) + (t (error "String ~s is neither 'true' nor 'false'" s)))) + +(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 description) ol + (loop + for word in keywords + thereis (search word text :test #'char-equal) + thereis (search word breif :test #'char-equal) + thereis (search word description :test #'char-equal)))) + +(defun query-oneliners (&key command keywords notflagged onlyaudited) + (if command + (remove-if-not + #$(and (not (and notflagged (flagged-by $ol))) + (or (not onlyaudited) (audited-by $ol)) + (or (null keywords) (oneliner-mentions-any $ol keywords))) + (oneliners-by-command command)) + (remove-if-not + #$(and (not (and notflagged (flagged-by $ol))) + (or (not onlyaudited) (audited-by $ol)) + (or (not command) (string-equal command (oneliner-command $ol)))) + (oneliners-from-keywords keywords)))) + +(defun oneliners-from-keywords (keywords) + (error "TBD")) + + + + + +(defun to-json (thing) + (let ((jonathan:*false-value* :false) + (jonathan:*null-value* :null)) + (jonathan:to-json thing))) + +;;; RESULTS PAGES |