path: root/src/main.lisp

(defpackage oneliners.api
  (:use :cl)
  (:local-nicknames (#:lzb #:lazybones)
                    (#:a #:alexandria-2)
                    (#:db #:bknr.datastore))
  (:import-from #:lazybones
                #:defendpoint*
                #:http-ok
                #: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*
    (setf *server* (lzb:create-server :port port :address address))
    (lzb:set-canned-response *server* 400 "Bad Request" "text/plain")
    (lzb:set-canned-response *server* 404 "Not Found" "text/plain")
    (lzb:set-canned-response *server* 500 "Server Error" "text/plain")))

(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*)
  (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")

(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"
  t)

;;; ENDPOINT DEFINITIONS

(defendpoint* :get "/search" ()
  "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.
- 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**: either command or keywords are required.
"
  (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 "/oneliner/:oneliner object-with-id:" (:auth t)
  "Updates a oneliner entry in the wiki database."
  (cond
    (oneliner
     (update-oneliner oneliner (lzb:request-body))  ; throws an error if fails, triggering a 500
     (http-ok "true"))                               
    (t (http-err 404))))                ;no oneliner with the given id.

(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)))                            


(defendpoint* :post "/auth" ()
  "Requests an authorization token")

;;; HELPERS

(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 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-oneliner (oneliner json-body)
  "Accepts a decoded json body, a plist, and "
  (assert (valid-oneliner-update-data-p json-body))
  (list oneliner json-body)) ;; dummy implmenetation

(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-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