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
    :documentation "An invite code.")
   (from
    :reader invite-from
    :initarg :from
    :initform nil
    :index-type bknr.indices:hash-index
    :index-reader invites-by-contributor
    :documentation "Who created this invite.")
   (created-at
    :reader created-at
    :initform (get-universal-time)
    :documentation "When the invite was created. Used to determine invite expiration."))
  (:documentation "An invitation to create a new contributor on this server.")
  (:metaclass db:persistent-class))

(defun invite-expiration (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
    (json:write-key-value :code (invite-code invite))
    (when (invite-from invite)
      (json:write-key-value :from (contributor-handle (invite-from invite))))
    (json:write-key-value :expires (invite-expiration invite))))

(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
    :documentation "The contributor's name. Must be unique among all
    other contributor names.")
   (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.")
   (invites
    :accessor contributor-invites
    :initform (list :made 0  :redeemed 0 :limit 1)
    :documentation "A pair of integers (Invites Made . Invites Redeemed)")
   (adminp
    :accessor adminp
    :initform nil
    :documentation "indicates whether or not this contributor has admin privileges."))
  (:metaclass db:persistent-class))

(defun can-invite-p (contributor)
  "Returns T if the contributor is currently allowed to make more invites."
  (or (adminp contributor)
      (with-plist (limit made) (contributor-invites contributor)
                  (< made limit))))

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

