path: root/src/main.lisp

(in-package :oneliners.api)

;;; DATA DEFINITIONS

(defclass invite (db:store-object)
  ((code
    :reader invite-code
    :initform (uuid)
    :index-type bknr.indices:string-unique-index
    :index-reader invite-by-code)
   (from
    :reader invite-from
    :initarg :from)
   (created-at
    :reader created-at
    :initform (get-universal-time)))
  (:metaclass db:persistent-class))

(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)
   (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.")
   (adminp
    :accessor adminp
    :initform nil
    :documentation "indicates whether or not this contributor has admin privileges."))
  (:metaclass db:persistent-class))

(defparameter +auth-cookie-name+ "olauthtoken")

(defclass api-access (db:store-object)
  ((token
    :reader api-token
    :initform (uuid)    
    :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)
  ((oneliner
    :accessor oneliner 
    :initarg :oneliner
    :initform (error "Onliner required"))
   (tags
    :accessor oneliner-tags
    :initarg :tags
    :initform nil
    :index-type bknr.indices:hash-list-index 
    :index-initargs (:test 'equal)
    :index-reader oneliners-by-tag
    :documentation "The commands that this oneliner principally involves.")
   (brief
    :accessor oneliner-brief
    :initarg :brief
    :initform (error "Oneliners need a brief title")
    :documentation "A short description of the oneliner.")
   (description
    :accessor oneliner-description
    :initarg :description
    :initform "")
   (created-by
    :reader created-by
    :initform (error "oneliners must be made by a contributor")
    :initarg :created-by)
   (created-at
    :reader created-at
    :initform (get-universal-time))
   (edited-at
    :accessor edited-at
    :initform nil
    :documentation "A universal time recording the last time of edit")
   (last-edited-by
    :accessor last-edited-by
    :initform nil
    :documentation "a contributor instance, the last person to edit thiscommand.")
   (flagged-by
    :accessor flagged-by
    :initform nil
    :documentation "NIL or :anonymous or a CONTRIBUTOR object.")
   (lockedp
    :accessor lockedp
    :initform nil
    :documentation "Prevents editing until unliked. Only users with
    admin priviliges can lock/unlock."))
  (:metaclass db:persistent-class))

(defmethod json:%to-json ((instance oneliner))
  (with-slots
        (db::id oneliner tags brief description
         created-at edited-at last-edited-by created-by
         flagged-by audited-by lockedp)
      instance
    (json:with-object
      (json:write-key-value "id" db::id)
      (json:write-key-value "oneliner" oneliner)
      (json:write-key-value "tags" tags)
      (json:write-key-value "brief" brief)
      (json:write-key-value "description" description)
      (json:write-key-value "createdAt" created-at)
      (json:write-key-value "editedAt" (if edited-at edited-at :null))
      (json:write-key-value "createdBy" (contributor-handle created-by))
      (json:write-key-value "isFlagged" (if (not (null flagged-by)) t :false))
      (json:write-key-value "isLocked" (if lockedp t :false)))))



;;; SERVICE CONTROL

(defvar *server* nil)
(defvar *cleaning-thread* nil)
(defvar *runningp* nil)
(defvar *instance-salt* "change me"
  "This is salt used for password hashing and login recovery")

(defparameter +data-store-directory-name+
  "oneliners-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))
    (set-canned-responses)))

(defun set-canned-responses ()
  (lzb:set-canned-response *server* 400 "Bad Request" "text/plain")
  (lzb:set-canned-response *server* 401 "Unauthorized" "text/plain")
  (lzb:set-canned-response *server* 403 "Forbidden" "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 3600))
  ;; when the thread  was 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 (sleep run-period)
                    (handler-case (routine-cleaning)
                      (error (e) (print e))))))))

(defun stop ()
  (setf *runningp* nil)
  (when *server*
    (lzb:stop-server *server*)))

(defparameter +invite-lifetime+ (* 60 60 24)
  "Invites expire after 24 hours")

(defun expired-invite-p (invite &optional (current-time (get-universal-time)))
  (> (- current-time (created-at invite))
     +invite-lifetime+))

