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