(deftype runstyle ()
  `(member :auto :manual))

(defparameter +oneliner-brief-max-length+ 72)

(defclass oneliner (db:store-object)
  ((oneliner
    :accessor oneliner 
    :initarg :oneliner
    :initform (error "Onliner required"))
   (runstyle
    :accessor oneliner-runstyle
    :initarg :runstyle
    :initform :auto
    :type runstyle
    :documentation "If :manual, indicates that this oneliner is not suitable
    for running from within another process, and should be run
    directly. Hence, clients should copy the text of this oneliner to
    the clipboard if possible.  Examples include ncurses applications,
    applications making use of readline, or those require extensive
    user interaction.")
   (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.")
   (explanation
    :accessor oneliner-explanation
    :initarg :explanation
    :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 explanation
         created-at edited-at last-edited-by created-by
         flagged-by audited-by lockedp runstyle)
      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 :explanation explanation)
      (json:write-key-value :runstyle runstyle)
      (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 *server-domain* "localhost")
(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")
       (domain "localhost")
       store-dir)
  (setf *instance-salt* salt
        *server-domain* domain)
  (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"
  :prefix "/api"
  :desc +oneliners-description+
  :content-type "application/json"
  :auth 'api-token-authorization)

(defun api-token-authorization ()
  "This request must be made with an API access token."
  (request-contributor)) 


;;; DATABASE TRANSACTIONS

(defun make-new-invite (&optional contributor)
  "Make and  return a new invite object. "
  (db:with-transaction ()
    (if contributor
      (let ((invites (contributor-invites contributor)))
        (incf (getf invites :made))
        (setf (contributor-invites contributor) invites)
        (make-instance 'invite :from contributor))
      (make-instance 'invite))))

(defun redeem-invite (invite handle password)
  (db:with-transaction ()
    ;; make new user
    (with-slots (salt hashed-pw)  (make-instance 'contributor :handle handle)
      (setf hashed-pw (pw-hash password salt)))
    ;; increment the redeemed invite count on the contributor who made
    ;; it, if exists.
    (a:when-let (contributor (invite-from invite))
      ;; doing it this way b/c i'm not sure if the transaction log
      ;; would see (incf (getf (contributor-invites contributor) :redeemed))
      (let ((invites (contributor-invites contributor)))
        (incf (getf invites :redeemed))
        (setf (contributor-invites contributor) invites)))
    ;; finally, delete the invite.
    (db:delete-object invite)))


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

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

(defun make-new-oneliner (contributor &key oneliner tags brief explanation runstyle)
  (db:with-transaction ()
    (make-instance 'oneliner
                   :created-by contributor
                   :explanation (or explanation "")
                   :tags tags
                   :oneliner oneliner
                   :brief brief
                   :runstyle (if runstyle (a:make-keyword runstyle) :auto))))


(defun unflag-oneliner (oneliner)
  (db:with-transaction ()
    (setf (flagged-by oneliner) nil)))

(defun flag-oneliner (oneliner  contributor)
  (db:with-transaction ()
    (setf (flagged-by oneliner) contributor)))

(defun lock-oneliner (oneliner contributor)
  "Locks a oneliner. Only admins can lock and unlock."
  (when (adminp contributor)
    (db:with-transaction () 
      (setf (lockedp oneliner) t))))

(defun unlock-oneliner (oneliner contributor)
  "Unlocks a oneliner. Only admins can lock and unlock."
  (when (adminp contributor)
    (db:with-transaction () 
      (setf (lockedp oneliner) nil))))

(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

(defun oneliners-with-all-tags (tags)
  (reduce #'intersection (mapcar #'oneliners-by-tag tags)))

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


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


(defun a-oneliner-id (string)
  "An id of a oneliner entry "
  (a:if-let (oneliner (db:store-object-with-id (parse-integer string)))
    oneliner
    (http-err 404)))

(defun an-api-token (token)
  "An api token"
  (a:if-let (access (access-by-token token))
    access
    (http-err 404)))

;;; ENDPOINT DEFINITIONS

(defendpoint* :post "/invite/redeem/:code an-invite-code:" () ()
  "Redeem an [invite code](#invite-code) and create a new [contributor](#new-contributor-post-body)"
  (with-plist (password1 password2 handle) (lzb:request-body)
              (unless (equal password1 password2)
                (http-err 400 "Passwords dont match"))
              (when (contributor-by-handle handle)
                (http-err 403 (format nil "The name ~a is already taken." handle)))
              (redeem-invite code handle 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* :delete "/access/:access an-api-token:" ((token an-api-token))
  (:auth t)
  "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
have exceeded the invite limit."
  (a:when-let (contributor (and (api-token-authorization) (request-contributor)))
    (or (adminp contributor)
        (can-invite-p contributor))))

(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 (api-contributor token))))

(defun validate-new-oneliner-plist (plist)
  (with-plist
      (oneliner tags brief runstyle) plist
      (unless tags
        (http-err 400 "A oneliner requires tags"))
      (unless brief
        (http-err 400 "Oneliner requires a brief explanation"))
      (unless (<= (length brief) +oneliner-brief-max-length+)
        (http-err 400 "Brief description is too long. Limit to 75 characters")) 
      (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. Must be AUTO or MANUAL")))))

(defendpoint* :post "/oneliner" ((token an-api-token))
  (:auth t)
  "Make a new [oneliner](#oneliner)."
  (validate-new-oneliner-plist (lzb:request-body))
  (apply 'make-new-oneliner
         (api-contributor token)
         (lzb:request-body))

  "true")

(defun admin-only ()
  "The request requires an API access token. Only contributors with
admin privileges are allowed to perform this action."
  (a:when-let (contributor (request-contributor))
    (adminp contributor)))

(defendpoint* :put "/oneliner/:oneliner a-oneliner-id:/locked" ((token an-api-token)
                                                                (value a-boolean))
  (:auth 'admin-only)
  "Sets the locked value of the specified oneliner"
  (if value
      (lock-oneliner oneliner (api-contributor token))
      (unlock-oneliner oneliner (api-contributor token)))
  "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 "/oneliner/:entry a-oneliner-id:/edit" ((token an-api-token))
  (:auth t)
  "Edit the fields of a oneliner."
  (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* :put "/oneliner/:entry a-oneliner-id:/flag" ((token an-api-token)
                                                           (value a-boolean))
  (:auth t)
  "Flag the oneliner for review."
  (when (and (lockedp entry) (not (adminp (api-contributor token))))
    (http-err 403))
  (if value 
      (flag-oneliner entry (api-contributor token))
      (unflag-oneliner entry))
  "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
Result](#search-result) object."
  (if tags
      (to-json
       (list :oneliners (query-oneliners :tags tags
                                         :notflagged notflagged
                                         :limit limit))) 
      (http-err 400)))

;;; HELPERS

(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 explanation) ol
    (loop
      for word in keywords
      thereis (search word text :test #'char-equal)
      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))
    (jonathan:to-json thing)))

(defun request-contributor ()
  (a:when-let (access
               (access-by-token
                (lzb:request-parameter "TOKEN")))
    (api-contributor access)))