(defun routine-cleaning ()
  (let ((now (get-universal-time))) 
    (a:when-let (expired-invites
                 (remove-if-not #$(expired-invite-p $invite now) (db:store-objects-with-class 'invite)))
      (db:with-transaction ()
        (mapc #'db:delete-object expired-invites)))))


;;; 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 api-token-authorization ()
  ;; presently if the token merely exists then that's good enough.
  (request-contributor)) 


;;; DATABASE TRANSACTIONS

(defun redeem-invite (invite handle password)
  (db:with-transaction ()
    (with-slots (salt hashed-pw)  (make-instance 'contributor :handle handle)
      (setf hashed-pw (pw-hash password salt)))
    (db:delete-object invite)))


(defun make-api-access (contributor)
  (db:with-transaction ()
    (make-instance 'api-access :contributor contributor)))

(defun make-new-oneliner (contributor plist)
  (with-plist
      (oneliner tags brief description) plist
      (unless brief
        (http-err 400 "Oneliner requires a breif description"))
      (unless oneliner
        (http-err 400 "Oneliner cannot be blank"))

      (db:with-transaction ()
        (make-instance 'oneliner
                       :created-by contributor
                       :description (or description "")
                       :tags tags
                       :oneliner oneliner
                       :brief brief))))

(defun query-oneliners (&key tags notflagged limit)
  ;; inefficient but easy to express 
  (let ((ols (oneliners-with-all-tags tags)))
    (a:subseq* (if notflagged
                   (remove-if #'flagged-by ols)
                   ols)
               0 (or limit 10))))


;;; ROUTE VARIABLE AND PARAMATER PARSERS

(defun an-int (string)
  "An Integer"
  (parse-integer string))

(defun a-string (string)
  "A String"
  string)

(defun a-csl (s)
  "A list of strings separated by commas. e.g. \"foo,bar,goo\""
  (mapcar #'str:trim (str:split "," s)))

(defun a-boolean (s)
  "Either \"true\" or \"false\"/"
  (cond ((string-equal s "true") t)
        ((string-equal s "false") nil)
        (t (error "String ~s is neither 'true' nor 'false'" s))))

(defun a-page-key (key)
  "A page key"
  key)

(defun an-invite-code (code)
  "An invite code."
  (a:if-let (invite (invite-by-code code))
    invite
    (http-err 404)))

(defun a-user-handle (handle)
  "A Contributor's Handle"
  (a:if-let (contributor (contributor-by-handle handle))
    contributor
    (http-err 404)))

(defun a-short-string (string)
  "A string at most 50 characters in  length"
  (when (< 50 (length string))
    (http-err 400 "String Too Long"))
  string)


;;; ENDPOINT DEFINITIONS

(defendpoint* :post "/redeem/:invite an-invite-code:"
  ((username a-string)
   (password1 a-string)
   (password2 a-string))
  ()
  "Redeem an invite code"
  (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 "/request-token/:contributor a-user-handle:"
  ((password a-string))
  ()
  "Authenticate a user and reply with an api token"
  (cond ((equal (pw-hash password (contributor-salt contributor))
                (hashed-pw contributor))
         (to-json 
          (a:if-let (access (access-by-contributor contributor))
            (list :token (api-token access))         ; return extant tokens
            (list :token (api-token (make-api-access contributor)))))) ; or make a new one 
        (t
         (http-err 401))))

(defendpoint* :post "/add-oneliner" ()
  (:auth t)
  (make-new-oneliner (request-contributor)  (lzb:request-body))
  "true")

(defendpoint* :get "/search" ((tags a-csl)
                              (limit an-int)
                              (notflagged a-boolean))
  ()
  "A search endpoint returning a JSON encoded array of Oneliner Entries.

**Note**: either command or keywords are required.
"
  (if tags
      (to-json
       (list :oneliners (query-oneliners :tags tags
                                         :notflagged notflagged
                                         :limit limit))) 

      (t                                  ; else responde with 400
       (http-err 400))))

;;; 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 initarg-keyword (thing)
  (a:make-keyword
   (string-upcase
    (if (symbolp thing) (symbol-name thing) thing))))

(defun json-plist->initarg-keywords (plist)
  (loop for (k v . more) on plist by #'cddr
        collect (initarg-keyword k)
        collect v))

(defun object-with-id (id-string)
  "Integer id of the desired entity.."
  (db:store-object-with-id (parse-integer id-string)))

(defparameter +updatable-oneliner-slot-keywords+
  '(:|oneliner| :|commands| :|brief| :|description|))

(defun valid-oneliner-update-data-p (jsonplist)
  "Checks the fields of jsonplist, return t if they are sufficient to update a oneliner entry."
  (loop for (k v . more) on jsonplist by #'cddr
        always (member k +updatable-oneliner-slot-keywords+)))

(defun update-oneliner (contributor oneliner json-body)
  "Accepts a decoded json body, a plist, and "
  (assert (valid-oneliner-update-data-p json-body))
  (db:with-transaction ()
    (loop for (k v . more) on json-body
          do (setf (slot-value oneliner (slot-name-of 'oneliner k)) v))
    (setf (edit-history oneliner) (get-universal-time))))

(defun valid-oneliner-init-data-p (plist)
  "dchecks the fields in plist,returns t if they are sufficient to create a new oneliner."
  ;; right now, just aliasing valid-oneliner-update-data-p
  (valid-oneliner-update-data-p plist))

(defun add-oneliner-to-db (contributor json-plist)
  "adds a new oneliner to the database, returning it upon success "
  (assert (valid-oneliner-init-data-p json-plist))
  (db:with-transaction ()
    (apply 'make-instance 'oneliner
           :created-at (get-universal-time)
           :created-by contributor
           (json-plist->initarg-keywords json-plist))))

(defun pw-hash (plaintext salt)
  "Hash plaintext using SALT and the value of *INSTANCE-SALT*"
  (flexi-streams:octets-to-string 
   (ironclad:digest-sequence
    :sha3
    (flexi-streams:string-to-octets (concatenate 'string *instance-salt* salt plaintext)
                                    :external-format :utf-8))
   :external-format :latin1))

(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 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 oneliners-with-all-tags (tags)
  (reduce #'intersection (mapcar #'oneliners-by-tag tags)))


(defun to-json (thing)
  (let ((jonathan:*false-value* :false)
        (jonathan:*null-value* :null))
    (jonathan:to-json thing)))

(defun request-contributor ()
  (a:when-let (access (access-by-token (lzb:request-cookie +auth-cookie-name+)))
    (api-contributor access)))