data classes defined

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