sx-interaction.el

;;; sx-interaction.el --- voting, commenting, and other interaction  -*- lexical-binding: t; -*-

;; Copyright (C) 2014-2018  Artur Malabarba

;; Author: Artur Malabarba <bruce.connor.am@gmail.com>

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU 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 General Public License for more details.

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

;;; Commentary:

;; This file holds a series of functions for performing arbitrary
;; interactions with arbitrary objects (objects here always mean the
;; alist of a question, answer, or comment). All commands take at
;; least a DATA argument corresponding to the object which, when
;; called interactively, is always derived from the context at point
;; (usually using the `sx--data-here' function).
;;
;; Interactions represented here involve voting, commenting, asking,
;; answering, editing.
;;
;; These are commands are meant to be available throughout the
;; interface. So it didn't make sense to put them in a specific
;; module. They also rely on a lot of dependencies, so they couldn't
;; be put in sx.el.


;;; Code:
(eval-when-compile
  '(require 'cl-lib))

(require 'sx)
(require 'sx-question)
(require 'sx-question-mode)
(require 'sx-question-list)
(require 'sx-compose)
(require 'sx-cache)


;;; Using data in buffer
(defun sx--data-here (&optional type noerror)
  "Get the alist regarding object under point of type TYPE.
Looks at the text property `sx--data-here'. If it's not set, it
looks at a few other reasonable variables. If those fail too, it
throws an error.

TYPE is a symbol restricting the type of object desired. Possible
values are 'question, 'answer, 'comment, or nil (for any type).

If no object of the requested type could be returned, an error is
thrown unless NOERROR is non-nil."
  (or (let ((data (get-char-property (point) 'sx--data-here)))
        (if (null type) data
          (sx-assoc-let data
            ;; Is data of the right type?
            (cl-case type
              (question (when .title data))
              (answer (when .answer_id data))
              (comment (when .comment_id data))))))
      ;; The following two only ever return questions.
      (when (or (null type) (eq type 'question))
        ;; @TODO: `sx-question-list-mode' may one day display answers.
        ;; Ideally, it would use the `sx--data-here' (so no special
        ;; handling would be necessary.
        (or (and (derived-mode-p 'sx-question-list-mode)
                 (tabulated-list-get-id))
            (and (derived-mode-p 'sx-question-mode)
                 sx-question-mode--data)))
      ;; Nothing was found
      (and (null noerror)
           (error "No %s found here" (or type "data")))))

(defun sx--marker-to-data (marker &rest rest)
  "Get the data at MARKER.
REST is passed to `sx--data-here'."
  (save-excursion
    (goto-char marker)
    (apply #'sx--data-here rest)))

(defun sx--error-if-unread (data)
  "Throw a user-error if DATA is an unread question.
If it's not a question, or if it is read, return DATA."
  ;; If we found a question, we may need to check if it's read.
  (if (and (assoc 'title data)
           (null (sx-question--read-p data)))
      (sx-user-error "Question not yet read. View it before acting on it")
    data))

(defun sx--maybe-update-display (&optional buffer site id)
  "Refresh whatever is displayed in BUFFER or the current buffer.
If BUFFER is not live, nothing is done.

If SITE is given but ID isn't, only update if BUFFER appears to
be a question-list displaying SITE.
If both SITE and ID are given, only update if BUFFER appears to
be a question matching SITE and ID."
  (setq buffer (or buffer (current-buffer)))
  (when (buffer-live-p buffer)
    (with-current-buffer buffer
      (cond ((derived-mode-p 'sx-question-list-mode)
             (when (or (not site)
                       (and (not id)
                            (string= site sx-question-list--site)))
               (sx-question-list-refresh 'redisplay 'no-update)))
            ((derived-mode-p 'sx-question-mode)
             (when (or (not site)
                       (and id
                            (equal
                             (let-alist (sx--data-here 'question)
                               (cons .site_par .question_id))
                             (cons site id))))
               (sx-question-mode-refresh 'no-update)))))))

(defun sx--copy-data (from to)
  "Copy all fields of alist FORM onto TO.
Only fields contained in TO are copied."
  (setcar to (car from))
  (setcdr to (cdr from)))

(defun sx-ensure-authentication ()
  "Signal user-error if the user refuses to authenticate.
Note that `sx-method-call' already does authentication checking.
This function is meant to be used by commands that don't
immediately perform method calls, such as `sx-ask'.  This way,
the unauthenticated user will be prompted before going through
the trouble of composing an entire question."
  (unless (sx-cache-get 'auth)
    (if (y-or-n-p "This command requires authentication, would you like to authenticate? ")
        (sx-authenticate)
      (sx-user-error "This command requires authentication, please run `M-x sx-authenticate' and try again."))))

(defmacro sx--make-update-callback (&rest body)
  "Return a function that runs BODY and updates display.
`sx--maybe-update-display' is only called if the buffer where the
function was created still exists.  In that case, BODY is also
run in this buffer."
  (declare (debug t))
  `(let ((buffer (current-buffer)))
     (lambda (result)
       ;; See http://emacs.stackexchange.com/a/10725/50
       (ignore result)
       (if (buffer-live-p buffer)
           (with-current-buffer buffer
             ,@body
             (sx--maybe-update-display))
         ,@body))))

(defun sx--copy-update-callback (data)
  "Return a function that overwrites DATA and updates display.
First, DATA is destructively overwritten with the car of the
argument passed to the function.  Then,
`sx--maybe-update-display' is called in the original buffer."
  (sx--make-update-callback
   ;; The api returns the new DATA.
   (when result
     (sx--copy-data (elt result 0) data))))


;;; Visiting
(defun sx-visit-externally (data &optional copy-as-kill)
  "Visit DATA in a web browser.
DATA can be a question, answer, or comment. Interactively, it is
derived from point position.

If copy-as-kill is non-nil, do not call `browse-url'.
Instead, copy the link as a new kill with `kill-new'.
Interactively, this is specified with a prefix argument.

If DATA is a question, also mark it as read."
  (interactive (list (sx--data-here) current-prefix-arg))
  (sx-assoc-let data
    (if (not (stringp .link))
        (sx-message "Nothing to visit here.")
      (funcall (if copy-as-kill #'kill-new #'browse-url) .link)
      (when (and (called-interactively-p 'any) copy-as-kill)
        (message "Copied: %S" .link))
      (when (and .title (not copy-as-kill))
        (sx-question--mark-read data)
        (sx--maybe-update-display)))))

;;;###autoload
(defun sx-open-link (link &optional _)
  "Visit element given by LINK inside Emacs.
Element can be a question, answer, or comment."
  (interactive
   (let ((def (with-temp-buffer
                (save-excursion (yank))
                (thing-at-point 'url))))
     (list (read-string (concat "Link (" def "): ") nil nil def))))
  ;; For now, we have no chance of handling chat links, let's just
  ;; send them to the browser.
  (if (string-match (rx string-start "http" (opt "s") "://chat.") link)
      (sx-visit-externally link)
    (let ((data (sx--link-to-data link)))
      (sx-assoc-let data
        (cl-case .type
          (comment
           (sx-display-question
            (sx-question-get-from-comment .site_par .id) 'focus)
           (sx--find-in-buffer 'comment .id))
          (answer
           (sx-display-question
            (sx-question-get-from-answer .site_par .id) 'focus)
           (sx--find-in-buffer 'answer .id))
          (question
           (sx-display-question
            (sx-question-get-question .site_par .id) 'focus))
          (t (error "Don't know how to open this link, please file a bug report: %s"
                    link)
             nil))))))

;;;###autoload
(defun sx-org-get-link ()
  "Add a link to this post to Org's memory."
  (when (memq major-mode '(sx-question-mode sx-question-list-mode))
    (sx-assoc-let (sx--data-here)
      (when .link
        (org-store-link-props :type 'http
                              :link .link
                              :description .title)))))

(eval-after-load "org"
  '(cond
    ((fboundp 'org-link-set-parameters)
     (org-link-set-parameters
      "sx" :store #'sx-org-get-link))
    ((boundp 'org-store-link-functions)
     (add-to-list 'org-store-link-functions
                  #'sx-org-get-link))))


;;; Displaying
(defun sx-display (&optional data)
  "Display object given by DATA.
Interactively, display object under point. Object can be a
question, an answer, or an inbox_item.

This is meant for interactive use. In lisp code, use
object-specific functions such as `sx-display-question' and the
likes."
  (interactive (list (sx--data-here)))
  (sx-assoc-let data
    (cond
     ;; This is an attempt to identify when we have the question
     ;; object itself, so there's no need to fetch anything.  This
     ;; happens inside the question-list, but it can be easily
     ;; confused with the inbox (whose items have a title, a body, and
     ;; a question_id).
     ((and .title .question_id .score
           (not .item_type) (not .notification_type))
      (sx-display-question data 'focus))
     (.answer_id
      (sx-display-question
       (sx-question-get-from-answer .site_par .answer_id)
       'focus)
      (if .comment_id
          (sx--find-in-buffer 'comment .comment_id)
        (sx--find-in-buffer 'answer .answer_id)))
     (.question_id
      (sx-display-question
       (sx-question-get-question .site_par .question_id) 'focus)
      (when .comment_id
        (sx--find-in-buffer 'comment .comment_id)))
     ;; `sx-question-get-from-comment' takes 2 api requests, so we
     ;; test it last.
     (.comment_id
      (sx-display-question
       (sx-question-get-from-comment .site_par .comment_id) 'focus)
      (sx--find-in-buffer 'comment .comment_id))
     (.notification_type
      (sx-message "Viewing notifications is not yet implemented"))
     (.item_type (sx-open-link .link)))))

(defun sx-display-question (&optional data focus window)
  "Display question given by DATA, on WINDOW.
Interactively, display question under point. When FOCUS is
non-nil (the default when called interactively), also focus the
relevant window.

If WINDOW nil, the window is decided by
`sx-question-mode-display-buffer-function'."
  (interactive (list (sx--data-here 'question) t))
  (when (sx-question--mark-read data)
    (sx--maybe-update-display))
  ;; Display the question.
  (setq window
        (get-buffer-window
         (sx-question-mode--display data window)))
  (when focus
    (if (window-live-p window)
        (select-window window)
      (switch-to-buffer sx-question-mode--buffer))))


;;; Simple interactions
(defun sx-favorite (data &optional undo)
  "Favorite question given by DATA.
Interactively, it is guessed from context at point.
With the UNDO prefix argument, unfavorite the question instead."
  (interactive (list (sx--error-if-unread (sx--data-here 'question))
                     current-prefix-arg))
  (sx-method-post-from-data data
    (if undo 'favorite/undo 'favorite)
    :callback (sx--copy-update-callback data)))
(defalias 'sx-star #'sx-favorite)

(defun sx-accept (data &optional undo)
  "Accept answer given by DATA.
Interactively, it is guessed from context at point.
With the UNDO prefix argument, unaccept the question instead."
  (interactive (list (sx--data-here 'answer)
                     current-prefix-arg))
  (sx-ensure-authentication)
  ;; When clicking the "Accept" button, first arg is a marker.
  (when (markerp data)
    (setq data (sx--marker-to-data data 'answer)))
  (sx-method-post-from-data data
    (if undo 'accept/undo 'accept)
    :callback (sx--copy-update-callback data)))


;;; Voting
(defun sx-upvote (data &optional undo)
  "Upvote an object given by DATA.
DATA can be a question, answer, or comment. Interactively, it is
guessed from context at point.
With UNDO prefix argument, remove upvote instead of applying it."
  (interactive (list (sx--error-if-unread (sx--data-here))
                     current-prefix-arg))
  (sx-set-vote data "upvote" (not undo)))

(defun sx-downvote (data &optional undo)
  "Downvote an object given by DATA.
DATA can be a question or an answer. Interactively, it is guessed
from context at point.
With UNDO prefix argument, remove downvote instead of applying it."
  (interactive (list (sx--error-if-unread (sx--data-here))
                     current-prefix-arg))
  (sx-set-vote data "downvote" (not undo)))

(defun sx-set-vote (data type status)
  "Set the DATA's vote TYPE to STATUS.
DATA can be a question, answer, or comment. TYPE can be
\"upvote\" or \"downvote\". STATUS is a boolean.

Besides posting to the api, DATA is also altered to reflect the
changes."
  (sx-ensure-authentication)
  (sx-method-post-from-data data
    (concat type (unless status "/undo"))
    :callback (sx--copy-update-callback data)))


;;; Delete
(defun sx-delete (data &optional undo)
  "Delete an object given by DATA.
DATA can be a question, answer, or comment. Interactively, it is
guessed from context at point.
With UNDO prefix argument, undelete instead."
  (interactive (list (sx--error-if-unread (sx--data-here))
                     current-prefix-arg))
  (sx-ensure-authentication)
  (when (y-or-n-p (format "DELETE this %s? "
                    (let-alist data
                      (cond (.comment_id "comment")
                            (.answer_id "answer")
                            (.question_id "question")))))
    (sx-method-post-from-data data
      (if undo 'delete/undo 'delete)
      :callback (sx--make-update-callback
                 ;; Indicate to ourselves this has been deleted.
                 (setcdr data (cons (car data) (cdr data)))
                 (setcar data 'deleted)))))


;;; Commenting
(defun sx-comment (data &optional text)
  "Post a comment on DATA given by TEXT.
DATA can be a question, an answer, or a comment. Interactively,
it is guessed from context at point.
If DATA is a comment, the comment is posted as a reply to it.

TEXT is a string. Interactively, it is read from the minibufer."
  (interactive (list (sx--error-if-unread (sx--data-here)) 'query))
  (sx-ensure-authentication)
  ;; When clicking the "Add a Comment" button, first arg is a marker.
  (when (markerp data)
    (setq data (sx--marker-to-data data))
    (setq text 'query))
  (sx-assoc-let data
    ;; Get the comment text
    (when (eq text 'query)
      (setq text (read-string
                  "Comment text: "
                  (when .comment_id
                    (substring-no-properties (sx-user--format "%@ " .owner)))))
      (while (not (sx--comment-valid-p text 'silent))
        (setq text (read-string "Comment text (between 16 and 600 characters): " text))))
    ;; If non-interactive, `text' could be anything.
    (unless (stringp text)
      (error "Comment body must be a string"))
    ;; And post
    (let ((result
           (sx-method-call 'posts
             :id (or .post_id .answer_id .question_id)
             :submethod "comments/add"
             :auth 'warn
             :url-method 'post
             :filter sx-browse-filter
             :site .site_par
             :keywords `((body . ,text)))))
      ;; The api returns the new DATA.
      (when result
        (sx--add-comment-to-object
         (sx--ensure-owner-in-object (list (cons 'display_name "(You)")) (elt result 0))
         (if .post_id (sx--get-post .post_type .site_par .post_id) data))
        ;; Display the changes in `data'.
        (sx--maybe-update-display)))))

(defun sx--comment-valid-p (&optional text silent)
  "Non-nil if TEXT fits stack exchange comment length limits.
If TEXT is nil, use `buffer-string'. Must have more than 15 and
less than 601 characters.
If SILENT is nil, message the user about this limit."
  (let ((w (string-width (or text (buffer-string)))))
    (if (and (< 15 w) (< w 601))
        t
      (unless silent
        (message "Comments must be within 16 and 600 characters."))
      nil)))

(defun sx--get-post (type site id)
  "Find in the database a post identified by TYPE, SITE and ID.
TYPE is `question' or `answer'.
SITE is a string.
ID is an integer."
  (let ((db (cons sx-question-mode--data
                  sx-question-list--dataset)))
    (setq db
          (cond
           ((string= type "question") db)
           ((string= type "answer")
            (apply #'cl-map 'list #'identity
                   (mapcar (lambda (x) (cdr (assoc 'answers x))) db)))))
    (car (cl-member-if
          (lambda (x) (sx-assoc-let x
                   (and (equal (or .answer_id .question_id) id)
                        (equal .site_par site))))
          db))))

(defun sx--add-comment-to-object (comment object)
  "Add COMMENT to OBJECT's `comments' property.
OBJECT can be a question or an answer."
  (let ((com-cell (assoc 'comments object)))
    (if com-cell
        (progn
          (setcdr
           com-cell
           (append (cdr com-cell)
                   (list comment))))
      ;; No previous comments, add it manually.
      (setcdr object (cons (car object) (cdr object)))
      (setcar object `(comments . (,comment)))))
  object)

(defun sx--ensure-owner-in-object (owner object)
  "Add `owner' property with value OWNER to OBJECT."
  (unless (cdr-safe (assq 'owner object))
    (setcdr object (cons (car object) (cdr object)))
    (setcar object `(owner . ,owner)))
  object)


;;; Editing
(defun sx-edit (data)
  "Start editing an answer or question given by DATA.
DATA is an answer or question alist. Interactively, it is guessed
from context at point."
  (interactive (list (sx--data-here)))
  (sx-ensure-authentication)
  ;; If we ever make an "Edit" button, first arg is a marker.
  (when (markerp data) (setq data (sx--data-here)))
  (sx-assoc-let data
    (let ((buffer (current-buffer)))
      (pop-to-buffer
       (sx-compose-create
        .site_par data
        ;; Before send hook
        (when .comment_id (list #'sx--comment-valid-p))
        ;; After send functions
        (list (lambda (_ res)
                (sx--copy-data (elt res 0) data)
                (sx--maybe-update-display buffer))))))))


;;; Asking
(defcustom sx-default-site "emacs"
  "Name of the site to use by default when listing questions."
  :type 'string
  :group 'sx)

(defun sx--interactive-site-prompt ()
  "Query the user for a site."
  (let ((default (or sx-question-list--site
                     (sx-assoc-let sx-question-mode--data .site_par)
                     sx-default-site)))
    (sx-completing-read
     (format "Site (%s): " default)
     (sx-site-get-api-tokens) nil t nil nil
     default)))

(defun sx--maybe-site-prompt (arg)
  "Get a site token conditionally in an interactive context.
If ARG is non-nil, use `sx--interactive-site-prompt'.
Otherwise, use `sx-question-list--site' if non-nil.
If nil, use `sx--interactive-site-prompt' anyway."
  ;; This could eventually be generalized into (sx--maybe-prompt
  ;; prefix-arg value-if-non-nil #'prompt-function).
  (if arg
      (sx--interactive-site-prompt)
    (or sx-question-list--site
        (sx--interactive-site-prompt))))

;;;###autoload
(defun sx-ask (site)
  "Start composing a question for SITE.
SITE is a string, indicating where the question will be posted."
  (interactive (list (sx--interactive-site-prompt)))
  (sx-ensure-authentication)
  (let ((buffer (current-buffer)))
    (pop-to-buffer
     (sx-compose-create
      site nil nil
      ;; After send functions
      (list (lambda (_b _res) (sx--maybe-update-display buffer)))))))


;;; Answering
(defun sx-answer (data)
  "Start composing an answer for question given by DATA.
DATA is a question alist. Interactively, it is guessed from
context at point. "
  ;; If the user tries to answer a question that's not viewed, he
  ;; probably hit the button by accident.
  (interactive
   (list (sx--error-if-unread (sx--data-here 'question))))
  (sx-ensure-authentication)
  ;; When clicking the "Write an Answer" button, first arg is a marker.
  (when (markerp data) (setq data (sx--data-here)))
  (let ((buffer (current-buffer)))
    (sx-assoc-let data
      (pop-to-buffer
       (sx-compose-create
        .site_par .question_id nil
        ;; After send functions
        (list (lambda (_ res)
                (sx--add-answer-to-question-object (elt res 0) data)
                (sx--maybe-update-display buffer .site_par .question_id))))))))

(defun sx--add-answer-to-question-object (answer question)
  "Add alist ANSWER to alist QUESTION in the right place."
  (let ((cell (assoc 'answers question)))
    (if cell
        (setcdr cell (append (cdr cell) (list answer)))
      ;; No previous comments, add it manually.
      (setcdr question (cons (car question) (cdr question)))
      (setcar question `(answers . (,answer))))
    question))

(provide 'sx-interaction)
;;; sx-interaction.el ends here

;; Local Variables:
;; indent-tabs-mode: nil
;; End: