path: root/rt-liberation-browser.el

;;; rt-liberation-browser.el --- Emacs interface to RT  -*- lexical-binding: t; -*-

;; Copyright (C) 2020  Free Software Foundation, Inc.
;;
;; Authors: Yoni Rabkin <yrk@gnu.org>
;;
;; This file is a part of rt-liberation.
;;
;; 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, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;; MA 02111-1307, USA.


;;; Code:
(require 'rt-liberation-rest)

(declare-function rt-liber-get-ancillary-text "rt-liberation-storage.el")
(declare-function rt-liber-display-ticket-history "rt-liberation-viewer.el" '(ticket-alist &optional assoc-browser))
(declare-function rt-liber-viewer2-display-ticket-history "rt-liberation-viewer.el" '(ticket-alist &optional assoc-browser))

(defvar rt-liber-base-url ""
  "Base url for ticket display.")

(defvar rt-liber-ticket-local nil
  "Buffer local storage for a ticket.
This variable is made buffer local for the ticket history")

(defvar rt-liber-correspondence-regexp
  "^Type: \\(EmailRecord\\|CommentEmailRecord\\|Correspond\\)"
  "Regular expression for correspondence sections.")

(defvar rt-liber-field-dictionary
  '((owner   . "Owner")
    (queue   . "Queue")
    (status  . "Status")
    (priority  . "Priority"))
  "Mapping between field symbols and RT field strings.

The field symbols provide the programmer with a consistent way of
referring to RT fields.")

(defvar rt-liber-custom-ticket-redraw-function
  'rt-liber-ticketlist-browser-redraw-f
  "Default ticket redraw function.")

(defvar rt-liber-anc-p nil
  "Display ancillary data for tickets.")

(defvar rt-liber-query nil
  "Query structure (becomes ticket-browser buffer local).")

(defvar rt-liber-ticket-list nil
  "Ticket-list structure (becomes ticket-browser buffer local).")

(defvar rt-liber-browser-buffer-name "*ticket-browser*"
  "Name of ticket browser buffer.")

(defvar rt-liber-browser-buffer nil
  "Ticket browser buffer.")

(defvar rt-liber-browser-default-sorting-function
  'rt-liber-sort-by-time-created
  "Default sorting function.")

(defvar rt-liber-browser-default-filter-function
  'rt-liber-default-filter-f
  "Default filtering function.
This is a function which accepts the ticket alist as a single
argument and returns nil if the ticket needs to be filtered out,
dropped or ignored (however you wish to put it.), otherwise the
function returns a truth value.")

(defvar rt-liber-browser-time-format-string "%b %d %Y %H:%M"
  "String passed to `format-time-string' in the ticket browser.")

(defvar rt-liber-browser-priority-cutoff 0
  "Tickets with a priority higher than this are high priority.")

(defgroup rt-liber nil
  "*rt-liberation, the Emacs interface to RT"
  :prefix "rt-liber-"
  :group 'rt-liber)

(defface rt-liber-ticket-face
  '((((class color) (background dark))
     (:foreground "DarkSeaGreen"))
    (((class color) (background light))
     (:foreground "Blue"))
    (((type tty) (class mono))
     (:inverse-video t))
    (t (:background "Blue")))
  "Face for tickets in browser buffer.")

(defface rt-liber-priority-ticket-face
  '((((class color) (background dark))
     (:foreground "Orange"))
    (((class color) (background light))
     (:foreground "Orange"))
    (((type tty) (class mono))
     (:inverse-video t))
    (t (:background "Black")))
  "Face for high priority tickets in browser buffer.")

(defvar rt-liber-browser-do-refresh t
  "When t, run `rt-liber-browser-refresh' otherwise disable it.")

(defvar rt-liber-assoc-browser nil
  "Browser associated with a ticket history.
This variable is made buffer local for the ticket history")

;;; ------------------------------------------------------------------

(defun rt-liber-browser-mode-quit ()
  "Bury the ticket browser."
  (interactive)
  (bury-buffer))

(defconst rt-liber-browser-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "q") 'rt-liber-browser-mode-quit)
    (define-key map (kbd "n") 'rt-liber-next-ticket-in-browser)
    (define-key map (kbd "p") 'rt-liber-previous-ticket-in-browser)
    (define-key map (kbd "RET") 'rt-liber-display-ticket-at-point)
    (define-key map (kbd "g") 'revert-buffer)
    (define-key map (kbd "G") 'rt-liber-browser-refresh-and-return)
    (define-key map (kbd "a") 'rt-liber-browser-assign)
    (define-key map (kbd "r") 'rt-liber-browser-resolve)
    (define-key map (kbd "o") 'rt-liber-browser-open)
    (define-key map (kbd "N") 'rt-liber-browser-new)
    (define-key map (kbd "t") 'rt-liber-browser-take-ticket-at-point)
    (define-key map (kbd "A") 'rt-liber-browser-ancillary-text)
    (define-key map (kbd "SPC") 'scroll-up)
    (define-key map (kbd "DEL") 'scroll-down)
    (define-key map (kbd "M") 'rt-liber-mark-ticket-at-point)
    (define-key map (kbd "P") 'rt-liber-browser-prioritize)
    map)
  "Key map for ticket browser.")

(define-derived-mode rt-liber-browser-mode nil
  "RT Liberation Browser"
  "Major Mode for browsing RT tickets.
\\{rt-liber-browser-mode-map}"
  (set (make-local-variable 'revert-buffer-function)
       #'rt-liber-browser-refresh)
  (set (make-local-variable 'buffer-stale-function)
       (lambda (&optional _noconfirm) 'slow))
  (run-hooks 'rt-liber-browser-hook))

(defun rt-liber-setup-browser-name (new)
  (setq rt-liber-browser-buffer
	(get-buffer-create
	 (if new
	     (generate-new-buffer-name
	      (if (stringp new)
		  new
		rt-liber-browser-buffer-name))
	   (if (and (boundp 'rt-liber-query)
		    rt-liber-query)
	       (buffer-name)
	     rt-liber-browser-buffer-name)))))

(defun rt-liber-browser-with-message (message &optional query new)
  "Start the RT ticket browser and display MESSAGE."
  (interactive)
  (rt-liber-setup-browser-name new)
  ;; setup stage (invisible to user)
  (with-current-buffer rt-liber-browser-buffer
    (let ((inhibit-read-only t))
      (rt-liber-browser-mode)
      (goto-char (point-min))
      (rt-liber-ticketlist-browser-redraw nil query)
      (newline 2)
      (insert message)
      (set (make-local-variable 'rt-liber-query) query)))
  ;; display stage (user can see updates)
  (switch-to-buffer rt-liber-browser-buffer)
  (setq buffer-read-only t))

(declare-function rt-liber-set-ancillary-text "rt-liberation-storage.el")

(defun rt-liber-browser-ancillary-text ()
  "Wrapper function around storage backend."
  (interactive)
  (when (not (featurep 'rt-liberation-storage))
    (error "rt-liberation-storage isn't loaded"))
  (let ((initial-contents ""))
    (rt-liber-set-ancillary-text
     (read-from-minibuffer "Text: " initial-contents))))

(defun rt-liber-browser-startup (ticket-list &optional query new)
  "Start the RT ticket browser."
  (interactive)
  (rt-liber-setup-browser-name new)
  ;; setup stage (invisible to user)
  (with-current-buffer rt-liber-browser-buffer
    (let ((inhibit-read-only t))
      (rt-liber-ticketlist-browser-redraw ticket-list query)
      (goto-char (point-min))
      (rt-liber-next-ticket-in-browser)
      (rt-liber-browser-mode)
      ;; store the ticket-list and the query which produced the buffer
      ;; as buffer local variables
      (set (make-local-variable 'rt-liber-ticket-list) ticket-list)
      (set (make-local-variable 'rt-liber-query) query)))
  ;; display stage (user can see updates)
  (switch-to-buffer rt-liber-browser-buffer)
  (setq buffer-read-only t))

(defun rt-liber-browse-query (query &optional new)
  "Run QUERY against the server and launch the browser.

NEW if non-nil create additional browser buffer. If NEW is a
string then that will be the name of the new buffer."
  (interactive "Mquery: ")
  (condition-case nil
      (rt-liber-browser-startup
       (rt-liber-rest-run-show-base-query
	(rt-liber-rest-run-ls-query query))
       query new)
    (rt-liber-no-result-from-query-error
     (rt-liber-browser-with-message "no results from query"
				    query new))))

(defun rt-liber-ticket-id-only (ticket-alist)
  "Return numerical portion of ticket number from TICKET-ALIST."
  (if ticket-alist
      (substring (cdr (assoc "id" ticket-alist)) 7)
    nil))

(defun rt-liber-ticket-priority-only (ticket-alist)
  "Return an integer value priority or NIL."
  (if ticket-alist
      (let ((p-str (cdr (assoc "Priority" ticket-alist))))
	(if p-str
	    (string-to-number p-str)
	  nil))
    nil))

(defun rt-liber-ticket-owner-only (ticket-alist)
  "Return the string value of the ticket owner."
  (when (not ticket-alist)
    (error "null ticket-alist"))
  (cdr (assoc (rt-liber-get-field-string 'owner)
	      ticket-alist)))

(defun rt-liber-get-field-string (field-symbol)
  (when (not field-symbol)
    (error "null field symbol"))
  (cdr (assoc field-symbol rt-liber-field-dictionary)))

;; accept a ticket-alist object and return an alist mapping ticket
;; properties to format characters for use in `rt-liber-format'.
(defun rt-liber-format-function (ticket-alist)
  "Return a pairing of TICKET-ALIST values to %-sequences."
  (let* ((id         (rt-liber-ticket-id-only ticket-alist))
	 (subject    (cdr (assoc "Subject" ticket-alist)))
	 (status     (cdr (assoc "Status" ticket-alist)))
	 (created    (format-time-string
		      rt-liber-browser-time-format-string
		      (date-to-time
		       (cdr (assoc "Created" ticket-alist)))))
	 (resolved   (cdr (assoc "Resolved" ticket-alist)))
	 (requestors (cdr (assoc "Requestors" ticket-alist)))
	 (creator    (cdr (assoc "Creator" ticket-alist)))
	 (owner      (rt-liber-ticket-owner-only ticket-alist))
	 (queue      (cdr (assoc "Queue" ticket-alist)))
	 (anc        (if rt-liber-anc-p
			 (rt-liber-get-ancillary-text
			  (rt-liber-ticket-id-only ticket-alist))
		       ""))
	 (priority   (cdr (assoc "Priority" ticket-alist))))
    (list (cons ?i (or id "N/A"))
	  (cons ?s (or subject "N/A"))
	  (cons ?c (or created "N/A"))
	  (cons ?S (or status "N/A"))
	  (cons ?r (or resolved "N/A"))
	  (cons ?R (or requestors "N/A"))
	  (cons ?C (or creator "N/A"))
	  (cons ?o (or owner "N/A"))
	  (cons ?q (or queue "N/A"))
	  (cons ?A (or anc ""))
	  (cons ?p (or priority "N/A")))))

(defun rt-liber-browser-assoc (char alist)
  "Process the %-sequence association."
  (let ((v (cdr (assoc char alist))))
    (cond ((eq char ?%) "%") ;; escape sequence for %
	  (t (or v "")))))

(defun rt-liber-high-priority-p (ticket-alist)
  "Return t if TICKET-ALIST is high priority.

The ticket's priority is compared to the variable
  `rt-liber-browser-priority-cutoff'."
  (let ((p (rt-liber-ticket-priority-only ticket-alist)))
    (if p
	(< rt-liber-browser-priority-cutoff p)
      nil)))

(defun rt-liber-format (format ticket-alist)
  "Substitute %-sequences in FORMAT."
  (let ((alist (rt-liber-format-function ticket-alist)))
    (replace-regexp-in-string
     "%."
     (lambda (str)
       (rt-liber-browser-assoc (aref str 1) alist))
     format t t)))

(defun rt-liber-ticketlist-browser-redraw-f (ticket)
  "Display TICKET."
  (insert (rt-liber-format "[%c %i %S]" ticket))
  (add-text-properties (point-at-bol)
		       (point-at-eol)
		       '(face rt-liber-ticket-face))
  (when (rt-liber-high-priority-p ticket)
    (let ((p (point)))
      (insert (format " HIGH PRIORITY (%d)"
		      (rt-liber-ticket-priority-only ticket)))
      (add-text-properties p
			   (point-at-eol)
			   '(face rt-liber-priority-ticket-face))))

  (newline)
  (insert (rt-liber-format "  [%o] %R: %s" ticket))
  (let ((p (point)))
    (insert (rt-liber-format "    %A" ticket))
    (add-text-properties p (point)
			 '(face font-lock-comment-face)))
  (newline))

(declare-function rt-liber-ticket-marked-p
		  "rt-liberation-multi.el")

(defun rt-liber-ticketlist-browser-redraw (ticketlist &optional query)
  "Display TICKETLIST. Optionally display QUERY as well."
  (erase-buffer)
  (when query
    (insert (format "Query: %s" query))
    (newline)
    (insert (format "%d tickets" (length ticketlist)))
    (newline))
  (when ticketlist
    (let ((filtered-count 0))
      (newline 2)
      (dolist (ticket
	       (funcall rt-liber-browser-default-sorting-function
			ticketlist))
	;; skip filtered tickets, but count how many have been skipped
	(if (funcall rt-liber-browser-default-filter-function ticket)
	    (progn
	      ;; assumes that rt-liber-ticketlist-browser-redraw-f leaves
	      ;; point at the end of the ticket drawn
	      (let ((start (point)))
		(funcall rt-liber-custom-ticket-redraw-function ticket)
		(add-text-properties start
				     (point)
				     (list 'rt-ticket ticket))
		(when (and (featurep 'rt-liberation-multi)
			   (rt-liber-ticket-marked-p ticket))
		  (add-text-properties start
				       (point)
				       '(face rt-liber-marked-ticket-face))))
	      (newline))
	  (setq filtered-count (1+ filtered-count))))
      (when (< 0 filtered-count)
	(insert (format "%d tickets not shown (filtered)" filtered-count))))))

(defun rt-liber-browser-refresh (&optional _ignore-auto noconfirm)
  (interactive)
  (if rt-liber-query
      (when (or rt-liber-browser-do-refresh
		noconfirm)
	;; explicitly pass nil NEW to `rt-liber-browse-query'
	(rt-liber-browse-query rt-liber-query nil))
    (error "no buffer-local query")))

(defun rt-liber-browser-refresh-and-return ()
  (interactive)
  (let ((id (rt-liber-browser-ticket-id-at-point)))
    (rt-liber-browser-refresh)
    (rt-liber-browser-move-point-to-ticket id)))

;; This is just a special case of
;; `rt-liber-browser-ticket-<PROPERTY>-at-point'
(defun rt-liber-browser-ticket-id-at-point (&optional point)
  "Return the ticket id for the ticket at buffer position.

If POINT is nil then called on (point)."
  (when (not point)
    (setq point (point)))
  (let ((value (rt-liber-ticket-id-only
		(get-text-property point 'rt-ticket))))
    (if value
	value
      (error "no such ticket property at point"))))

(defun rt-liber-ticket-taken-p (ticket-alist)
  "Return t if TICKET-ALIST is owned by Nobody."
  (when (not ticket-alist)
    (error "null argument"))
  (let ((owner (rt-liber-ticket-owner-only ticket-alist)))
    (if (string= owner "Nobody")
	nil
      t)))

(defun rt-liber-next-ticket-in-browser ()
  "Move point to the next ticket."
  (interactive)
  (let ((next (next-single-property-change (point) 'rt-ticket)))
    (when next (goto-char next))))

(defun rt-liber-previous-ticket-in-browser ()
  "Move point to the previous ticket."
  (interactive)
  (let ((prev (previous-single-property-change (point) 'rt-ticket)))
    (when prev (goto-char prev))))

(defun rt-liber-display-ticket-at-point ()
  "Display the contents of the ticket at point."
  (interactive)
  (let ((ticket-alist (get-text-property (point) 'rt-ticket)))
    (rt-liber-display-ticket-history ticket-alist (current-buffer))))

;; remove after release START
(defun rt-liber-viewer2-display-ticket-at-point ()
  "Display the contents of the ticket at point."
  (interactive)
  (let ((ticket-alist (get-text-property (point) 'rt-ticket)))
    (rt-liber-viewer2-display-ticket-history ticket-alist (current-buffer))))
;; remove after release END

(defun rt-liber-browser-search (id)
  "Return point where ticket with ID is displayed or nil."
  (let ((p nil))
    (save-excursion
      (goto-char (point-min))
      (let ((point-id (rt-liber-ticket-id-only
		       (get-text-property (point) 'rt-ticket))))
	(if
	    ;; (predicate) looks for the exceptional situation
	    (and point-id (string= id point-id))
	    ;; (consequent) we're done
	    (setq p (point))
	  ;; (alternative) continue looking
	  (while (and (not p)
		      (rt-liber-next-ticket-in-browser))
	    (let ((point-id (rt-liber-ticket-id-only
			     (get-text-property (point) 'rt-ticket))))
	      (when (string= id point-id)
		(setq p (point))))))))
    p))

(defun rt-liber-browser-move-point-to-ticket (id)
  "Move point to the beginning of ticket with ID."
  (let ((p (rt-liber-browser-search id)))
    (if p
	(progn
	  (goto-char p)
	  (recenter-top-bottom))
      (error "ticket #%s not found" id))))


;;; --------------------------------------------------------
;;; Ticket browser sorting
;;; --------------------------------------------------------

(defun rt-liber-lex-lessthan-p (a b field)
  "Return t if A is lexicographically less than B in FIELD."
  (let ((field-a (cdr (assoc field a)))
	(field-b (cdr (assoc field b))))
    (if (and field-a field-b)
	(string-lessp field-a field-b)
      (error "\"%s\" is not a valid ticket field" field))))

(defun rt-liber-time-lessthan-p (a b field)
  "Return t if A is chronologically less than B in FIELD."
  (let ((field-a (cdr (assoc field a)))
	(field-b (cdr (assoc field b))))
    (if (and field-a field-b)
	(time-less-p (date-to-time field-a)
		     (date-to-time field-b))
      (error "\"%s\" is not a valid ticket field" field))))

(defun rt-liber-sort-ticket-list (ticket-list sort-f)
  "Return a copy of TICKET-LIST sorted by SORT-F."
  (let ((seq (copy-sequence ticket-list)))
    (sort seq sort-f)))

(defun rt-liber-sort-by-owner (ticket-list)
  "Sort TICKET-LIST lexicographically by owner."
  (rt-liber-sort-ticket-list
   ticket-list
   #'(lambda (a b)
       (rt-liber-lex-lessthan-p
	a b (rt-liber-get-field-string 'owner)))))

(defun rt-liber-sort-by-time-created (ticket-list)
  "Sort TICKET-LIST in reverse chronological order."
  (reverse
   (rt-liber-sort-ticket-list
    ticket-list
    #'(lambda (a b)
	(rt-liber-time-lessthan-p a b "Created")))))


;;; --------------------------------------------------------
;;; Ticket browser filtering
;;; --------------------------------------------------------

;; See the fine manual for example code.

(defun rt-liber-default-filter-f (_ticket)
  "The default filtering function for the ticket browser

This function is really a placeholder for user custom functions,
and as such always return t."
  t)


(provide 'rt-liberation-browser)

;;; rt-liberation-browser.el ends here.