;;;; helm-redmine.el --- show redmine tickets with helm interface

helm-redmine.el

;;;; helm-redmine.el --- show redmine tickets with helm interface

;; Copyright (C) 2013 by l3msh0

;; Author: l3msh0
;; URL: https://gist.github.com/l3msh0/5663231
;; Version: 0.0.1

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

;; helm-redmine.el is an helm interface for redmine tickets.
;; Because this program is developed with the redmine which doesn't allow API access,
;; there are some hacks around loging procedure.

;;; Settings:

;; See below for example.

;; (require 'helm-redmine)
;; (setq helm-redmine-project-url "http://hostname.org/redmine/projects/myproject/")
;; (setq helm-redmine-api-params-alist '(("limit" . 100)
;;                                       ("query_id" . 5)))

;;; Code:

(require 'url)
(require 'helm)
(eval-when-compile (require 'cl))

;;====================
;; Configurations
;;====================
(defvar helm-redmine-project-url nil "Redmine project root URL")
(defvar helm-redmine-api-name "issues" "API name to call")
(defvar helm-redmine-api-params-alist '(("limit" . 100)) "API parameter alist")
(defvar helm-redmine-username nil)
(defvar helm-redmine-password nil)

;;====================
;; Util
;;====================
(defun helm-redmine-login-url (root)
  "Make login url from project root url."
  (string-match "\\(http://.*\\)projects" root)
  (concat (match-string 1 root) "login"))

(defadvice url-http-handle-authentication (around redmine-auth-hack activate)
  ;; do nothing
  )

(defun helm-redmine-build-query (args)
  "Build query string from args alist."
  (mapconcat (lambda (arg) (concat (url-hexify-string (car arg))
                                   "="
                                   (let ((val (cdr arg)))
                                     (if (numberp val) (url-hexify-string (number-to-string val)) (url-hexify-string val)))))
             args
             "&"))

(defun helm-redmine-http-post (url &optional args)
  "Send ARGS to URL as a POST request."
  (let ((url-request-method "POST")
        (url-request-extra-headers
         '(("Content-Type" . "application/x-www-form-urlencoded")))
        (url-request-data (helm-redmine-build-query args)))
    (url-retrieve-synchronously url)))

(defun helm-redmine-http-get (url &optional args)
  "Fetch URL resource by GET request."
  ;; activate advice to ignore authentication prompt
  (ad-enable-advice 'url-http-handle-authentication 'around 'redmine-auth-hack)
  (ad-activate 'url-http-handle-authentication)
  (prog1
      (url-retrieve-synchronously (concat url "?" (helm-redmine-build-query args)))
    (ad-disable-advice 'url-http-handle-authentication 'around 'redmine-auth-hack)
    (ad-activate 'url-http-handle-authentication)))

(defun helm-redmine-login ()
  "Execute redmine login procedure."
  ;; prompt if auth info are empty
  (when (null helm-redmine-username)
    (setq helm-redmine-username (read-string "Username: ")))
  (when (null helm-redmine-password)
    (setq helm-redmine-password (read-passwd "Password: ")))

  (let* ((login (helm-redmine-login-url helm-redmine-project-url))
         (token (helm-redmine-scrape-token
                 (helm-redmine-http-get login)))
         (buf (helm-redmine-http-post login `(("username" . ,helm-redmine-username)
                                              ("password" . ,helm-redmine-password)
                                              ("authenticity_token" . ,token))))
         (status (helm-redmine-get-http-status buf)))
    (kill-buffer buf)
    (unless (= status 302)
      (error "Login failed."))
    status))

(defun helm-redmine-scrape-token (buf)
  "Extract authenticity_token from the buffer."
  (with-current-buffer buf
    (goto-char (point-min))
    (re-search-forward "<input name=\"authenticity_token\".*?value=\"\\(.*\\)\"")
    (match-string 1)))

(defun helm-redmine-get-http-status (buf)
  "Return HTTP status code for the result of `url-retrieve'."
  (with-current-buffer buf
    (goto-char (point-min))
    (re-search-forward "Status: \\([0-9]\\{3\\}\\)")
    (string-to-number (match-string 1))))

;;====================
;; Communicate
;;====================
(defun helm-redmine-call-api (api params)
  "Call Redmine API and return parsed result."
  (let* ((url (concat helm-redmine-project-url api ".xml"))
         (buf (helm-redmine-http-get url params))
         (status (helm-redmine-get-http-status buf)))
    (unless (= status 200)
      ;; login
      (helm-redmine-login)
      (setq buf (helm-redmine-http-get url params)))
    (prog1 (with-current-buffer buf
             (xml-parse-region (re-search-forward "^$") (point-max)))
      (kill-buffer buf))))

;;====================
;; helm
;;====================
(defun helm-redmine-make-source (xml)
  "Make helm source from parsed issue list."
  (let* ((issues (car xml))
         (issue-list (xml-get-children issues 'issue)))
    (mapcar
     (lambda (issue)
       (let ((id (caddar (xml-get-children issue 'id)))
             (priority (xml-get-attribute (car (xml-get-children issue 'priority)) 'name))
             (subject (caddar (xml-get-children issue 'subject))))
         (format "#%s %s %s" id priority subject)))
     issue-list)))

(defun helm-redmine ()
  (interactive)
  (when (null helm-redmine-project-url)
    (error "`helm-redmine-project-url is undefined."))
  (let ((issues (helm-redmine-call-api helm-redmine-api-name helm-redmine-api-params-alist)))
    (helm :sources `(
                     (name . "redmine tickets")
                     (candidates . ,(helm-redmine-make-source issues))
                     (action . (("Browse" . (lambda (c)
                                              (string-match "#\\([0-9]+\\)" c)
                                              (browse-url (concat helm-redmine-project-url "issues/" (match-string 1 c)))))
                               ))
                     )
          :buffer "*helm-redmine*")))

(provide 'helm-redmine)