elmo/acap.el

   1 ;;; acap.el --- An ACAP interface.
   2
   3 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   4 ;; Keywords: ACAP
   5
   6 ;; Copyright (C) 2001 Yuuichi Teranishi <teranisi@gohome.org>
   7
   8 ;; This file is not part of GNU Emacs
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28 ;; acap.el is an elisp library providing an interface for talking to
  29 ;; ACAP (RFC2244) servers.
  30 ;;
  31 ;; This is a transcript of short interactive session for demonstration
  32 ;; purposes.
  33
  34 ;; (setq proc (acap-open "my.acap.server" "username" "CRAM-MD5"))
  35 ;; => #<process ACAP>
  36 ;;
  37 ;; (acap-search proc "/addressbook/" '((RETURN ("*")))))
  38 ;; => ((done-ok nil "search completed")
  39 ;;     (modtime . "20010828091433000010")
  40 ;;     (entry "user"
  41 ;;         ((("subdataset"
  42 ;;            ("."))
  43 ;;           ("modtime" "20010824004532000003")
  44 ;;           ("entry" "user"))))
  45 ;;     (entry ""
  46 ;;         ((("modtime" "20010824004532000002")
  47 ;;           ("entry" "")
  48 ;;           ("dataset.owner" "anonymous")
  49 ;;           ("dataset.acl" ("$anyone   xrwia")))))
  50 ;;
  51 ;; (acap-close proc)
  52 ;; => t
  53
  54 ;;; History:
  55 ;;
  56 ;; 27 Aug 2001 Created (Some codes are based on imap.el.).
  57
  58 ;;; Code:
  59
  60 (eval-when-compile
  61   (require 'cl)
  62   (require 'static))
  63 (require 'pces)
  64 (require 'sasl)
  65
  66 ;; User variables.
  67 (defgroup acap nil
  68   "Low level ACAP issues."
  69   :group 'applications)
  70
  71 (defcustom acap-default-user (user-login-name)
  72   "Default username to use."
  73   :type 'string
  74   :group 'acap)
  75
  76 (defcustom acap-default-port 674
  77   "Default port for ACAP."
  78   :type 'integer
  79   :group 'acap)
  80
  81 (defcustom acap-stock-passphrase nil
  82   "Stock passphrase on memory if t."
  83   :type 'boolean
  84   :group 'acap)
  85
  86 ;; Constants.
  87 (defconst acap-server-eol "\r\n"
  88   "The EOL string sent from the server.")
  89
  90 (defconst acap-client-eol "\r\n"
  91   "The EOL string sent from the server.")
  92
  93 ;; Internal variables.
  94 (defvar acap-state 'closed
  95   "ACAP state.
  96 Valid states are `closed', `initial', `auth'.")
  97
  98 (defvar acap-capability nil
  99   "Capability for server.")
 100
 101 (defvar acap-reached-tag 0
 102   "Lower limit on command tags that have been parsed.")
 103
 104 (defvar acap-tag 0
 105   "Command tag number.")
 106
 107 (defvar acap-auth nil
 108   "Authenticated mechanism name.")
 109
 110 (defvar acap-process nil
 111   "Process for the buffer.")
 112
 113 (defvar acap-server nil
 114   "Server name.")
 115
 116 (defvar acap-port nil
 117   "Port number.")
 118
 119 (defvar acap-response nil
 120   "ACAP Response.")
 121
 122 (make-variable-buffer-local 'acap-state)
 123 (make-variable-buffer-local 'acap-auth)
 124 (make-variable-buffer-local 'acap-capability)
 125 (make-variable-buffer-local 'acap-reached-tag)
 126 (make-variable-buffer-local 'acap-failed-tag)
 127 (make-variable-buffer-local 'acap-tag)
 128 (make-variable-buffer-local 'acap-server)
 129 (make-variable-buffer-local 'acap-port)
 130 (make-variable-buffer-local 'acap-response)
 131
 132 (defvar acap-network-stream-alist
 133   '((default . open-network-stream-as-binary)))
 134
 135 (defun acap-network-stream-open (buffer server port &optional type)
 136   (let* ((port (or port acap-default-port))
 137          (process (progn
 138                     (message "Connecting to %s..." server)
 139                     (funcall (cdr (assq (or type 'default)
 140                                         acap-network-stream-alist))
 141                              "ACAP" buffer server port))))
 142     (when process
 143       (with-current-buffer buffer
 144         (while (and (memq (process-status process) '(open run))
 145                     (goto-char (point-min))
 146                     (not (setq acap-capability (acap-parse-greeting))))
 147           (message "Waiting for response from %s..." server)
 148           (accept-process-output process 1))
 149         (message "Waiting for response from %s...done" server)
 150         (when (memq (process-status process) '(open run))
 151           process)))))
 152
 153 (defvar acap-passphrase nil)
 154 (defvar acap-rp-user nil)
 155 (defvar acap-rp-server nil)
 156 (defvar acap-rp-auth nil)
 157
 158 (defvar acap-passphrase-alist nil)
 159
 160 (defun acap-read-passphrase (prompt)
 161   "Prompt is not used."
 162   (or acap-passphrase
 163       (progn
 164         (setq prompt (format "%s passphrase for %s@%s: "
 165                              acap-rp-auth acap-rp-user acap-rp-server))
 166         (if (functionp 'read-passwd)
 167             (read-passwd prompt)
 168           (if (load "passwd" t)
 169               (read-passwd prompt))))))
 170
 171 ;;; Debug.
 172 (defvar acap-debug t)
 173 (defvar acap-debug-buffer nil)
 174 (defun acap-debug (string)
 175   "Insert STRING to the debug buffer."
 176   (when acap-debug
 177     (if (or (null acap-debug-buffer)
 178             (not (bufferp acap-debug-buffer))
 179             (not (buffer-live-p acap-debug-buffer)))
 180         (setq acap-debug-buffer (get-buffer-create "*Debug acap*")))
 181     (with-current-buffer acap-debug-buffer
 182       (goto-char (point-max))
 183       (insert string))))
 184
 185 ;;; Stock passphrase (Not implemented yet)
 186 (defun acap-stock-passphrase (user server auth passphrase)
 187   (let ((key (format "%s/%s/%s" user server auth))
 188         pair)
 189     (when (setq pair (assoc key acap-passphrase-alist))
 190       (setq acap-passphrase-alist (delete pair acap-passphrase-alist)))
 191     (setq acap-passphrase-alist (cons
 192                                  (cons key passphrase)
 193                                  acap-passphrase-alist))))
 194
 195 (defun acap-stocked-passphrase (user server auth)
 196   (when acap-stock-passphrase
 197     (let ((key (format "%s/%s/%s" user server auth)))
 198       (cdr (assoc key acap-passphrase-alist)))))
 199
 200 (defun acap-remove-stocked-passphrase (user server auth)
 201   (let ((key (format "%s/%s/%s" user server auth)))
 202     (setq acap-passphrase-alist
 203           (delq (assoc key acap-passphrase-alist)
 204                 acap-passphrase-alist))))
 205
 206 ;;; Open, Close
 207 (defun acap-open (server &optional user auth port type)
 208   (let* ((user (or user acap-default-user))
 209          (buffer (get-buffer-create (concat " *acap on " user " at " server)))
 210          process passphrase mechanism tag)
 211     (with-current-buffer buffer
 212       (if acap-process
 213           (delete-process acap-process))
 214       (setq process (acap-network-stream-open buffer server port type)
 215             acap-process process)
 216       (erase-buffer)
 217       (set-buffer-multibyte nil)
 218       (buffer-disable-undo)
 219       (setq acap-state 'initial)
 220       (set-process-filter process 'acap-arrival-filter)
 221       (set-process-sentinel process 'acap-sentinel)
 222       (while (and (memq (process-status process) '(open run))
 223                   (not (eq acap-state 'auth)))
 224         (setq acap-auth
 225               (unwind-protect
 226                   (let* ((mechanism
 227                           (sasl-find-mechanism
 228                            (if auth
 229                                (list auth)
 230                              (cdr (or (assq 'Sasl acap-capability)
 231                                       (assq 'SASL acap-capability))))))
 232                          (sclient
 233                           (sasl-make-client mechanism user "acap" server))
 234                          (sasl-read-passphrase 'acap-read-passphrase)
 235                          (acap-rp-user user)
 236                          (acap-rp-server server)
 237                          (acap-rp-auth (sasl-mechanism-name mechanism))
 238                          acap-passphrase step response cont-string)
 239                     (unless (string= (sasl-mechanism-name mechanism)
 240                                      "ANONYMOUS")
 241                       (setq acap-passphrase (acap-read-passphrase nil)))
 242                     (setq tag (acap-send-command
 243                                process
 244                                (concat
 245                                 (format "AUTHENTICATE \"%s\""
 246                                         (sasl-mechanism-name mechanism))
 247                                 (if (and (setq step
 248                                                (sasl-next-step sclient nil))
 249                                          (sasl-step-data step))
 250                                     (concat " " (prin1-to-string
 251                                                  (sasl-step-data step)))))))
 252                     (when (setq response (acap-wait-for-response process tag))
 253                       (while (acap-response-cont-p response)
 254                         (sasl-step-set-data
 255                          step (acap-response-cont-string response))
 256                         (acap-response-clear process)
 257                         (if (setq step (sasl-next-step sclient step))
 258                             (with-temp-buffer
 259                               (insert (or (sasl-step-data step) ""))
 260                               (setq response (acap-send-data-wait
 261                                               process (current-buffer) tag)))
 262                           (setq response nil)))
 263                       (if (acap-response-ok-p response)
 264                           (progn
 265                             (setq acap-state 'auth)
 266                             mechanism)
 267                         (message "Authentication failed.")
 268                         (sit-for 1))))
 269                 nil)))
 270       (unless acap-auth
 271         (message "acap: Connecting to %s...failed" server))
 272       (setq acap-server server
 273             acap-port port)
 274       process)))
 275
 276 (defun acap-close (process)
 277   (with-current-buffer (process-buffer process)
 278     (unless (acap-response-ok-p (acap-send-command-wait process "LOGOUT"))
 279       (message "Server %s didn't let me log out" acap-server))
 280     (when (memq (process-status process) '(open run))
 281       (delete-process process))
 282     (erase-buffer)
 283     t))
 284
 285 ;;; Commands
 286
 287 (defun acap-noop (process)
 288   "Execute NOOP command on PROCESS."
 289   (acap-send-command-wait process "NOOP"))
 290
 291 (defun acap-lang (process lang-list)
 292   "Execute LANG command on PROCESS."
 293   (acap-send-command-wait process
 294                           (mapconcat
 295                            'identity
 296                            (nconc (list "LANG")
 297                                   (mapcar 'prin1-to-string lang-list))
 298                            " ")))
 299
 300 (defun acap-search (process target &optional modifier criteria)
 301   "Execute SEARCH command on PROCESS.
 302 TARGET is a string which specifies what is to be searched
 303 \(dataset or context name\).
 304 MODIFIER is an alist of modifiers. Each element should be a list like
 305 \(MODIFIER-NAME DATA1 DATA2...\).
 306 CRITERIA is a search criteria string.
 307 If CRITERIA is not specified, \"ALL\" is assumed,
 308 Modifiers and search criteria are described in section 6.4.1 of RFC2244.
 309
 310 Examples:
 311 \(acap-search process
 312              \"/addressbook/\"
 313              '\((DEPTH 3\)
 314                \(RETURN \(\"addressbook.Alias\"
 315                         \"addressbook.Email\"
 316                         \"addressbook.List\"\)\)\)
 317              \"OR NOT EQUAL \\\"addressbook.Email\\\" \\\"i\;octed\\\" NIL\\
 318                  NOT EQUAL \\\"addressbook.Email\\\" \\\"i\;octed\\\" NIL\"\)
 319
 320 \(acap-search process
 321              \"/addressbook/user/fred/\"
 322              '\(\(RETURN \(\"*\"\)\)
 323              \"EQUAL \\\"entry\\\" \\\"i\;octed\\\" \\\"A0345\\\"\"\)"
 324   (acap-send-command-wait process
 325                           (concat "SEARCH " (prin1-to-string target)
 326                                   (if modifier " ")
 327                                   (mapconcat
 328                                    'prin1-to-string
 329                                    (acap-flatten modifier)
 330                                    " ")
 331                                   " "
 332                                   (or criteria "ALL"))))
 333
 334 (defun acap-freecontext (process name)
 335   "Execute FREECONTEXT command on PROCESS."
 336   (acap-send-command-wait process
 337                           (concat "FREECONTEXT " name)))
 338
 339 (defun acap-updatecontext (process names)
 340   "Execute UPDATECONTEXT command on PROCESS."
 341   (acap-send-command-wait process
 342                           (mapconcat
 343                            'identity
 344                            (nconc (list "FREECONTEXT") names)
 345                            " ")))
 346
 347 (defun acap-store (process entries)
 348   "Execute STORE command on PROCESS.
 349 ENTRIES is a store-entry list."
 350   (acap-send-command-wait process (concat "STORE " (prin1-to-string entries))))
 351
 352 (defun acap-deletedsince (process name time)
 353   "Execute DELETEDSINCE command on PROCESS."
 354   (acap-send-command-wait process
 355                           (concat "DELETEDSINCE "
 356                                   (prin1-to-string name)
 357                                   " "
 358                                   (prin1-to-string (acap-encode-time time)))))
 359
 360 (defun acap-setacl (process object identifier rights)
 361   "Execute SETACL command on PROCESS."
 362   (acap-send-command-wait process
 363                           (concat "SETACL "
 364                                   (prin1-to-string object)
 365                                   " "
 366                                   (prin1-to-string identifier)
 367                                   " "
 368                                   (prin1-to-string rights))))
 369
 370 (defun acap-deleteacl (process object &optional identifier)
 371   "Execute DELETEACL command on PROCESS."
 372   (acap-send-command-wait process
 373                           (concat
 374                            "DELETEACL "
 375                            (prin1-to-string object)
 376                            (if identifier
 377                                (concat " " (prin1-to-string identifier))))))
 378
 379 (defun acap-myrights (process object)
 380   "Execute MYRIGHTS command on PROCESS."
 381   (acap-send-command-wait process
 382                           (concat
 383                            "MYRIGHTS "
 384                            (prin1-to-string object))))
 385
 386 (defun acap-listrights (process object identifier)
 387   "Execute LISTRIGHTS command on PROCESS."
 388   (acap-send-command-wait process
 389                           (concat
 390                            "LISTRIGHTS "
 391                            (prin1-to-string object)
 392                            " "
 393                            (prin1-to-string identifier))))
 394
 395 (defun acap-getquota (process dataset)
 396   "Execute GETQUOTA command on PROCESS."
 397   (acap-send-command-wait process
 398                           (concat
 399                            "GETQUOTA "
 400                            (prin1-to-string dataset))))
 401
 402 ;;; response accessor.
 403 (defun acap-response-ok-p (response)
 404   (assq 'done-ok response))
 405
 406 (defun acap-response-cont-p (response)
 407   (assq 'cont response))
 408
 409 (defun acap-response-cont-string (response)
 410   (cdr (assq 'cont response)))
 411
 412 (defun acap-response-body (response)
 413   (cdr (or (assq 'done-ok response)
 414            (assq 'done-no response)
 415            (assq 'done-bad response))))
 416
 417 (defun acap-response-entries (response)
 418   (let (entries)
 419     (dolist (ent response)
 420       (if (eq (car ent) 'entry)
 421           (setq entries (cons ent entries))))
 422     entries))
 423
 424 (defun acap-response-entry-entry (entry)
 425   (car (cdr entry)))
 426
 427 (defun acap-response-entry-return-data-list (entry)
 428   (nth 1 (cdr entry)))
 429
 430 (defun acap-response-return-data-list-get-value (name return-data-list)
 431   (nth 1 (assoc name return-data-list)))
 432
 433 (defun acap-response-listrights (response)
 434   (cdr (assq 'listrights response)))
 435
 436 ;;; Send command, data.
 437 (defun acap-response-clear (process)
 438   (with-current-buffer (process-buffer process)
 439     (setq acap-response nil)))
 440
 441 (defun acap-send-command-wait (process command)
 442   (acap-wait-for-response process (acap-send-command process command)))
 443
 444 (defun acap-send-data-wait (process string tag)
 445   (cond ((stringp string)
 446          (acap-send-command-1 process string))
 447         ((bufferp string)
 448          (with-current-buffer string
 449            (acap-response-clear process)
 450            (acap-send-command-1 process (format "{%d}" (buffer-size)))
 451            (if (acap-response-cont-p (acap-wait-for-response process tag))
 452                (with-current-buffer string
 453                  (acap-response-clear process)
 454                  (process-send-region process (point-min)
 455                                       (point-max))
 456                  (process-send-string process acap-client-eol)))
 457            (acap-debug (concat (buffer-string) acap-client-eol)))))
 458   (acap-wait-for-response process tag))
 459
 460 (defun acap-send-command-1 (process cmdstr)
 461   (acap-debug (concat "<-" cmdstr acap-client-eol))
 462   (process-send-string process (concat cmdstr acap-client-eol)))
 463
 464 (defun acap-send-command (process command)
 465   (with-current-buffer (process-buffer process)
 466     (setq acap-response nil)
 467     (if (not (listp command)) (setq command (list command)))
 468     (let ((tag (setq acap-tag (1+ acap-tag)))
 469           cmd cmdstr response)
 470       (setq cmdstr (concat (number-to-string acap-tag) " "))
 471       (while (setq cmd (pop command))
 472         (cond ((stringp cmd)
 473                (setq cmdstr (concat cmdstr cmd)))
 474               ((bufferp cmd)
 475                (with-current-buffer cmd
 476                  (setq cmdstr (concat cmdstr (format "{%d}" (buffer-size)))))
 477                (unwind-protect
 478                    (progn
 479                      (acap-send-command-1 process cmdstr)
 480                      (setq cmdstr nil
 481                            response (acap-wait-for-response process tag))
 482                      (if (not (acap-response-cont-p response))
 483                          (setq command nil) ;; abort command if no cont-req
 484                        (with-current-buffer cmd
 485                          (process-send-region process (point-min)
 486                                               (point-max))
 487                          (process-send-string process acap-client-eol))))))
 488               (t (error "Unknown command type"))))
 489       (when cmdstr
 490         (acap-send-command-1 process cmdstr))
 491       tag)))
 492
 493 (defun acap-wait-for-response (process tag)
 494   (with-current-buffer (process-buffer process)
 495     (while (and (not (acap-response-cont-p acap-response))
 496                 (< acap-reached-tag tag))
 497       (or (and (not (memq (process-status process) '(open run)))
 498                (sit-for 1))
 499           (let ((len (/ (point-max) 1024))
 500                 message-log-max)
 501             (unless (< len 10)
 502               (message "acap read: %dk" len))
 503             (accept-process-output process 1))))
 504     (message "")
 505     acap-response))
 506
 507 ;;; Sentinel, Filter.
 508 (defun acap-sentinel (process string)
 509   (delete-process process))
 510
 511 (defun acap-find-next-line ()
 512   (when (re-search-forward (concat acap-server-eol "\\|{\\([0-9+]+\\)}"
 513                                    acap-server-eol)
 514                            nil t)
 515     (if (match-string 1)
 516         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
 517             nil
 518           (goto-char (+ (point) (string-to-number (match-string 1))))
 519           (acap-find-next-line))
 520       (point))))
 521
 522 (defun acap-arrival-filter (proc string)
 523   "ACAP process filter."
 524   (acap-debug string)
 525   (with-current-buffer (process-buffer proc)
 526     (goto-char (point-max))
 527     (insert string)
 528     (let (end)
 529       (goto-char (point-min))
 530       (while (setq end (acap-find-next-line))
 531         (save-restriction
 532           (narrow-to-region (point-min) end)
 533           (delete-backward-char (length acap-server-eol))
 534           (goto-char (point-min))
 535           (unwind-protect
 536               (cond ((or (eq acap-state 'auth)
 537                          (eq acap-state 'initial)
 538                          (eq acap-state 'nonauth))
 539                      (acap-parse-response))
 540                     (t
 541                      (message "Unknown state %s in arrival filter"
 542                               acap-state)))
 543             (delete-region (point-min) (point-max))))))))
 544
 545 ;;; acap parser.
 546 (defsubst acap-forward ()
 547   (or (eobp) (forward-char)))
 548
 549 (defsubst acap-parse-number ()
 550   (when (looking-at "[0-9]+")
 551     (prog1
 552         (string-to-number (match-string 0))
 553       (goto-char (match-end 0)))))
 554
 555 (defsubst acap-parse-literal ()
 556   (when (looking-at "{\\([0-9]+\\)}\r\n")
 557     (let ((pos (match-end 0))
 558           (len (string-to-number (match-string 1))))
 559       (if (< (point-max) (+ pos len))
 560           nil
 561         (goto-char (+ pos len))
 562         (buffer-substring pos (+ pos len))))))
 563
 564 (defun acap-parse-greeting ()
 565   (when (looking-at "* ACAP")
 566     (goto-char (match-end 0))
 567     (acap-forward)
 568     (let (capabilities)
 569       (while (eq (char-after (point)) ?\()
 570         (push (read (current-buffer)) capabilities)
 571         (acap-forward))
 572       (nreverse capabilities))))
 573
 574 ;; resp-body = ["(" resp-code ")" SP] quoted
 575 (defun acap-parse-resp-body ()
 576   (let ((body (read (current-buffer))))
 577     (if (listp body) ; resp-code
 578         (list body (read (current-buffer)))
 579       (list nil body) ; no resp-code.
 580       )))
 581
 582 ;;   string          = quoted / literal
 583 ;;
 584 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
 585 ;;
 586 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
 587 ;;                     "\" quoted-specials
 588 ;;
 589 ;;   quoted-specials = DQUOTE / "\"
 590 ;;
 591 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
 592
 593 (defsubst acap-parse-string ()
 594   (cond ((eq (char-after) ?\")
 595          (forward-char 1)
 596          (let ((p (point)) (name ""))
 597            (skip-chars-forward "^\"\\\\")
 598            (setq name (buffer-substring p (point)))
 599            (while (eq (char-after) ?\\)
 600              (setq p (1+ (point)))
 601              (forward-char 2)
 602              (skip-chars-forward "^\"\\\\")
 603              (setq name (concat name (buffer-substring p (point)))))
 604            (forward-char 1)
 605            name))
 606         ((eq (char-after) ?{)
 607          (acap-parse-literal))))
 608
 609 ;;   nil             = "NIL"
 610
 611 (defsubst acap-parse-nil ()
 612   (if (looking-at "NIL")
 613       (goto-char (match-end 0))))
 614
 615 ;; entry              = entry-name / entry-path
 616 ;; entry-name         = string-utf8
 617 ;;                        ;; entry name MUST NOT contain slash
 618 ;;                        ;; MUST NOT begin with "."
 619 ;; entry-path         = string-utf8
 620 ;;                        ;; slash-separated path to entry
 621 ;;                        ;; begins with slash
 622
 623 (defsubst acap-parse-quoted ()
 624   (if (eq (char-after) ?\")
 625       (read (current-buffer))))
 626
 627 (defun acap-parse-entry ()
 628   (acap-parse-quoted))
 629
 630 ;; value              = string
 631 (defun acap-parse-value ()
 632   (acap-parse-string))
 633
 634 ;; value-list         = "(" [value *(SP value)] ")"
 635 (defun acap-parse-value-list ()
 636   ;; same as acl.
 637   (when (eq (char-after (point)) ?\()
 638     (let (values)
 639       (while (not (eq (char-after (point)) ?\)))
 640         (acap-forward)
 641         (push (acap-parse-value) values))
 642       (acap-forward)
 643       (nreverse values))))
 644
 645 ;;
 646 ;;   return-data-list   = return-data *(SP return-data)
 647 ;;
 648 ;;   return-data        = return-metadata / return-metalist /
 649 ;;                        return-attr-list
 650
 651 (defun acap-parse-return-data-list ()
 652   (let (rlist r)
 653     (setq rlist (list (acap-parse-return-metadata-or-return-metalist)))
 654     (acap-forward)
 655     (while (setq r (acap-parse-return-metadata-or-return-metalist))
 656       (setq rlist (nconc rlist (list r)))
 657       (acap-forward))
 658     rlist))
 659
 660 (defun acap-parse-return-metadata-or-return-metalist ()
 661   (or (acap-parse-string)
 662       (acap-parse-value-or-return-metalist)
 663       (and (acap-parse-nil) nil)))
 664
 665 (defun acap-parse-value-or-return-metalist ()
 666   (when (eq (char-after (point)) ?\()
 667     (let (elems)
 668       (while (not (eq (char-after (point)) ?\)))
 669         (acap-forward)
 670         (push (or (acap-parse-value)
 671                   (acap-parse-return-metalist))
 672               elems))
 673       (acap-forward)
 674       (nreverse elems))))
 675
 676 ;;   return-metalist    = "(" return-metadata *(SP return-metadata) ")"
 677 ;;                        ;; occurs when multiple metadata items requested
 678 ;;
 679 (defun acap-parse-return-metalist ()
 680   (when (eq (char-after (point)) ?\()
 681     (let (metadatas)
 682       (while (not (eq (char-after (point)) ?\)))
 683         (acap-forward)
 684         (push (acap-parse-return-metadata) metadatas))
 685       (acap-forward)
 686       (nreverse metadatas))))
 687
 688 ;;   return-metadata    = nil / string / value-list / acl
 689 (defun acap-parse-return-metadata ()
 690   (or (acap-parse-string)
 691       (acap-parse-value-list)
 692       (and (acap-parse-nil) nil)
 693       ;; (acap-parse-acl) acl is same as value-list.
 694       ))
 695
 696 ;;   return-attr-list   = "(" return-metalist *(SP return-metalist) ")"
 697 ;;                        ;; occurs when "*" in RETURN pattern on SEARCH
 698 (defun acap-parse-return-attr-list ()
 699   (when (eq (char-after (point)) ?\()
 700     (let (metalists)
 701       (while (not (eq (char-after (point)) ?\)))
 702         (acap-forward)
 703         (push (acap-parse-return-metalist) metalists))
 704       (acap-forward)
 705       (nreverse metalists))))
 706
 707 (defun acap-parse-time ()
 708   (acap-parse-quoted))
 709
 710 ;; quoted *(SP quoted)
 711 (defun acap-parse-quoted-list ()
 712   (let (qlist q)
 713     (setq qlist (list (acap-parse-quoted)))
 714     (acap-forward)
 715     (while (setq q (acap-parse-quoted))
 716       (setq qlist (nconc qlist (list q)))
 717       (acap-forward))
 718     qlist))
 719
 720 (defun acap-parse-any ()
 721   (read (current-buffer)))
 722
 723 (defun acap-parse-extension-data ()
 724   (let (elist e)
 725     (setq elist (list (acap-parse-any)))
 726     (acap-forward)
 727     (while (setq e (acap-parse-any))
 728       (setq elist (nconc elist (list e)))
 729       (acap-forward))
 730     elist))
 731
 732 (defun acap-parse-response ()
 733   "Parse a ACAP command response."
 734   (let ((token (read (current-buffer)))
 735         tag)
 736     (setq
 737      acap-response
 738      (cons
 739       (cond
 740        ((eq token '+)
 741         (acap-forward)
 742         (cons 'cont (acap-parse-string)))
 743        ((eq token '*)
 744         ;; untagged response.
 745         (case (prog1 (setq token (read (current-buffer)))
 746                 (acap-forward))
 747           (ADDTO (cons 'addto
 748                        (list (acap-parse-quoted)
 749                              (progn
 750                                (acap-forward)
 751                                (acap-parse-quoted))
 752                              (progn
 753                                (acap-forward)
 754                                (acap-parse-number))
 755                              (progn
 756                                (acap-forward)
 757                                (acap-parse-return-data-list)))))
 758           (ALERT ;(cons 'alert (acap-parse-resp-body))
 759            (message (nth 1 (acap-parse-resp-body))))
 760           (BYE   ;(cons 'bye (acap-parse-resp-body)))
 761            ;;(message (nth 1  (acap-parse-resp-body)))
 762            ;;(ding)
 763            (delete-process acap-process))
 764           (CHANGE (cons 'change
 765                         (list (acap-parse-quoted)
 766                               (progn
 767                                 (acap-forward)
 768                                 (acap-parse-quoted))
 769                               (progn
 770                                 (acap-forward)
 771                                 (acap-parse-number))
 772                               (progn
 773                                 (acap-forward)
 774                                 (acap-parse-number))
 775                               (progn
 776                                 (acap-forward)
 777                                 (acap-parse-return-data-list)))))
 778           (LANG (cons 'lang (list (acap-parse-quoted-list))))
 779           ;; response-stat
 780           (OK   (cons 'stat-ok (acap-parse-resp-body)))
 781           (NO   (cons 'stat-no (acap-parse-resp-body)))
 782           (BAD  ;(cons 'stat-bad (acap-parse-resp-body))
 783            ;; XXX cyrus-sml-acap does not return tagged bad response?
 784            (error (nth 1 (acap-parse-resp-body))))))
 785        ((integerp token)
 786         ;; tagged response.
 787         (setq tag token)
 788         (case (prog1 (setq token (read (current-buffer)))
 789                 (acap-forward))
 790           (DELETED   (cons 'deleted (acap-parse-quoted)))
 791           ;; response-done
 792           ((OK Ok ok) (prog1 (cons 'done-ok (acap-parse-resp-body))
 793                         (setq acap-reached-tag tag)))
 794           ((NO No no)   (prog1 (cons 'done-no (acap-parse-resp-body))
 795                           (setq acap-reached-tag tag)))
 796           ((BAD Bad bad) (prog1 (cons 'done-bad (acap-parse-resp-body))
 797                            (setq acap-reached-tag tag)))
 798           (ENTRY (cons 'entry
 799                        (list
 800                         (acap-parse-entry)
 801                         (progn (acap-forward)
 802                                (acap-parse-return-data-list)))))
 803           (LISTRIGHTS (cons 'listrights
 804                             (acap-parse-quoted-list)))
 805           (MODTIME    (cons 'modtime (acap-parse-time)))
 806           (MYRIGHTS   (cons 'myrights (acap-parse-quoted)))
 807           (QUOTA      (cons 'quota
 808                             (list (acap-parse-quoted)
 809                                   (progn
 810                                     (acap-forward)
 811                                     (acap-parse-number))
 812                                   (progn
 813                                     (acap-forward)
 814                                     (acap-parse-number))
 815                                   (acap-parse-extension-data))))
 816           (REFER      (cons 'refer (list (acap-parse-quoted)
 817                                          (acap-parse-quoted))))
 818           (REMOVEFROM (cons 'removefrom
 819                             (list (acap-parse-quoted)
 820                                   (progn
 821                                     (acap-forward)
 822                                     (acap-parse-quoted))
 823                                   (progn
 824                                     (acap-forward)
 825                                     (acap-parse-number)))))
 826           ;; response-extend
 827           (t ; extend-token
 828            (cons 'extend (list token (acap-parse-extension-data))))))
 829        (t ; garbage
 830         (list 'garbage token)))
 831       acap-response))))
 832
 833 ;;; Utilities.
 834 (defun acap-flatten (l)
 835   "Flatten list-of-list."
 836   (unless (null l)
 837     (append
 838      (if (and (car l)
 839               (listp (car l)))
 840          (car l)
 841        (list (car l)))
 842      (acap-flatten (cdr l)))))
 843
 844 (defun acap-flatten-r (l)
 845   "Flatten list-of-list recursively."
 846   (cond
 847    ((null l) '())
 848    ((listp l)
 849     (append (acap-flatten (car l)) (acap-flatten (cdr l))))
 850    (t (list l))))
 851
 852 (defun acap-encode-time (time)
 853   (format-time-string "%Y%m%d%H%M%S" (current-time) t)) ; Universal time.
 854
 855 (defun acap-decode-time (acap-time)
 856   (when (string-match "^\\([0-9][0-9][0-9][0-9]\\)\\([0-1][0-9]\\)\\([0-3][0-9]\\)\\([0-2][0-9]\\)\\([0-5][0-9]\\)\\([0-5][0-9]\\)" acap-time)
 857     (encode-time (string-to-number (match-string 6 acap-time))
 858                  (string-to-number (match-string 5 acap-time))
 859                  (string-to-number (match-string 4 acap-time))
 860                  (string-to-number (match-string 3 acap-time))
 861                  (string-to-number (match-string 2 acap-time))
 862                  (string-to-number (match-string 1 acap-time))
 863                  t)))
 864
 865 (provide 'acap)
 866
 867 ;;; acap.el ends here