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

   1 ;;; debbugs.el --- SOAP library to access debbugs servers  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Keywords: comm, hypermedia
   7 ;; Package: debbugs
   8 ;; Version: 0.9.7
   9 ;; Package-Requires: ((soap-client "3.1.1") (cl-lib "0.5"))
  10
  11 ;; This file is not part of GNU Emacs.
  12
  13 ;; This program is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This package provides basic functions to access a Debbugs SOAP
  29 ;; server (see <http://wiki.debian.org/DebbugsSoapInterface>).
  30
  31 ;; The function "get_versions" is not implemented (yet).  "search_est"
  32 ;; is an extension on <http://debbugs.gnu.org>.
  33
  34 ;;; Code:
  35
  36 ;(setq soap-debug t message-log-max t)
  37 (require 'soap-client)
  38 (eval-when-compile (require 'cl-lib))
  39
  40 (defgroup debbugs nil
  41   "Debbugs library"
  42   :group 'hypermedia)
  43
  44 (defcustom debbugs-servers
  45   '(("gnu.org"
  46      :wsdl "http://debbugs.gnu.org/cgi/soap.cgi?WSDL"
  47      :bugreport-url "http://debbugs.gnu.org/cgi/bugreport.cgi")
  48     ("debian.org"
  49      :wsdl "http://bugs.debian.org/cgi-bin/soap.cgi?WSDL"
  50      :bugreport-url "http://bugs.debian.org/cgi-bin/bugreport.cgi"))
  51   "*List of Debbugs server specifiers.
  52 Each entry is a list that contains a string identifying the port
  53 name and the server parameters in keyword-value form. Allowed
  54 keywords are:
  55
  56 `:wsdl' -- Location of WSDL. The value is a string with URL that
  57 should return the WSDL specification of Debbugs/SOAP service.
  58
  59 `:bugreport-url' -- URL of the server script that returns mboxes
  60 with bug logs.
  61
  62 The list initially contains two predefined and configured Debbugs
  63 servers: \"gnu.org\" and \"debian.org\"."
  64   :group 'debbugs
  65   :link '(custom-manual "(debbugs)Debbugs server specifiers")
  66   :type '(choice
  67           (const nil)
  68           (repeat
  69            (cons :tag "Server"
  70                  (string :tag "Port name")
  71                  (checklist :tag "Options" :greedy t
  72                             (group :inline t
  73                                    (const :format "" :value :wsdl)
  74                                    (string :tag "WSDL"))
  75                             (group :inline t
  76                                    (const :format "" :value :bugreport-url)
  77                                    (string :tag "Bugreport URL")))))))
  78
  79 (defcustom debbugs-port "gnu.org"
  80   "The port instance to be applied from `debbugs-wsdl'.
  81 This corresponds to the Debbugs server to be accessed, either
  82 \"gnu.org\", or \"debian.org\", or user defined port name."
  83   ;; Maybe we should create an own group?
  84   :group 'debbugs
  85   :type '(choice :tag "Debbugs server" (const "gnu.org") (const "debian.org")
  86                  (string :tag "user defined port name")))
  87
  88 ;; It would be nice if we could retrieve it from the debbugs server.
  89 ;; Not supported yet.
  90 (defconst debbugs-wsdl
  91   (soap-load-wsdl
  92    (expand-file-name
  93     "Debbugs.wsdl"
  94     (if load-in-progress
  95         (file-name-directory load-file-name)
  96       default-directory)))
  97   "The WSDL object to be used describing the SOAP interface.")
  98
  99 ;; Please do not increase this value, otherwise we would run into
 100 ;; performance problems on the server.  Maybe we need to change this a
 101 ;; server specific value.
 102 (defconst debbugs-max-hits-per-request 500
 103   "The max number of bugs or results per soap invocation.")
 104
 105 (defvar debbugs-cache-data
 106   (make-hash-table :test 'equal :size debbugs-max-hits-per-request)
 107   "Hash table of retrieved bugs.")
 108
 109 (defcustom debbugs-cache-expiry (* 60 60)
 110   "How many seconds debbugs query results are cached.
 111 t or 0 disables caching, nil disables expiring."
 112   :group 'debbugs
 113   :type '(choice (const :tag "Always" t)
 114                  (const :tag "Never" nil)
 115                  (integer :tag "Seconds")))
 116
 117 (defvar debbugs-soap-invoke-async-object nil
 118   "The object manipulated by `debbugs-soap-invoke-async'.")
 119
 120 (defun debbugs-soap-invoke-async (operation-name &rest parameters)
 121   "Invoke the SOAP connection asynchronously."
 122   (apply
 123    #'soap-invoke-async
 124    (lambda (response &rest _args)
 125      (setq debbugs-soap-invoke-async-object
 126            (append debbugs-soap-invoke-async-object (car response))))
 127    nil debbugs-wsdl debbugs-port operation-name parameters))
 128
 129 (defun debbugs-get-bugs (&rest query)
 130   "Return a list of bug numbers which match QUERY.
 131
 132 QUERY is a sequence of keyword-value pairs where the values are
 133 strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]*
 134
 135 The keyword-value pair is a subquery.  The keywords are allowed to
 136 have multiple occurrence within the query at any place.  The
 137 subqueries with the same keyword form the logical subquery, which
 138 returns the union of bugs of every subquery it contains.
 139
 140 The result of the QUERY is an intersection of results of all
 141 subqueries.
 142
 143 Valid keywords are:
 144
 145   :package -- The value is the name of the package a bug belongs
 146   to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".
 147
 148   :src -- This is used to retrieve bugs that belong to source
 149   with given name.
 150
 151   :severity -- This is the severity of the bug.  The exact set of
 152   allowed values depends on the Debbugs port.  Examples are
 153   \"normal\", \"minor\", \"wishlist\" etc.
 154
 155   :tag -- An arbitrary string the bug is annotated with.
 156   Usually, this is used to mark the status of the bug, like
 157   \"fixed\", \"moreinfo\", \"notabug\", \"patch\",
 158   \"unreproducible\" or \"wontfix\".  The exact set of tags
 159   depends on the Debbugs port.
 160
 161   :owner -- This is used to identify bugs by the owner's email
 162   address.  The special email address \"me\" is used as pattern,
 163   replaced with `user-mail-address'.
 164
 165   :submitter -- With this keyword it is possible to filter bugs
 166   by the submitter's email address.  The special email address
 167   \"me\" is used as pattern, replaced with `user-mail-address'.
 168
 169   :maint -- This is used to find bugs of the packages which are
 170   maintained by the person with the given email address.  The
 171   special email address \"me\" is used as pattern, replaced with
 172   `user-mail-address'.
 173
 174   :correspondent -- This allows to find bug reports where the
 175   person with the given email address has participated.  The
 176   special email address \"me\" is used as pattern, replaced with
 177   `user-mail-address'.
 178
 179   :affects -- With this keyword it is possible to find bugs which
 180   affect the package with the given name.  The bugs are chosen by
 181   the value of field `affects' in bug's status.  The returned bugs
 182   do not necessary belong to this package.
 183
 184   :status -- Status of bug.  Valid values are \"open\",
 185   \"forwarded\" and \"done\".
 186
 187   :archive -- A keyword to filter for bugs which are already
 188   archived, or not.  Valid values are \"0\" (not archived),
 189   \"1\" (archived) or \"both\".  If this keyword is not given in
 190   the query, `:archive \"0\"' is assumed by default.
 191
 192 Example.  Get all opened and forwarded release critical bugs for
 193 the packages which are maintained by \"me\" and which have a
 194 patch:
 195
 196   \(debbugs-get-bugs :maint \"me\" :tag \"patch\"
 197                      :severity \"critical\"
 198                      :status \"open\"
 199                      :severity \"grave\"
 200                      :status \"forwarded\"
 201                      :severity \"serious\")"
 202
 203   (let (vec kw key val)
 204     ;; Check query.
 205     (while (and (consp query) (<= 2 (length query)))
 206       (setq kw (pop query)
 207             val (pop query))
 208       (unless (and (keywordp kw) (stringp val))
 209         (error "Wrong query: %s %s" kw val))
 210       (setq key (substring (symbol-name kw) 1))
 211       (cl-case kw
 212         ((:package :severity :tag :src :affects)
 213          ;; Value shall be one word.
 214          (if (string-match "\\`\\S-+\\'" val)
 215              (setq vec (vconcat vec (list key val)))
 216            (error "Wrong %s: %s" key val)))
 217         ((:owner :submitter :maint :correspondent)
 218          ;; Value is an email address.
 219          (if (string-match "\\`\\S-+\\'" val)
 220              (progn
 221                (when (string-equal "me" val)
 222                  (setq val user-mail-address))
 223                (when (string-match "<\\(.+\\)>" val)
 224                  (setq val (match-string 1 val)))
 225                (setq vec (vconcat vec (list key val))))
 226            (error "Wrong %s: %s" key val)))
 227         (:status
 228          ;; Possible values: "open", "forwarded" and "done".
 229          (if (string-match "\\`\\(open\\|forwarded\\|done\\)\\'" val)
 230              (setq vec (vconcat vec (list key val)))
 231            (error "Wrong %s: %s" key val)))
 232         (:archive
 233          ;; Value is `0' or `1' or `both'.
 234          (if (string-match "\\`\\(0\\|1\\|both\\)\\'" val)
 235              (setq vec (vconcat vec (list key val)))
 236            (error "Wrong %s: %s" key val)))
 237         (t (error "Unknown key: %s" kw))))
 238
 239     (unless (null query)
 240       (error "Unknown key: %s" (car query)))
 241     (sort (car (soap-invoke debbugs-wsdl debbugs-port "get_bugs" vec)) '<)))
 242
 243 (defun debbugs-newest-bugs (amount)
 244   "Return the list of bug numbers, according to AMOUNT (a number) latest bugs."
 245   (if (= amount 1)
 246       ;; We cache it as bug "0" in `debbugs-cache-data'.
 247       (let ((status (gethash 0 debbugs-cache-data)))
 248         (unless (and
 249                  status
 250                  (or
 251                   (null debbugs-cache-expiry)
 252                   (and
 253                    (natnump debbugs-cache-expiry)
 254                    (> (cdr (assoc 'cache_time status))
 255                       (- (float-time) debbugs-cache-expiry)))))
 256           ;; Due to `debbugs-gnu-completion-table', this function
 257           ;; could be called in rapid sequence.  We cache temporarily
 258           ;; the value nil, therefore.
 259           (when (natnump debbugs-cache-expiry)
 260             (puthash
 261              0
 262              (list (cons 'cache_time (1+ (- (float-time) debbugs-cache-expiry)))
 263                    (list 'newest_bug))
 264              debbugs-cache-data))
 265           ;; Compute the value.
 266           (setq
 267            status
 268            (list
 269             (cons 'cache_time (float-time))
 270             (cons 'newest_bug
 271                   (caar
 272                    (soap-invoke
 273                     debbugs-wsdl debbugs-port "newest_bugs" amount)))))
 274
 275           ;; Cache it.
 276           (when (or (null debbugs-cache-expiry) (natnump debbugs-cache-expiry))
 277             (puthash 0 status debbugs-cache-data)))
 278
 279         ;; Return the value, as list.
 280         (list (cdr (assoc 'newest_bug status))))
 281
 282     (sort
 283      (car (soap-invoke debbugs-wsdl debbugs-port "newest_bugs" amount)) '<)))
 284
 285 (defun debbugs-convert-soap-value-to-string (string-value)
 286   "If STRING-VALUE is unibyte, decode its contents as a UTF-8 string.
 287 If STRING-VALUE is a multibyte string, then `soap-client'
 288 received an xsd:string for this value, and will have decoded it
 289 already.
 290
 291 If STRING-VALUE is a unibyte string, then `soap-client' received
 292 an xsd:base64Binary, and ran `base64-decode-string' on it to
 293 produce a unibyte string of bytes.
 294
 295 For some reason, the Debbugs server code base64-encodes strings
 296 that contain UTF-8 characters, and returns them as
 297 xsd:base64Binary, instead of just returning them as xsd:string.
 298 Therefore, when STRING-VALUE is a unibyte string, we assume its
 299 bytes represent a UTF-8 string and decode them accordingly."
 300   (if (stringp string-value)
 301       (if (not (multibyte-string-p string-value))
 302           (decode-coding-string string-value 'utf-8)
 303         string-value)
 304     (error "Invalid string value")))
 305
 306 (defun debbugs-get-status (&rest bug-numbers)
 307   "Return a list of status entries for the bugs identified by BUG-NUMBERS.
 308
 309 Every returned entry is an association list with the following attributes:
 310
 311   `bug_num': The bug number.
 312
 313   `package': A list of package names the bug belongs to.
 314
 315   `severity': The severity of the bug report. This can be
 316   \"critical\", \"grave\", \"serious\", \"important\",
 317   \"normal\", \"minor\" or \"wishlist\".
 318
 319   `tags': The status of the bug report, a list of strings.  This
 320   can be \"fixed\", \"notabug\", \"wontfix\", \"unreproducible\",
 321   \"moreinfo\" or \"patch\".
 322
 323   `pending': The string \"pending\", \"forwarded\", \"fixed\" or \"done\".
 324
 325   `subject': Subject/Title of the bugreport.
 326
 327   `originator': Submitter of the bugreport.
 328
 329   `mergedwith': A list of bug numbers this bug was merged with.
 330   If it is a single bug, then this attribute contains just a
 331   number.
 332
 333   `source': Source package name of the bug report.
 334
 335   `date': Date of bug creation.
 336
 337   `log_modified', `last_modified': Date of last update.
 338
 339   `found_date', `fixed_date': Date of bug report / bug fix
 340   \(empty for now).
 341
 342   `done': The email address of the worker who has closed the bug (if done).
 343
 344   `archived': t if the bug is archived, nil otherwise.
 345
 346   `unarchived': The date the bug has been unarchived, if ever.
 347
 348   `found_versions', `fixed_versions': List of version strings.
 349
 350   `forwarded': A URL or an email address.
 351
 352   `blocks': A list of bug numbers this bug blocks.
 353
 354   `blockedby': A list of bug numbers this bug is blocked by.
 355
 356   `msgid': The message id of the initial bug report.
 357
 358   `owner': Who is responsible for fixing.
 359
 360   `location': Always the string \"db-h\" or \"archive\".
 361
 362   `affects': A list of package names.
 363
 364   `summary': Arbitrary text.
 365
 366 Example:
 367
 368   \(debbugs-get-status 10)
 369
 370   => ;; Attributes with empty values are not shown
 371      \(\(\(bug_num . 10)
 372        \(source . \"unknown\")
 373        \(date . 1203606305.0)
 374        \(msgid . \"<87zltuz7eh.fsf@freemail.hu>\")
 375        \(severity . \"wishlist\")
 376        \(owner . \"Magnus Henoch <mange@freemail.hu>\")
 377        \(log_modified . 1261079402.0)
 378        \(location . \"db-h\")
 379        \(subject . \"url-gw should support HTTP CONNECT proxies\")
 380        \(originator . \"Magnus Henoch <mange@freemail.hu>\")
 381        \(last_modified . 1271200046.0)
 382        \(pending . \"pending\")
 383        \(package \"emacs\")))"
 384   (let (cached-bugs)
 385     ;; Check for cached bugs.
 386     (setq bug-numbers (delete-dups bug-numbers)
 387           bug-numbers
 388           (delete
 389            nil
 390            (mapcar
 391             (lambda (bug)
 392               (let ((status (gethash bug debbugs-cache-data)))
 393                 (if (and
 394                      status
 395                      (or
 396                       (null debbugs-cache-expiry)
 397                       (and
 398                        (natnump debbugs-cache-expiry)
 399                        (> (cdr (assoc 'cache_time status))
 400                           (- (float-time) debbugs-cache-expiry)))))
 401                     (progn
 402                       (setq cached-bugs (append cached-bugs (list status)))
 403                       nil)
 404                   bug)))
 405             bug-numbers)))
 406
 407     ;; Retrieve the data.
 408     (setq debbugs-soap-invoke-async-object nil)
 409     (when bug-numbers
 410       ;; Retrieve bugs asynchronously.
 411       (let ((bug-ids bug-numbers)
 412             results)
 413         (while bug-ids
 414           (setq results
 415                 (append
 416                  results
 417                  (list
 418                   (debbugs-soap-invoke-async
 419                    "get_status"
 420                    (apply
 421                     #'vector
 422                     (butlast
 423                      bug-ids (- (length bug-ids)
 424                                 debbugs-max-hits-per-request))))))
 425
 426                 bug-ids
 427                 (last bug-ids (- (length bug-ids)
 428                                  debbugs-max-hits-per-request))))
 429
 430         (dolist (res results)
 431           (while (buffer-live-p res)
 432             (accept-process-output (get-buffer-process res) 0.1)))))
 433
 434     (append
 435      cached-bugs
 436      ;; Massage results.
 437      (mapcar
 438       (lambda (x)
 439         (let (y)
 440           ;; "archived" is the number 1 or 0.
 441           (setq y (assoc 'archived (cdr (assoc 'value x))))
 442           (setcdr y (= (cdr y) 1))
 443           ;; "found_versions" and "fixed_versions" are lists,
 444           ;; containing strings or numbers.
 445           (dolist (attribute '(found_versions fixed_versions))
 446             (setq y (assoc attribute (cdr (assoc 'value x))))
 447             (setcdr y (mapcar
 448                        (lambda (z) (if (numberp z) (number-to-string z) z))
 449                        (cdr y))))
 450           ;; "mergedwith", "blocks" and "blockedby are strings,
 451           ;; containing blank separated bug numbers.
 452           (dolist (attribute '(mergedwith blocks blockedby))
 453             (setq y (assoc attribute (cdr (assoc 'value x))))
 454             (when (stringp (cdr y))
 455               (setcdr y (mapcar
 456                          #'string-to-number (split-string (cdr y) " " t)))))
 457           ;; "subject", "originator", "owner" and "summary" may be an
 458           ;; xsd:base64Binary value containing a UTF-8-encoded string.
 459           (dolist (attribute '(subject originator owner summary))
 460             (setq y (assoc attribute (cdr (assoc 'value x))))
 461             (when (stringp (cdr y))
 462               (setcdr y (debbugs-convert-soap-value-to-string (cdr y)))))
 463           ;; "package" is a string, containing comma separated
 464           ;; package names.  "keywords" and "tags" are strings,
 465           ;; containing blank separated package names.
 466           (dolist (attribute '(package keywords tags))
 467             (setq y (assoc attribute (cdr (assoc 'value x))))
 468             (when (stringp (cdr y))
 469               (setcdr y (split-string (cdr y) ",\\| " t))))
 470           ;; Cache the result, and return.
 471           (if (or (null debbugs-cache-expiry) (natnump debbugs-cache-expiry))
 472               (puthash
 473                (cdr (assoc 'key x))
 474                ;; Put also a time stamp.
 475                (cons (cons 'cache_time (float-time))
 476                      (cdr (assoc 'value x)))
 477                debbugs-cache-data)
 478             ;; Don't cache.
 479             (cdr (assoc 'value x)))))
 480       debbugs-soap-invoke-async-object))))
 481
 482 (defun debbugs-get-usertag (&rest query)
 483   "Return a list of bug numbers which match QUERY.
 484
 485 QUERY is a sequence of keyword-value pairs where the values are
 486 strings, i.e. :KEYWORD \"VALUE\" [:KEYWORD \"VALUE\"]*
 487
 488 Valid keywords are:
 489
 490   :user -- The value is the name of the package a bug belongs to,
 491   like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".  It can
 492   also be an email address of a user who has applied a user tag.
 493   The special email address \"me\" is used as pattern, replaced
 494   with `user-mail-address'.  There must be at least one such
 495   entry; it is recommended to have exactly one.
 496
 497   :tag -- A string applied as user tag.  Often, it is a
 498   subproduct identification, like \"cedet\" or \"tramp\" for the
 499   package \"emacs\".
 500
 501 If there is no :tag entry, no bug numbers will be returned but a list of
 502 existing user tags for :user.
 503
 504 Example:
 505
 506   \(debbugs-get-usertag :user \"emacs\")
 507
 508   => (\"www\" \"solaris\" \"ls-lisp\" \"cygwin\")
 509
 510   \(debbugs-get-usertag :user \"emacs\" :tag \"www\" :tag \"cygwin\")
 511
 512   => (807 1223 5637)"
 513
 514   (let (user tags kw key val object result)
 515     ;; Check query.
 516     (while (and (consp query) (<= 2 (length query)))
 517       (setq kw (pop query)
 518             val (pop query))
 519       (unless (and (keywordp kw) (stringp val))
 520         (error "Wrong query: %s %s" kw val))
 521       (setq key (substring (symbol-name kw) 1))
 522       (cl-case kw
 523         ((:user)
 524          ;; Value shall be one word.  Extract email address, if existing.
 525          (if (string-match "\\`\\S-+\\'" val)
 526              (progn
 527                (when (string-equal "me" val)
 528                  (setq val user-mail-address))
 529                (when (string-match "<\\(.+\\)>" val)
 530                  (setq val (match-string 1 val)))
 531                (cl-pushnew val user :test #'equal))
 532            (error "Wrong %s: %s" key val)))
 533         ((:tag)
 534          ;; Value shall be one word.
 535          (if (string-match "\\`\\S-+\\'" val)
 536              (cl-pushnew val tags :test #'equal)
 537            (error "Wrong %s: %s" key val)))
 538         (t (error "Unknown key: %s" kw))))
 539
 540     (unless (null query)
 541       (error "Unknown key: %s" (car query)))
 542     (unless (= (length user) 1)
 543       (error "There must be exactly one :user entry"))
 544
 545     (setq
 546      object
 547      (car (soap-invoke debbugs-wsdl debbugs-port "get_usertag" (car user))))
 548
 549     (if (null tags)
 550         ;; Return the list of existing tags.
 551         (mapcar (lambda (x) (symbol-name (car x))) object)
 552
 553       ;; Return bug numbers.
 554       (dolist (elt object result)
 555         (when (member (symbol-name (car elt)) tags)
 556           (setq result (append (cdr elt) result)))))))
 557
 558 (defun debbugs-get-bug-log (bug-number)
 559   "Return a list of messages related to BUG-NUMBER.
 560
 561 Every message is an association list with the following attributes:
 562
 563   `msg_num': The number of the message inside the bug log.  The
 564   numbers are ascending, newer messages have a higher number.
 565
 566   `header': The message header lines, as arrived at the bug tracker.
 567
 568   `body': The message body.
 569
 570   `attachments' A list of possible attachments, or nil.  Not
 571   implemented yet server side."
 572   (car (soap-invoke debbugs-wsdl debbugs-port "get_bug_log" bug-number)))
 573
 574 (defun debbugs-search-est (&rest query)
 575   "Return the result of a full text search according to QUERY.
 576
 577 QUERY is a sequence of lists of keyword-value pairs where the
 578 values are strings or numbers, i.e. :KEYWORD \"VALUE\" [:KEYWORD
 579 VALUE]*
 580
 581 Every sublist of the QUERY forms a hyperestraier condition.  A
 582 detailed description of hyperestraier conditions can be found at
 583 URL `http://fallabs.com/hyperestraier/uguide-en.html#searchcond'.
 584
 585 The following conditions are possible:
 586
 587 \[:phrase SEARCH-PHRASE :skip NUMBER :max NUMBER\]
 588
 589   The string SEARCH-PHRASE forms the search on the database.  It
 590   contains words to be searched for, combined by operators like
 591   AND, ANDNOT and OR.  If there is no operator between the words,
 592   AND is used by default.  The phrase keyword and value can also
 593   be omitted, this is useful in combination with other conditions.
 594
 595   :skip and :max are optional.  They specify, how many hits are
 596   skipped, and how many maximal hits are returned.  This can be
 597   used for paged results.  Per default, :skip is 0 and all
 598   possible hits are returned.
 599
 600   There must be exactly one such condition.
 601
 602 \[ATTRIBUTE VALUE+ :operation OPERATION :order ORDER\]
 603
 604   ATTRIBUTE is one of the following keywords:
 605
 606   :subject, :@title -- The subject of a message or the title of
 607   the bug, a string.
 608
 609   :date, :@cdate -- The submission or modification dates of a
 610   message, a number.
 611
 612   :@author -- The email address of the author of a message
 613   belonging to this bug, a string.  It may be different than
 614   the email of the person submitting the bug.
 615   The special email address \"me\" is used as pattern, replaced
 616   with `user-mail-address'.
 617
 618   :package -- The value is the name of the package a bug belongs
 619   to, like \"emacs\", \"coreutils\", \"gnus\", or \"tramp\".
 620
 621   :tags -- An arbitrary string the bug is annotated with.
 622
 623   :severity -- This is the severity of the bug.  The exact set of
 624   allowed values depends on the Debbugs port.  Examples are
 625   \"normal\", \"minor\", \"wishlist\" etc.
 626
 627   :operator defines the comparison operator to be applied to
 628   ATTRIBUTE.  For string attributes this could be \"STREQ\" \(is
 629   equal to the string), \"STRNE\" \(is not equal to the string),
 630   \"STRINC\" \(includes the string), \"STRBW\" \(begins with the
 631   string), \"STREW\" \(ends with the string), \"STRAND\"
 632   \(includes all tokens in the string), \"STROR\" \(includes at
 633   least one token in the string), \"STROREQ\" \(is equal to at
 634   least one token in the string) or \"STRRX\" \(matches regular
 635   expressions of the string).  For operators with tokens, several
 636   values for ATTRIBUTE shall be used.
 637
 638   Numbers can be compared by the operators \"NUMEQ\" \(is equal
 639   to the number), \"NUMNE\" \(is not equal to the number),
 640   \"NUMGT\" \(is greater than the number), \"NUMGE\" \(is greater
 641   than or equal to the number), \"NUMLT\" \(is less than the
 642   number), \"NUMLE\" \(is less than or equal to the number) or
 643   \"NUMBT\" \(is between the two numbers).  In the last case,
 644   there must be two values for ATTRIBUTE.
 645
 646   If an operator is leaded by \"!\", the meaning is inverted.  If
 647   a string operator is leaded by \"I\", the case of the value is
 648   ignored.
 649
 650   The optional :order can be specified only in one condition.  It
 651   means, that ATTRIBUTE is used for sorting the results.  The
 652   following order operators exist: \"STRA\" \(ascending by
 653   string), \"STRD\" \(descending by string), \"NUMA\" \(ascending
 654   by number) or \"NUMD\" \(descending by number).
 655
 656   A special case is an :order, where there is no corresponding
 657   attribute value and no operator.  In this case, ATTRIBUTE is
 658   not used for the search.
 659
 660 The result of the QUERY is a list of association lists with the
 661 same attributes as in the conditions.  Additional attributes are
 662
 663   `id': The bug number.
 664
 665   `msg_num': The number of the message inside the bug log.
 666
 667   `snippet': The surrounding text found by the search.  For the
 668   syntax of the snippet, consult the hyperestraier user guide.
 669
 670 Examples:
 671
 672   \(debbugs-search-est
 673     \\='\(:phrase \"armstrong AND debbugs\" :skip 10 :max 2)
 674     \\='\(:severity \"normal\" :operator \"STRINC\")
 675     \\='\(:date :order \"NUMA\"))
 676
 677   => \(\(\(msg_num . 21)
 678        \(date . 1229208302)
 679        \(@author . \"Glenn Morris <rgm@gnu.org>\")
 680        \(@title . \"Re: bug#1567: Mailing an archived bug\")
 681        \(id . 1567)
 682        \(severity . \"normal\")
 683        \(@cdate . \"Wed, 17 Dec 2008 14:34:50 -0500\")
 684        \(snippet . \"...\")
 685        \(subject . \"Mailing an archived bug\")
 686        \(package . \"debbugs.gnu.org\"))
 687       ...)
 688
 689   ;; Show all messages from me between 2011-08-01 and 2011-08-31.
 690   \(debbugs-search-est
 691     \\='\(:max 20)
 692     \\='\(:@author \"me\" :operator \"ISTRINC\")
 693     \\=`\(:date
 694       ,\(floor \(float-time \(encode-time 0 0 0  1 8 2011)))
 695       ,\(floor \(float-time \(encode-time 0 0 0 31 8 2011)))
 696       :operator \"NUMBT\"))"
 697
 698   (let ((phrase (assoc :phrase query))
 699         args result)
 700     (if (and phrase (not (member :skip phrase)) (not (member :max phrase)))
 701         ;; We loop, until we have all results.
 702         (let ((skip 0)
 703               (query (delete phrase query))
 704               result1)
 705           (while skip
 706             (setq result1
 707                   (apply
 708                    #'debbugs-search-est
 709                    (append
 710                     (list
 711                      (append
 712                       phrase `(:skip ,skip)
 713                       `(:max ,debbugs-max-hits-per-request)))
 714                     query))
 715                   skip (and (= (length result1) debbugs-max-hits-per-request)
 716                             (+ skip debbugs-max-hits-per-request))
 717                   result (append result result1)))
 718           result)
 719
 720       ;; Compile search arguments.
 721       (dolist (elt query)
 722         ;; FIXME: `vec' is used in an O(N²) way.  It should be a list instead,
 723         ;; on which we push elements, and we only convert it to a vector at
 724         ;; the end.
 725         (let (vec kw key val
 726                   phrase-cond attr-cond)
 727
 728           ;; Phrase is mandatory, even if empty.
 729           (when (and (or  (member :skip elt) (member :max elt))
 730                      (not (member :phrase elt)))
 731             (setq vec (vector "phrase" "")))
 732
 733           ;; Parse condition.
 734           (while (consp elt)
 735             (setq kw (pop elt))
 736             (unless (keywordp kw)
 737               (error "Wrong keyword: %s" kw))
 738             (setq key (substring (symbol-name kw) 1))
 739             (cl-case kw
 740               ;; Phrase condition.
 741               (:phrase
 742                ;; It shouldn't happen in an attribute condition.
 743                (if attr-cond
 744                    (error "Wrong keyword: %s" kw))
 745                (setq phrase-cond t val (pop elt))
 746                ;; Value is a string.
 747                (if (stringp val)
 748                    (setq vec (vconcat vec (list key val)))
 749                  (error "Wrong %s: %s" key val)))
 750
 751               ((:skip :max)
 752                ;; It shouldn't happen in an attribute condition.
 753                (if attr-cond
 754                    (error "Wrong keyword: %s" kw))
 755                (setq phrase-cond t val (pop elt))
 756                ;; Value is a number.
 757                (if (numberp val)
 758                    (setq vec (vconcat vec (list key (number-to-string val))))
 759                  (error "Wrong %s: %s" key val)))
 760
 761               ;; Attribute condition.
 762               ((:submitter :@author)
 763                ;; It shouldn't happen.
 764                (if (or (and (eq kw :submitter) phrase-cond)
 765                        (and (eq kw :@author) attr-cond))
 766                    (error "Wrong keyword: %s" kw))
 767                (if (not (stringp (car elt)))
 768                    (setq vec (vconcat vec (list key "")))
 769                  ;; Value is an email address.
 770                  (while (and (stringp (car elt))
 771                              (string-match "\\`\\S-+\\'" (car elt)))
 772                    (when (string-equal "me" (car elt))
 773                      (setcar elt user-mail-address))
 774                    (when (string-match "<\\(.+\\)>" (car elt))
 775                      (setcar elt (match-string 1 (car elt))))
 776                    (let ((x (pop elt)))
 777                      (unless (member x val)
 778                        (setq val (append val (list x))))))
 779                  (setq vec
 780                        (vconcat
 781                         vec (list key (mapconcat #'identity val " "))))))
 782
 783               (:status
 784                ;; It shouldn't happen in a phrase condition.
 785                (if phrase-cond
 786                    (error "Wrong keyword: %s" kw))
 787                (setq attr-cond t)
 788                (if (not (stringp (car elt)))
 789                    (setq vec (vconcat vec (list key "")))
 790                  ;; Possible values: "open", "forwarded" and "done".
 791                  (while (and (stringp (car elt))
 792                              (string-match
 793                               "\\`\\(open\\|forwarded\\|done\\)\\'" (car elt)))
 794                    (let ((x (pop elt)))
 795                      (unless (member x val)
 796                        (setq val (append val (list x))))))
 797                  (setq vec
 798                        (vconcat
 799                         vec (list key (mapconcat #'identity val " "))))))
 800
 801               ((:subject :package :tags :severity :@title)
 802                ;; It shouldn't happen in a phrase condition.
 803                (if phrase-cond
 804                    (error "Wrong keyword: %s" kw))
 805                (setq attr-cond t)
 806                (if (not (stringp (car elt)))
 807                    (setq vec (vconcat vec (list key "")))
 808                  ;; Just a string.
 809                  (while (stringp (car elt))
 810                    (let ((x (pop elt)))
 811                      (unless (member x val)
 812                        (setq val (append val (list x))))))
 813                  (setq vec
 814                        (vconcat
 815                         vec (list key (mapconcat #'identity val " "))))))
 816
 817               ((:date :@cdate)
 818                ;; It shouldn't happen in a phrase condition.
 819                (if phrase-cond
 820                    (error "Wrong keyword: %s" kw))
 821                (setq attr-cond t)
 822                (if (not (numberp (car elt)))
 823                    (setq vec (vconcat vec (list key "")))
 824                  ;; Just a number.
 825                  (while (numberp (car elt))
 826                    (let ((x (pop elt)))
 827                      (unless (member x val)
 828                        (setq val (append val (list x))))))
 829                  (setq vec
 830                        (vconcat
 831                         vec
 832                         (list key (mapconcat #'number-to-string val " "))))))
 833
 834               ((:operator :order)
 835                ;; It shouldn't happen in a phrase condition.
 836                (if phrase-cond
 837                    (error "Wrong keyword: %s" kw))
 838                (setq attr-cond t val (pop elt))
 839                ;; Value is a number.
 840                (if (stringp val)
 841                    (setq vec (vconcat vec (list key val)))
 842                  (error "Wrong %s: %s" key val)))
 843
 844               (t (error "Unknown key: %s" kw))))
 845
 846           (setq args (vconcat args (list vec)))))
 847
 848       (setq result
 849             (car (soap-invoke debbugs-wsdl debbugs-port "search_est" args)))
 850       ;; The result contains lists (key value).  We transform it into
 851       ;; cons cells (key . value).
 852       (dolist (elt1 result result)
 853         (dolist (elt2 elt1)
 854           (setcdr elt2 (cadr elt2)))))))
 855
 856 (defun debbugs-get-attribute (bug-or-message attribute)
 857   "Return the value of key ATTRIBUTE.
 858
 859 BUG-OR-MESSAGE must be list element returned by either
 860 `debbugs-get-status' or `debbugs-get-bug-log'.
 861
 862 Example: Return the originator of last submitted bug.
 863
 864 \(debbugs-get-attribute
 865   \(car \(apply #\\='debbugs-get-status \(debbugs-newest-bugs 1))) \\='originator)"
 866   (cdr (assoc attribute bug-or-message)))
 867
 868 (defun debbugs-get-message-numbers (messages)
 869   "Return the message numbers of MESSAGES.
 870 MESSAGES must be the result of a `debbugs-get-bug-log' call."
 871   (mapcar (lambda (x) (debbugs-get-attribute x 'msg_num)) messages))
 872
 873 (defun debbugs-get-message (messages message-number)
 874   "Return the message MESSAGE-NUMBER of MESSAGES.
 875 MESSAGES must be the result of a `debbugs-get-bug-log' call.
 876
 877 The returned message is a list of strings.  The first element are
 878 the header lines of the message, the second element is the body
 879 of the message.  Further elements of the list, if any, are
 880 attachments of the message.
 881
 882 If there is no message with MESSAGE-NUMBER, the function returns nil.
 883
 884 Example: Return the first message of last submitted bug.
 885
 886 \(let \(\(messages \(apply #\\='debbugs-get-bug-log \(debbugs-newest-bugs 1))))
 887   \(debbugs-get-message messages
 888                        \(car \(debbugs-get-message-numbers messages))))"
 889   (while (and messages
 890               (/= (debbugs-get-attribute (car messages) 'msg_num)
 891                   message-number))
 892     (setq messages (cdr messages)))
 893   (when messages
 894     (append (list (debbugs-get-attribute (car messages) 'header)
 895                   (debbugs-get-attribute (car messages) 'body))
 896             (debbugs-get-attribute (car messages) 'attachments))))
 897
 898 (defun debbugs-get-mbox (bug-number mbox-type &optional filename)
 899   "Download mbox with messages of bug BUG-NUMBER from Debbugs server.
 900 BUG-NUMBER is a number of bug.  It must be of integer type.
 901
 902 MBOX-TYPE specifies a type of mbox and can be one of the
 903 following symbols:
 904
 905    `mboxfolder': Download mbox folder.
 906
 907    `mboxmaint': Download maintainer's mbox.
 908
 909    `mboxstat', `mboxstatus': Download status mbox.  The use of
 910    either symbol depends on actual Debbugs server configuration.
 911    For gnu.org, use the former; for debian.org - the latter.
 912
 913 FILENAME, if non-nil, is the name of file to store mbox.  If
 914 FILENAME is nil, the downloaded mbox is inserted into the
 915 current buffer."
 916   (let (url (mt "") bn)
 917     (unless (setq url (plist-get
 918                        (cdr (assoc debbugs-port debbugs-servers))
 919                        :bugreport-url))
 920       (error "URL of bugreport script for port %s is not specified"
 921              debbugs-port))
 922     (setq bn (format "bug=%s;" (number-to-string bug-number)))
 923     (unless (eq mbox-type 'mboxfolder)
 924       (if (memq mbox-type '(mboxmaint mboxstat mboxstatus))
 925           (setq mt (concat (symbol-name mbox-type) "=yes;"))
 926         (error "Unknown mbox type: %s" mbox-type)))
 927     (setq url (concat url (format "?%s%smbox=yes" bn mt)))
 928     (if filename
 929         (url-copy-file url filename t)
 930       (url-insert-file-contents url))))
 931
 932 (provide 'debbugs)
 933
 934 ;;; TODO:
 935
 936 ;; * SOAP interface extensions (wishlist).
 937 ;;   - Server-side sorting.
 938 ;;   - Regexp and/or wildcards search.
 939 ;;   - Returning message attachments.
 940
 941 ;;; debbugs.el ends here