(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)
  (+ +invite-lifetime+
     (created-at invite)))

(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."
  (with-plist (limit made) (contributor-invites contributor)
              (< made limit)))

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

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

(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.")
   (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 *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"
  :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 plist)
  (with-plist
      (oneliner tags brief description runstyle) plist
      (unless brief
        (http-err 400 "Oneliner requires a brief description"))
      (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.")))
      (db:with-transaction ()
        (make-instance 'oneliner
                       :created-by contributor
                       :description (or description "")
                       :tags tags
                       :oneliner oneliner
                       :brief brief
                       :runstyle (or runstyle :auto)))))

(defun flag-oneliner (oneliner &optional contributor)
  "Flag a oneliner for review. If locked, ensure that CONTRIBUTOR is an admin. Returns T or NIL."
  (when (or (not (lockedp oneliner)) (and contributor (adminp contributor))) 
    (db:with-transaction ()
      (setf (flagged-by oneliner) (or contributor :anonymous))
      t)))

(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 plist)
  (when (or (not (lockedp ol)) (adminp contributor))
    (with-plist
        (oneliner tags brief description runstyle) plist
        (when runstyle
          (setf runstyle (a:make-keyword runstyle))
          (unless (typep runstyle 'runstyle)
            (http-err 400)))
      (db:with-transaction ()
        (when oneliner
          (setf (oneliner ol) oneliner))
        (when tags
          (setf (oneliner-tags ol) tags))
        (when brief
          (setf (oneliner-brief ol) brief))
        (when description
          (setf (oneliner-description ol) description))
        (when runstyle
          (setf (oneliner-runstyle ol) 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)))

;;; ENDPOINT DEFINITIONS

(defendpoint* :post "/redeem/:invite an-invite-code:"
  ((username a-string)
   (password1 a-string)
   (password2 a-string))
  ()
  "Redeem an [invite code](#invite-code) and create a new [contributor](#new-contributor-post-body)"
  (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 "/token/:contributor a-user-handle:"
  ((password a-string))
  ()
  "Authenticate a contributor and reply with an [api token](#access-token)"
  (cond ((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))))) 
           (lzb:set-response-cookie
            +auth-cookie-name+ token
            :path "/" :domain *server-domain*)
           (to-json (list :token token)))) 
        (t
         (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* :post "/revoke/:contributor a-user-handle:" ()
  (:auth t)
  "A contributor can revoke their own access (if for some reason their
  API key ends up out of their control), or an admin can revoke
  anybody's access token, forcing the  to re-authenticate."
  (if (can-revoke-contributor (request-contributor) contributor)
      (revoke-access contributor)
      (http-err 403)))

(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 "/make-invite" ()
  (:auth 'authorized-to-invite)
  "On success, return an object containing a new [invite token](#invite-token)."
  (to-json (make-new-invite (request-contributor))))

(defendpoint* :post "/add-oneliner" ()
  (:auth t)
  "Make a new [oneliner](#oneliner-post-body)."
  (make-new-oneliner (request-contributor)  (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* :patch "/lock/:oneliner a-oneliner-id:" ()
  (:auth 'admin-only)
  "Locks a oneliner. Locked oneliners cannot be edited or flagged."
  (lock-oneliner oneliner (request-contributor))
  "true")

(defendpoint* :patch "/unlock/:oneliner a-oneliner-id:" ()
  (:auth 'admin-only)
  "Unlocks a oneliner."
  (unlock-oneliner oneliner (request-contributor))
  "true")

(defendpoint* :patch "/edit/:oneliner a-oneliner-id:" ()
  (:auth t)
  "Edit the fields of a oneliner."
  (if (edit-oneliner oneliner (request-contributor) (lzb:request-body))
      "true"
      (http-err 403))) ;; in case it is locked

(defendpoint* :patch "/flag/:oneliner a-oneliner-id:" () ()
  "Flag the oneliner for review. Open to anyone."
  (if  (flag-oneliner oneliner (request-contributor))
       "true"
       (http-err 403)))

(defendpoint* :get "/search" ((tags a-csl)
                              (limit an-int)
                              (notflagged a-boolean))
  ()
  "A search endpoint returning a JSON encoded array of Oneliner Entries. TAGS cannot be empty."
  (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 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 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)))