path: root/src/main.lisp

;;;; main-lisp 

;; Copyright (C) 2022  Colin Okay

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(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.")
   (signature
    :accessor contributor-signature
    :initarg :signature
    :initform nil
    :documentation "A short piece of contributor flair. May contain a url.")
   (salt
    :reader contributor-salt
    :initform (uuid)
    :type string
    :documentation "Per contributor 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 PLIST representing invites made by this
    contributor, the number of thos that ahve been redeemed, and the
    limit on the number of invites that the contributor can make")
   (adminp
    :accessor adminp
    :initform nil
    :documentation "indicates whether or not this contributor has admin privileges.")
   (lockedp
    :accessor contributor-lockedp
    :initform nil
    :documentation "indicates that this contributor is currently banned from editing."))
  (: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))))

(defmethod json:%to-json ((obj contributor))
  (json:with-object
    (json:write-key-value "HANDLE" (contributor-handle obj))
    (json:write-key-value "SIGNATURE" (contributor-signature obj))))


(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 "Oneliner required"))
   (name
    :accessor oneliner-name
    :initarg :name
    :initform nil
    :index-type bknr.indices:string-unique-index 
    :index-reader oneliner-by-name
    :documentation "A unique name for this oneliner.")
   (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
    contributor 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 a CONTRIBUTOR object.")
   (lockedp
    :accessor lockedp
    :initform nil
    :documentation "Prevents editing until unlocked. Only contributors 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 name)
      instance
    (json:with-object
      (json:write-key-value :id db::id)
      (json:write-key-value :name (if name name :false))
      (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)))))

;;; CACHES


(defvar *newest-cache-size* 20)
(defvar *newest-cache* nil
  "A cache of the newest oneliners")

;;; 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 +default-config-file+
  #+linux "/etc/oneliners/oneliners-conf.lisp")

(defparameter +data-store-directory-name+
  "oneliners-api-datastore")

