code.delx.au - gnu-emacs-elpa/blob - packages/debbugs/debbugs.el

   1 ;;; debbugs.el --- SOAP library to access debbugs servers
   2
   3 ;; Copyright (C) 2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Keywords: comm, hypermedia
   7 ;; Package: debbugs
   8 ;; Version: 0.1
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This package provides some basic functions to access a debbugs SOAP
  28 ;; server (see <http://wiki.debian.org/DebbugsSoapInterface>).
  29
  30 ;; The SOAP functions "get_usertag" and "get_versions" are not
  31 ;; implemented (yet).
  32
  33 ;;; Code:
  34
  35 ;(setq soap-debug t message-log-max t)
  36 (require 'soap-client)
  37 (eval-when-compile (require 'cl))
  38
  39 (defgroup debbugs nil
  40   "Debbugs library"
  41   :group 'hypermedia)
  42
  43 (defcustom debbugs-servers
  44   '(("gnu.org"
  45      :wsdl "http://debbugs.gnu.org/cgi/soap.cgi?WSDL"
  46      :bugreport-url "http://debbugs.gnu.org/cgi/bugreport.cgi")
  47     ("debian.org"
  48      :wsdl "http://bugs.debian.org/cgi-bin/soap.cgi?WSDL"
  49      :bugreport-url "http://bugs.debian.org/cgi-bin/bugreport.cgi"))
  50   "*List of Debbugs server specifiers.
  51 Each entry is a list that contains a string identifying the port
  52 name and the server parameters in keyword-value form. Allowed
  53 keywords are:
  54
  55 `:wsdl' -- Location of WSDL. The value is a string with URL that
  56 should return the WSDL specification of Debbugs/SOAP service.
  57
  58 `:bugreport-url' -- URL of the server script that returns mboxes
  59 with bug logs.
  60
  61 The list initially contains two predefined and configured Debbugs
  62 servers: \"gnu.org\" and \"debian.org\"."
  63   :group 'debbugs
  64   :link '(custom-manual "(debbugs)Debbugs server specifiers")
  65   :type '(choice
  66           (const nil)
  67           (repeat
  68            (cons :tag "Server"
  69                  (string :tag "Port name")
  70                  (checklist :tag "Options" :greedy t
  71                             (group :inline t
  72                                    (const :format "" :value :wsdl)
  73                                    (string :tag "WSDL"))
  74                             (group :inline t
  75                                    (const :format "" :value :bugreport-url)
  76                                    (string :tag "Bugreport URL")))))))
  77
  78 (defcustom debbugs-port "gnu.org"
  79   "The port instance to be applied from `debbugs-wsdl'.
  80 This corresponds to the Debbugs server to be accessed, either
  81 \"gnu.org\", or \"debian.org\", or user defined port name."
  82   ;; Maybe we should create an own group?
  83   :group 'debbugs
  84   :type '(choice :tag "Debbugs server" (const "gnu.org") (const "debian.org")
  85                  (string :tag "user defined port name")))
  86
  87 ;; It would be nice if we could retrieve it from the debbugs server.
  88 ;; Not supported yet.
  89 (defconst debbugs-wsdl
  90   (soap-load-wsdl
  91    (expand-file-name
  92     "Debbugs.wsdl"
  93     (if load-in-progress
  94         (file-name-directory load-file-name)
  95       default-directory)))
  96   "The WSDL object to be used describing the SOAP interface.")
  97
  98 (defun debbugs-get-bugs (&rest query)
  99   "Return a list of bug numbers which match QUERY.
 100
 101 QUERY is a sequence of keyword-value pairs where the values are
 102 strings, i. e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]*
 103
 104 The keyword-value pair is a subquery.  The keywords are allowed to
 105 have multiple occurrence within the query at any place.  The
 106 subqueries with the same keyword form the logical subquery, which
 107 returns the union of bugs of every subquery it contains.
 108
 109 The result of the QUERY is an intersection of results of all
 110 subqueries.
 111
 112 Valid keywords are:
 113
 114   :package -- The value is the name of the package a bug belongs
 115   to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".
 116
 117   :src -- This is used to retrieve bugs that belong to source
 118   with given name.
 119
 120   :severity -- This is the severity of the bug.  The exact set of
 121   allowed values depends on the Debbugs port.  Examples are
 122   \"normal\", \"minor\", \"wishlist\" etc.
 123
 124   :tag -- An arbitrary string the bug is annotated with.
 125   Usually, this is used to mark the status of the bug, like
 126   \"fixed\", \"moreinfo\", \"notabug\", \"patch\",
 127   \"unreproducible\" or \"wontfix\".  The exact set of tags
 128   depends on the Debbugs port.
 129
 130   :owner -- This is used to identify bugs by the owner's email
 131   address.  The special email address \"me\" is used as pattern,
 132   replaced with `user-mail-address'.
 133
 134   :submitter -- With this keyword it is possible to filter bugs
 135   by the submitter's email address.  The special email address
 136   \"me\" is used as pattern, replaced with `user-mail-address'.
 137
 138   :maint -- This is used to find bugs of the packages which are
 139   maintained by the person with the given email address.  The
 140   special email address \"me\" is used as pattern, replaced with
 141   `user-mail-address'.
 142
 143   :correspondent -- This allows to find bug reports where the
 144   person with the given email address has participated.  The
 145   special email address \"me\" is used as pattern, replaced with
 146   `user-mail-address'.
 147
 148   :affects -- With this keyword it is possible to find bugs which
 149   affect the package with the given name.  The bugs are chosen by
 150   the value of field `affects' in bug's status.  The returned bugs
 151   do not necessary belong to this package.
 152
 153   :status -- Status of bug.  Valid values are \"done\",
 154   \"forwarded\" and \"open\".
 155
 156   :archive -- A keyword to filter for bugs which are already
 157   archived, or not.  Valid values are \"0\" (not archived),
 158   \"1\" (archived) or \"both\".  If this keyword is not given in
 159   the query, `:archive \"0\"' is assumed by default.
 160
 161 Example.  Get all opened and forwarded release critical bugs for
 162 the packages which are maintained by \"me\" and which have a
 163 patch:
 164
 165   \(debbugs-get-bugs :maint \"me\" :tag \"patch\"
 166                      :severity \"critical\"
 167                      :status \"open\"
 168                      :severity \"grave\"
 169                      :status \"forwarded\"
 170                      :severity \"serious\"))"
 171
 172   (let (vec kw key val)
 173     ;; Check query.
 174     (while (and (consp query) (<= 2 (length query)))
 175       (setq kw (pop query)
 176             val (pop query))
 177       (unless (and (keywordp kw) (stringp val))
 178         (error "Wrong query: %s %s" kw val))
 179       (setq key (substring (symbol-name kw) 1))
 180       (case kw
 181         ((:package :severity :tag :src :affects)
 182          ;; Value shall be one word.
 183          (if (string-match "\\`\\S-+\\'" val)
 184              (setq vec (vconcat vec (list key val)))
 185            (error "Wrong %s: %s" key val)))
 186         ((:owner :submitter :maint :correspondent)
 187          ;; Value is an email address.
 188          (if (string-match "\\`\\S-+\\'" val)
 189              (progn
 190                (when (string-equal "me" val)
 191                  (setq val user-mail-address))
 192                (when (string-match "<\\(.+\\)>" val)
 193                  (setq val (match-string 1 val)))
 194                (setq vec (vconcat vec (list key val))))
 195            (error "Wrong %s: %s" key val)))
 196         (:status
 197          ;; Possible values: "done", "forwarded" and "open"
 198          (if (string-match "\\`\\(done\\|forwarded\\|open\\)\\'" val)
 199              (setq vec (vconcat vec (list key val)))
 200            (error "Wrong %s: %s" key val)))
 201         (:archive
 202          ;; Value is `0' or `1' or `both'.
 203          (if (string-match "\\`\\(0\\|1\\|both\\)\\'" val)
 204              (setq vec (vconcat vec (list key val)))
 205            (error "Wrong %s: %s" key val)))
 206         (t (error "Unknown key: %s" kw))))
 207
 208     (unless (null query)
 209       (error "Unknown key: %s" (car query)))
 210     (sort (car (soap-invoke debbugs-wsdl debbugs-port "get_bugs" vec)) '<)))
 211
 212 (defun debbugs-newest-bugs (amount)
 213   "Return the list of bug numbers, according to AMOUNT (a number) latest bugs."
 214   (sort (car (soap-invoke debbugs-wsdl debbugs-port "newest_bugs" amount)) '<))
 215
 216 (defun debbugs-get-status (&rest bug-numbers)
 217   "Return a list of status entries for the bugs identified by BUG-NUMBERS.
 218
 219 Every returned entry is an association list with the following attributes:
 220
 221   `bug_num': The bug number.
 222
 223   `package': A list of package names the bug belongs to.
 224
 225   `severity': The severity of the bug report. This can be
 226   \"important\", \"grave\", \"normal\", \"minor\" or \"wishlist\".
 227
 228   `tags': The status of the bug report, a list of strings.  This
 229   can be \"fixed\", \"notabug\", \"wontfix\", \"unreproducible\",
 230   \"moreinfo\" or \"patch\".
 231
 232   `pending': The string \"pending\", \"forwarded\" or \"done\".
 233
 234   `subject': Subject/Title of the bugreport.
 235
 236   `originator': Submitter of the bugreport.
 237
 238   `mergedwith': A list of bug numbers this bug was merged with.
 239
 240   `source': Source package name of the bug report.
 241
 242   `date': Date of bug creation.
 243
 244   `log_modified', `last_modified': Date of last update.
 245
 246   `found_date', `fixed_date': Date of bug report / bug fix
 247   \(empty for now).
 248
 249   `done': The email address of the worker who has closed the bug (if done).
 250
 251   `archived': `t' if the bug is archived, `nil' otherwise.
 252
 253   `unarchived': The date the bug has been unarchived, if ever.
 254
 255   `found_versions', `fixed_versions': List of version strings.
 256
 257   `forwarded': A URL or an email address.
 258
 259   `blocks': A list of bug numbers this bug blocks.
 260
 261   `blockedby': A list of bug numbers this bug is blocked by.
 262
 263   `msgid': The message id of the initial bug report.
 264
 265   `owner': Who is responsible for fixing.
 266
 267   `location': Always the string \"db-h\" or \"archive\".
 268
 269   `affects': A list of package names.
 270
 271   `summary': Arbitrary text.
 272
 273 Example:
 274
 275   \(debbugs-get-status 10)
 276
 277   => ;; Attributes with empty values are not show
 278      \(\(\(bug_num . 10)
 279        \(source . \"unknown\")
 280        \(date . 1203606305.0)
 281        \(msgid . \"<87zltuz7eh.fsf@freemail.hu>\")
 282        \(severity . \"wishlist\")
 283        \(owner . \"Magnus Henoch <mange@freemail.hu>\")
 284        \(log_modified . 1261079402.0)
 285        \(location . \"db-h\")
 286        \(subject . \"url-gw should support HTTP CONNECT proxies\")
 287        \(originator . \"Magnus Henoch <mange@freemail.hu>\")
 288        \(last_modified . 1271200046.0)
 289        \(pending . \"pending\")
 290        \(package \"emacs\")))"
 291   (let ((object
 292          (car
 293           (soap-invoke
 294            debbugs-wsdl debbugs-port "get_status"
 295            (apply 'vector bug-numbers)))))
 296     (mapcar
 297      (lambda (x)
 298        (let (y)
 299          ;; "archived" is the number 1 or 0.
 300          (setq y (assoc 'archived (cdr (assoc 'value x))))
 301          (setcdr y (= (cdr y) 1))
 302          ;; "found_versions" and "fixed_versions" are lists,
 303          ;; containing strings or numbers.
 304          (dolist (attribute '(found_versions fixed_versions))
 305            (setq y (assoc attribute (cdr (assoc 'value x))))
 306            (setcdr y (mapcar
 307                       (lambda (z) (if (numberp z) (number-to-string z) z))
 308                       (cdr y))))
 309          ;; "mergedwith" is a string, containing blank separated bug numbers.
 310          (setq y (assoc 'mergedwith (cdr (assoc 'value x))))
 311          (when (stringp (cdr y))
 312            (setcdr y (mapcar 'string-to-number (split-string (cdr y) " " t))))
 313          ;; "package" is a string, containing comma separated package names.
 314          ;; "keywords" and "tags" are strings, containing blank
 315          ;; separated package names.
 316          (dolist (attribute '(package keywords tags))
 317            (setq y (assoc attribute (cdr (assoc 'value x))))
 318            (when (stringp (cdr y))
 319              (setcdr y (split-string (cdr y) ",\\| " t))))
 320          (cdr (assoc 'value x))))
 321      object)))
 322
 323 (defun debbugs-get-bug-log (bug-number)
 324   "Return a list of messages related to BUG-NUMBER.
 325
 326 Every message is an association list with the following attributes:
 327
 328   `msg_num': The number of the message inside the bug log.  The
 329   numbers are ascending, newer messages have a higher number.
 330
 331   `header': The message header lines, as arrived at the bug tracker.
 332
 333   `body': The message body.
 334
 335   `attachments' A list of possible attachments, or `nil'.  Not
 336   implemented yet server side."
 337   (car (soap-invoke debbugs-wsdl debbugs-port "get_bug_log" bug-number)))
 338
 339 (defun debbugs-get-attribute (bug-or-message attribute)
 340   "Return the value of key ATTRIBUTE.
 341
 342 BUG-OR-MESSAGE must be list element returned by either
 343 `debbugs-get-status' or `debbugs-get-bug-log'.
 344
 345 Example: Return the originator of last submitted bug.
 346
 347 \(debbugs-get-attribute
 348   \(car \(apply 'debbugs-get-status \(debbugs-newest-bugs 1))) 'originator)"
 349   (cdr (assoc attribute bug-or-message)))
 350
 351 (defun debbugs-get-message-numbers (messages)
 352   "Return the message numbers of MESSAGES.
 353 MESSAGES must be the result of a `debbugs-get-bug-log' call."
 354   (mapcar (lambda (x) (debbugs-get-attribute x 'msg_num)) messages))
 355
 356 (defun debbugs-get-message (messages message-number)
 357   "Return the message MESSAGE-NUMBER of MESSAGES.
 358 MESSAGES must be the result of a `debbugs-get-bug-log' call.
 359
 360 The returned message is a list of strings.  The first element are
 361 the header lines of the message, the second element is the body
 362 of the message.  Further elements of the list, if any, are
 363 attachments of the message.
 364
 365 If there is no message with MESSAGE-NUMBER, the function returns `nil'.
 366
 367 Example: Return the first message of last submitted bug.
 368
 369 \(let \(\(messages \(apply 'debbugs-get-bug-log \(debbugs-newest-bugs 1))))
 370   \(debbugs-get-message messages
 371                        \(car \(debbugs-get-message-numbers messages))))"
 372   (while (and messages
 373               (/= (debbugs-get-attribute (car messages) 'msg_num)
 374                   message-number))
 375     (setq messages (cdr messages)))
 376   (when messages
 377     (append (list (debbugs-get-attribute (car messages) 'header)
 378                   (debbugs-get-attribute (car messages) 'body))
 379             (debbugs-get-attribute (car messages) 'attachments))))
 380
 381 (defun debbugs-get-mbox (bug-number mbox-type &optional filename)
 382   "Download mbox with messages of bug BUG-NUMBER from Debbugs server.
 383 BUG-NUMBER is a number of bug. It must be of integer type.
 384
 385 MBOX-TYPE specifies a type of mbox and can be one of the
 386 following symbols:
 387
 388    `mboxfolder': Download mbox folder.
 389
 390    `mboxmaint': Download maintainer's mbox.
 391
 392    `mboxstat', `mboxstatus': Download status mbox. The use of
 393    either symbol depends on actual Debbugs server
 394    configuration. For gnu.org, use the former; for debian.org -
 395    the latter.
 396
 397 FILENAME, if non-nil, is the name of file to store mbox. If
 398 FILENAME is nil, the downloaded mbox is inserted into the current
 399 buffer."
 400   (let (url (mt "") bn)
 401     (unless (setq url (plist-get
 402                        (cdr (assoc debbugs-port debbugs-servers))
 403                        :bugreport-url))
 404       (error "URL of bugreport script for port %s is not specified"
 405              debbugs-port))
 406     (setq bn (format "bug=%s;" (number-to-string bug-number)))
 407     (unless (eq mbox-type 'mboxfolder)
 408       (if (memq mbox-type '(mboxmaint mboxstat mboxstatus))
 409           (setq mt (concat (symbol-name mbox-type) "=yes;"))
 410         (error "Unknown mbox type: %s" mbox-type)))
 411     (setq url (concat url (format "?%s%smbox=yes" bn mt)))
 412     (if filename
 413         (url-copy-file url filename t)
 414       (url-insert-file-contents url))))
 415
 416 (provide 'debbugs)
 417
 418 ;;; TODO:
 419
 420 ;; * SOAP interface extensions (wishlist).
 421 ;;   - Server-side sorting.
 422 ;;   - Regexp and/or wildcards search.
 423 ;;   - Fulltext search.
 424 ;;   - Returning message attachments.
 425
 426 ;;; debbugs.el ends here