(defun data-store-path (store-dir)
  (let ((store-dir
          (pathname-directory 
           (if store-dir store-dir (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 salt-from-file (path)
  "Get server salt from a file, making one if not already extant. It
is recommended to keep this file somewhere other than the host where
you are running this instance.. You will need it to allow people to
obtain new tokens or to change their passwords for their contributor
accounts. So keep it secret, keep it safe."
  (unless (uiop:file-exists-p path)
    (a:write-string-into-file
         (uuid)
         path))
  (a:read-file-into-string path))


(defun make-admins-from-file (path)
  (if (uiop:file-exists-p path)
      (let ((admins (with-open-file (input path) (read input))))
        (assert (every #$(and (= 2 (length $admin)) (every 'stringp $admin)) admins)
                () "Admins file formatted incorrectly. It should be a list of pairs of strings ((name pw) (name pw) ...)")
        (loop for (name pass) in admins
              unless (contributor-by-handle name)
                do (make-new-admin-contributor name pass)
              else
                do (format *error-output* "Did not make admin ~a." name)))
      (format *error-output*
              "Though an admins file ~s was specified, it was not found on disk.~%"
              path)))

(defun start-from-config (&optional (config-file +default-config-file+))
  "A config file should contain a single PLIST, specifying several
options:

:PORT :ADDRESS :DOMAIN :STORE-DIR are all passed to START as-is.

:SALT-FILE should be a path to a location on disk both readible and
writable by the current process. This file contains the server salt,
used to generate password hashes (along with contributor-salt).  If a
file at this location does not exist, it will be created.  You should
store this file somewhere besides the server after starting up, or you
should ensure that this process, and only this process, has read/write
access to it.

:INIT-ADMINS-FILE should be a file that contains a list of pairs of
strings. This list is interpeted to be ((HANDLE1 PW1) (HANDLE2 PW2)
...)  for admin contributors for this server. This file will be read and the
contributors will be made. You should destroy this file after the initial
boot up, subsequent boots will not need it, even if it remains
mentioned in th config file.

:SWANK-PORT should be a port number (or absent). When present the
startup process attempts to start as swank server on the provided port.

"
  (handler-case
      (progn 
        (assert (uiop:file-exists-p config-file))
        (let ((config 
                (with-open-file (input config-file)
                  (read input))))
          (with-plist
              (port address salt-file domain store-dir init-admins-file swank-port) config
            ;; when swhank port, start swank
            (when swank-port
              (bt:make-thread
               (lambda ()
                 (swank:create-server
                  :port swank-port
                  :dont-close t))))
            
            ;; start the server with options in the config.
            (apply 'start
                   (nconc  
                    (when port (list :port port))
                    (when salt-file
                      (list :salt (salt-from-file salt-file)))
                    (when address (list :address address))
                    (when domain (list :domain domain))
                    (when store-dir (list :store-dir store-dir))))
              ;; make any admins listed.
              (when init-admins-file
                (make-admins-from-file init-admins-file)))))
    (error (err)
      (format t "Caught error ~a~%" err))))

(defun start
    (&key
       (port 8888)
       (address "127.0.0.1")
       salt
       (domain "localhost")
       store-dir)
  (assert salt)
  (setf *instance-salt* salt
        *server-domain* domain)
  (ensure-datastore store-dir)
  (ensure-server port address)
  (lzb:install-app *server* (lzb:app 'oneliners.api::oneliners.api))
  (lzb:start-server *server*)
  (setf *runningp* t)
  (start-cleaning-thread)
  (format t "STARTED~%"))


(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.2.0"
  :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."
  (a:when-let (contributor (request-contributor))
    (or (not (contributor-lockedp contributor))
        (adminp contributor)))) 


;;; DATABASE TRANSACTIONS

(defun delete-oneliner (oneliner)
  (db:with-transaction ()
    (db:delete-object oneliner)))

(defun update-password (contributor new-password)
  (db:with-transaction () 
    (with-slots (salt hashed-pw) contributor
      (setf hashed-pw (pw-hash new-password salt)))))

(defun set-contributor-locked (contributor value)
  "Lock / unlock a contributor account"
  (db:with-transaction ()
    (setf (contributor-lockedp contributor) value)))

(defun set-signature (contributor signature)
  "Set signature"
  (db:with-transaction ()
    (setf (contributor-signature contributor) signature)))

(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 &optional sig)
  (db:with-transaction ()
    ;; make new contributor
    (with-slots (salt hashed-pw signature)  (make-instance 'contributor :handle handle)
      (setf hashed-pw (pw-hash password salt))
      (when sig
        (setf signature sig)))
    ;; 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-new-admin-contributor (handle password)
  (db:with-transaction ()
    (with-slots (salt hashed-pw adminp) (make-instance 'contributor :handle handle)
      (setf hashed-pw (pw-hash password salt)
            adminp t))))

(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 name)
  (a:when-let
      ((ol 
        (db:with-transaction ()
          (make-instance 'oneliner
                         :created-by contributor
                         :explanation (or explanation "")
                         :tags tags
                         :oneliner oneliner
                         :brief brief
                         :name name
                         :runstyle (if runstyle (a:make-keyword runstyle) :auto)))))
    (setf *newest-cache*
          (if (< (length *newest-cache*) *newest-cache-size*)
              (cons ol *newest-cache*) 
              (cons ol (drop-last *newest-cache*))))
    ol))

(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 name)
  "Assumes each param, where given, has been validated."
  (db:with-transaction ()
    (setf (last-edited-by ol) contributor)
    (when name
      (setf (oneliner-name ol) name))
    (when oneliner
      (setf (oneliner ol) oneliner))
    (when tags
      (setf (oneliner-tags ol) (remove-duplicates tags :test #'equal)))
    (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 newest-oneliners (&optional limit)
  (cond
    ((and *newest-cache* (<= limit (length *newest-cache*)))
     (a:subseq* *newest-cache* 0 limit))
    (t
     (let (newest) 
       (loop
         for ol in (db:store-objects-with-class 'oneliner)
         when (< (length newest) limit)
           do (setf newest (sort (cons ol newest) #'> :key #'created-at))
         when (> (created-at ol) (created-at (first newest)))
           do (setf newest
                    (cons ol (drop-last newest))))
       (setf *newest-cache*
             (a:subseq* newest 0 *newest-cache-size*))
       newest))))


(defun flagged-oneliners (&optional limit)
  (loop
    for idx from 0
    for ol in (db:store-objects-with-class 'oneliner)
    while (or (not limit) (< idx limit))
    when (flagged-by ol)
      collect ol))

(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-contributor-by-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 or name of a oneliner"
  (a:if-let (oneliner (or
                       (db:store-object-with-id (parse-integer string :junk-allowed t))
                       (oneliner-by-name 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)))

;;; SOME PREDICATES

(defparameter +compiled-tag-and-handle-re+
  (ppcre:create-scanner  "^[a-z0-9_\-]+$"
                         :single-line-mode t
                         :case-insensitive-mode t))

(defun valid-tag-p (tag)
  (and (stringp tag)
       (<= (length tag) 20)
       (ppcre:scan +compiled-tag-and-handle-re+ tag)))

(defun valid-contributor-handle-p (handle)
  (and (stringp handle)
       (<= 3 (length handle) 15)
       (ppcre:scan +compiled-tag-and-handle-re+ handle)))

(defun valid-signature-p (signature)
  (and (stringp signature)
       (<= (length signature) +oneliner-brief-max-length+)))

(defun is-current-password-p (contributor pw)
  (with-slots (salt hashed-pw) contributor
      (equal hashed-pw (pw-hash pw salt))))

;;; ENDPOINT DEFINITIONS

(defendpoint* :post "/snapshot" ((token an-api-token))
  (:auth 'admin-only)
  "Snapshot the datastore. Do this after upgrade"
  (db:snapshot)
  "ok")

(defendpoint* :get "/contributor/:who a-contributor-by-handle:" () ()
  "Return a [contributor](#contributor) data object."
  (to-json who))

(defendpoint* :put "/contributor/:who a-contributor-by-handle:/locked" ((value a-boolean)
                                                                        (token an-api-token))
  (:auth 'admin-only)
  "Admin users may lock a particular contributor, preventing that
contributor for making edits or adding new oneliners."
  (set-contributor-locked who value)
  "true")

(defendpoint* :put "/contributor/:who a-contributor-by-handle:/password" ((value a-string)
                                                                          (repeated a-string)
                                                                          (current a-string)
                                                                          (token an-api-token))
  (:auth t)
  "Change a contributor's password. CURRENT is the current
password. VALUE is the new password. REPEATED must match VALUE. TOKEN
is an API Access token."
  (unless (or (eq who (api-contributor token))
              (adminp (api-contributor token)))
    (http-err 403 "Cannot change that password."))
  (unless (or (adminp (api-contributor token))
              (is-current-password-p who current))
    (http-err 400 "The old password is incorrect"))
  (unless (equalp value repeated)
    (http-err 400 "The two passwords do not match."))
  (update-password who value)
  "true")

(defendpoint* :put "/contributor/:who a-contributor-by-handle:/signature" ((token an-api-token))
  (:auth t)
  "Update a [contributor's](#contributor) signature."
  (unless (or (eq who (api-contributor token))
              (adminp (api-contributor token)))
    (http-err 403))
  (with-plist (signature) (lzb:request-body)
              (unless (valid-signature-p signature)
                (http-err 400 "Bad signature"))
              (set-signature who signature)
              "true"))

(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 signature) (lzb:request-body)
              (unless (equal password1 password2)
                (http-err 400 "Passwords dont match"))
              (unless (valid-contributor-handle-p handle)
                (http-err 400 (format nil "~a is not a valid contributor handle." handle)))
              (when (contributor-by-handle handle)
                (http-err 403 (format nil "The name ~a is already taken." handle)))
              (redeem-invite code handle password1 signature)
              "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)))

;TODO: Might rewrite this to be by user-name
(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))))

(defparameter +explanation-wordcount-limit+ 549)

(defun validate-new-oneliner-plist (plist)
  (with-plist
      (oneliner tags brief runstyle explanation) plist
      (unless tags
        (http-err 400 "A oneliner requires tags"))
      (unless (every 'valid-tag-p tags)
        (http-err 400 "Some tags are malformed."))
      (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 explanation
        (unless (<= (count #\space explanation) +explanation-wordcount-limit+)
          (http-err 400 "Explanation is too long. Limit to around 550 words.")))
      (when runstyle
        (setf runstyle (a:make-keyword runstyle))
        (unless (typep runstyle 'runstyle)
          (http-err 400 "Invalid runstyle. Must be AUTO or MANUAL")))))

(defendpoint* :delete "/oneliner/:oneliner a-oneliner-id:" ((token an-api-token))
  (:auth t)
  "Delete a oneliner."
  (delete-oneliner oneliner)
  "true")


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

(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))
  (to-json entry)) 

(defendpoint* :get "/oneliner/:entry a-oneliner-id:" () ()
  "Gets a oneliner by id."
  (to-json entry))

(defendpoint* :put "/oneliner/:entry a-oneliner-id:/flag" ((token an-api-token)
                                                           (value a-boolean))
  (:auth t)
  "Flag / Unflag the oneliner for review."
  (when (and (lockedp entry) (not (adminp (api-contributor token))))
    (http-err 403))
  (if value 
      (flag-oneliner entry (api-contributor token))
      (if (adminp (api-contributor token))
          (unflag-oneliner entry)
          (http-err 403)))
  "true")

(defendpoint* :get "/oneliners/newest" ((limit an-int))
  ()
  "A search endpoint returning the LIMIT newest oneliners."
  (to-json (list :oneliners (newest-oneliners limit))))

(defendpoint* :get "/oneliners/all-flagged" ((limit an-int))
  ()
  "A search endpoint returning all of the flagged oneliners. If LIMIT
  is present, only that many are returned."
  (to-json (list :oneliners (flagged-oneliners limit))))

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