From 3c2152a75e0d923bcb2227b7d8e36ddd2139452b Mon Sep 17 00:00:00 2001 From: Colin McLear Date: Tue, 4 Dec 2018 23:57:59 -0600 Subject: [PATCH] Add excorporate packages --- .local/elpa/excorporate-0.8.1/ChangeLog | 257 ++ .local/elpa/excorporate-0.8.1/NEWS | 82 + .local/elpa/excorporate-0.8.1/README | 20 + .local/elpa/excorporate-0.8.1/dir | 18 + .../excorporate-autoloads.el | 82 + .../excorporate-0.8.1/excorporate-calendar.el | 46 + .../excorporate-0.8.1/excorporate-calfw.el | 151 + .../excorporate-0.8.1/excorporate-diary.el | 249 ++ .../elpa/excorporate-0.8.1/excorporate-org.el | 151 + .../elpa/excorporate-0.8.1/excorporate-pkg.el | 2 + .local/elpa/excorporate-0.8.1/excorporate.el | 920 +++++ .../elpa/excorporate-0.8.1/excorporate.info | 237 ++ .../elpa/excorporate-0.8.1/excorporate.texi | 260 ++ .local/elpa/fsm-0.2.1/fsm-autoloads.el | 22 + .local/elpa/fsm-0.2.1/fsm-pkg.el | 2 + .local/elpa/fsm-0.2.1/fsm.el | 503 +++ .local/elpa/nadvice-0.3/nadvice-autoloads.el | 15 + .local/elpa/nadvice-0.3/nadvice-pkg.el | 2 + .local/elpa/nadvice-0.3/nadvice.el | 124 + .../soap-client-autoloads.el | 15 + .../elpa/soap-client-3.1.5/soap-client-pkg.el | 2 + .local/elpa/soap-client-3.1.5/soap-client.el | 3166 +++++++++++++++++ .local/elpa/soap-client-3.1.5/soap-inspect.el | 546 +++ .../url-http-ntlm-autoloads.el | 50 + .../url-http-ntlm-2.0.4/url-http-ntlm-pkg.el | 2 + .../elpa/url-http-ntlm-2.0.4/url-http-ntlm.el | 618 ++++ excorporate/diary-excorporate-today | 0 excorporate/diary-excorporate-transient | 0 28 files changed, 7542 insertions(+) create mode 100644 .local/elpa/excorporate-0.8.1/ChangeLog create mode 100644 .local/elpa/excorporate-0.8.1/NEWS create mode 100644 .local/elpa/excorporate-0.8.1/README create mode 100644 .local/elpa/excorporate-0.8.1/dir create mode 100644 .local/elpa/excorporate-0.8.1/excorporate-autoloads.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate-calendar.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate-calfw.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate-diary.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate-org.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate-pkg.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate.el create mode 100644 .local/elpa/excorporate-0.8.1/excorporate.info create mode 100644 .local/elpa/excorporate-0.8.1/excorporate.texi create mode 100644 .local/elpa/fsm-0.2.1/fsm-autoloads.el create mode 100644 .local/elpa/fsm-0.2.1/fsm-pkg.el create mode 100644 .local/elpa/fsm-0.2.1/fsm.el create mode 100644 .local/elpa/nadvice-0.3/nadvice-autoloads.el create mode 100644 .local/elpa/nadvice-0.3/nadvice-pkg.el create mode 100644 .local/elpa/nadvice-0.3/nadvice.el create mode 100644 .local/elpa/soap-client-3.1.5/soap-client-autoloads.el create mode 100644 .local/elpa/soap-client-3.1.5/soap-client-pkg.el create mode 100644 .local/elpa/soap-client-3.1.5/soap-client.el create mode 100644 .local/elpa/soap-client-3.1.5/soap-inspect.el create mode 100644 .local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-autoloads.el create mode 100644 .local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-pkg.el create mode 100644 .local/elpa/url-http-ntlm-2.0.4/url-http-ntlm.el create mode 100644 excorporate/diary-excorporate-today create mode 100644 excorporate/diary-excorporate-transient diff --git a/.local/elpa/excorporate-0.8.1/ChangeLog b/.local/elpa/excorporate-0.8.1/ChangeLog new file mode 100644 index 00000000..05009624 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/ChangeLog @@ -0,0 +1,257 @@ +2018-09-15 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.8.1 + + * packages/excorporate/excorporate.el: Bump version to 0.8.1. Bump + nadvice version requirement to 0.3. + +2018-09-13 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.8.0 + + * excorporate/excorporate.el: Bump version to 0.8.0. + +2018-09-13 Thomas Fitzsimmons + + packages/excorporate: Mention appt features in documentation + + * packages/excorporate/excorporate.texi (Usage): Mention features of + appt integration. + +2018-09-12 Thomas Fitzsimmons + + packages/excorporate: Support diary on Emacs 24.1, 24.2, 24.3 + + * packages/excorporate/excorporate.el: Update copyright year. Unbump + Emacs version requirement to 24.1. Add nadvice 0.2 requirement. + (exco-calendar-item-with-details-iterate): Do not pass identifier to + finalizer. + * packages/excorporate/excorporate-diary.el: Require nadvice. + (exco-diary-icalendar--add-diary-entry-around): Port defadvice to + nadvice. + (exco-diary-initialize): Move retrieval message to + exco-diary-diary-advice. + (exco-diary-diary-advice): Add retrieval message from + exco-diary-initialize. Explicitly return nil. + (excorporate-diary-enable): Create excorporate diary directory and blank + files. Sharp quote and reorder diary hooks. + (excorporate-diary-disable): Remove autoload cookie. + +2018-09-12 Thomas Fitzsimmons + + packages/excorporate: Update documentation for Diary support + + * packages/excorporate/excorporate.texi (Top): Suggest testing proxy + connections. + (Configuration): Simplify. + (Usage): Recommend diary first. + (Troubleshooting): Fix typo. + * packages/excorporate/excorporate.info: Rebuild. + +2018-09-12 Thomas Fitzsimmons + + packages/excorporate: Add diary and appt integration + + * packages/excorporate/excorporate-diary.el: New file. + * packages/excorporate/excorporate.el: Bump Emacs version requirement to + 24.4. + (exco-calendar-item-iterate): Silence a byte compilation warning. + +2018-09-11 Thomas Fitzsimmons + + packages/excorporate: Support retrieving meeting details + + * packages/excorporate/excorporate.el + (exco-calendar-item-get-details): New function. + (exco--calendar-item-dolist): New macro. + (exco-calendar-item-with-details-iterate): New function. + (exco-calendar-item-iterate): Use new exco--calendar-item-dolist macro. + +2018-09-11 Thomas Fitzsimmons + + packages/excorporate: Extend exco-connection-iterate + + * packages/excorporate/excorporate.el (exco-connection-iterate): Add + optional callback-will-call-finalize argument. Allow callback to call + finalize function. + +2018-09-04 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.7.7 + + * excorporate/excorporate.el: Bump version to 0.7.7. + +2018-09-04 Thomas Fitzsimmons + + excorporate.el: Require org for org-trim + + * excorporate/excorporate.el: Require org for org-trim. + +2018-09-04 Thomas Fitzsimmons + + excorporate-calfw.el: Enable clean byte-compiling in GNU ELPA + + * excorporate/excorporate-calfw.el: Specify NOERROR when require'ing + calfw. + (cfw:component-model, cfw:cp-add-selection-change-hook) + (cfw:cp-get-contents-sources) + (cfw:create-calendar-component-buffer, cfw:cursor-to-nearest-date) + (cfw:date, cfw:model-set-contents-sources) + (cfw:refresh-calendar-buffer, make-cfw:event, make-cfw:source): Declare + functions. + (cfw:component): Declare variable. + (cfw:cp-set-contents-sources): Override to fix a bug. + * excorporate/excorporate-calfw.el (exco-calfw-add-meetings) + (exco-calfw-finalize-buffer): Do not declare cfw:component special. + * copyright_exceptions: Add exception for description of calfw's + copyright situation in excorporate-calfw.el. + +2018-09-04 Thomas Fitzsimmons + + excorporate-calfw.el: Rename from excorporate-calfw.el.txt + + * excorporate/excorporate-calfw.el: Rename from + excorporate-calfw.el.txt. + +2018-09-04 Thomas Fitzsimmons + + excorporate.el: Bump soap-client requirement to 3.1.4 + + * excorporate/excorporate.el (Package-Requires): Bump soap-client + version to 3.1.4. + +2016-10-05 Thomas Fitzsimmons + + excorporate.texi: Increase authentication success likelihood + +2016-10-05 Thomas Fitzsimmons + + excorporate.el: Bump version to 0.7.6 + + * packages/excorporate/excorporate.el: Bump version to 0.7.6. + +2016-10-05 Thomas Fitzsimmons + + packages/excorporate: Bump url-http-ntlm required version to 2.0.3 + +2016-10-05 Thomas Fitzsimmons + + packages/excorporate: Acknowledge Fabio Leimgruber + +2016-06-16 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.7.5 + +2016-06-16 Thomas Fitzsimmons + + packages/excorporate: Interoperate with `save-some-buffers' + + * packages/excorporate/excorporate-org.el + (exco-org-initialize-buffer): Set buffer-file-name to + excorporate-org-buffer-name during org-mode initialization + (bug#23765). + +2016-06-14 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.7.4 + +2016-06-14 Thomas Fitzsimmons + + packages/excorporate: Interoperate with LaTeX preview + + * packages/excorporate/excorporate-org.el + (exco-org-initialize-buffer): Set buffer-file-name to + excorporate-org-buffer-name (bug#23765). + +2016-04-01 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.7.3 + +2016-04-01 Mitchel Humpherys + + packages/excorporate/excorporate-org.el: Allow quitting window + + * packages/excorporate/excorporate-org.el + (exco-org-initialize-buffer): Use a copy of org-mode-map as the local + keymap. Bind q to quit-window. + + Copyright-paperwork-exempt: yes + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Add NEWS file + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Bump version to 0.7.2 + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Require soap-client 3.1.1 + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Acknowledge Erik Hetzner + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Improve exco-get-meetings-for-day + + * packages/excorporate/excorporate.el (exco-get-meetings-for-day): Add + RequestVersion header to FindItem request. Use soap-operation-arity to + calculate how many nil arguments to send. + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Change server version lookup + + * packages/excorporate/excorporate.el (exco--get-server-version): Change + version lookup algorithm. + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Retrieve Services.wsdl directly + + * packages/excorporate/excorporate.el (exco--fsm): Retrieve + Services.wsdl directly, instead of via the endpoint. + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Update manual + + * packages/excorporate/excorporate.texi: Update troubleshooting section, + add bug reporting section. + +2016-03-16 Thomas Fitzsimmons + + packages/excorporate: Handle nil list of main invitees + + * packages/excorporate/excorporate.el + (exco-calendar-item-iterate): Handle nil list of main invitees. + * packages/excorporate/excorporate-org.el + (exco-org-insert-meeting): Likewise. + * packages/excorporate/excorporate-calfw.el.txt + (exco-calfw-add-meeting): Likewise. + +2016-02-26 Thomas Fitzsimmons + + packages/excorporate/excorporate.el: Bump version to 0.7.1 + +2016-02-26 Thomas Fitzsimmons + + packages/excorporate/excorporate.texi: New manual + + * packages/excorporate/excorporate.texi, + packages/excorporate/excorporate.info, packages/excorporate/dir: New + files. + +2016-02-24 Thomas Fitzsimmons + + packages/excorporate: New package, import version 0.7.0 + + * packages/excorporate/README, + packages/excorporate/excorporate-calendar.el, + packages/excorporate/excorporate-calfw.el.txt, + packages/excorporate/excorporate-org.el, + packages/excorporate/excorporate.el: New files. + diff --git a/.local/elpa/excorporate-0.8.1/NEWS b/.local/elpa/excorporate-0.8.1/NEWS new file mode 100644 index 00000000..e85e1f0c --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/NEWS @@ -0,0 +1,82 @@ +GNU Emacs Excorporate NEWS -- history of user-visible changes. + +* Excorporate 0.8.1 + +Released 2018-09-15 + +** Depend on nadvice 0.3 + +This fixes excorporate-diary-enable on Emacs 24.1, 24.2, and 24.3. + +* Excorporate 0.8.0 + +Released 2018-09-13 + +** Add functions for retrieving meeting details + +** Add diary support + +M-x excorporate +M-x excorporate-diary-enable +M-x calendar +Press `d' + +** Add appt support + +After you've retrieved today's meetings, several minutes before the +start of the next meeting a reminder window will pop up. + +If Emacs is left running overnight, it will display tomorrow's +meetings at 12:01 AM. + +* Excorporate 0.7.7 + +Released 2018-09-04 + +** Enable calfw support + +* Excorporate 0.7.6 + +Released 2016-10-05 + +** Require some NTLM compatibility fixes via updated dependencies + +* Excorporate 0.7.5 + +Released 2016-06-16 + +** Interoperate with `save-some-buffers' + +* Excorporate 0.7.4 + +Released 2016-06-15 + +** Interoperate with `org-startup-with-latex-preview' + +* Excorporate 0.7.3 + +Released 2016-04-01 + +** Bind q to quit-window in Org mode backend + +* Excorporate 0.7.2 + +Released 2016-03-16 + +** Support Office 365 and Exchange 2010_SP1 + +* Excorporate 0.7.1 + +Released 2016-02-26 + +** Add Info manual + +* Excorporate 0.7.0 + +Released 2016-02-21 + +** First release in GNU ELPA + +Local variables: +mode: outline +end: diff --git a/.local/elpa/excorporate-0.8.1/README b/.local/elpa/excorporate-0.8.1/README new file mode 100644 index 00000000..7389a880 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/README @@ -0,0 +1,20 @@ +Excorporate provides Exchange integration for Emacs. + +To create a connection to a web service: + +M-x excorporate + +Excorporate will prompt for an email address that it will use to +automatically discover settings. Then it will prompt you for your +credentials two or three times depending on the server configuration. + +You should see a message indicating that the connection is ready +either in the minibuffer or in the *Messages* buffer. + +Finally, run M-x calendar, and press 'e' to show today's meetings. + +If autodiscovery fails, customize `excorporate-configuration' to skip +autodiscovery. + +For further information including connection troubleshooting, see the +Excorporate Info node at C-h i d m Excorporate. diff --git a/.local/elpa/excorporate-0.8.1/dir b/.local/elpa/excorporate-0.8.1/dir new file mode 100644 index 00000000..c0433c30 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/dir @@ -0,0 +1,18 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "?" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* Excorporate: (excorporate). Exchange Web Services integration for Emacs. diff --git a/.local/elpa/excorporate-0.8.1/excorporate-autoloads.el b/.local/elpa/excorporate-0.8.1/excorporate-autoloads.el new file mode 100644 index 00000000..e179460f --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate-autoloads.el @@ -0,0 +1,82 @@ +;;; excorporate-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "excorporate" "excorporate.el" (0 0 0 0)) +;;; Generated autoloads from excorporate.el + +(autoload 'excorporate "excorporate" "\ +Start Excorporate. +Prompt for a mail address to use for autodiscovery, with an +initial suggestion of `user-mail-address'. However, if +`excorporate-configuration' is non-nil, `excorporate' will use +that without prompting. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "excorporate" '("exco"))) + +;;;*** + +;;;### (autoloads nil "excorporate-calendar" "excorporate-calendar.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from excorporate-calendar.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "excorporate-calendar" '("exco"))) + +;;;*** + +;;;### (autoloads nil "excorporate-calfw" "excorporate-calfw.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from excorporate-calfw.el + +(autoload 'exco-calfw-show-day "excorporate-calfw" "\ +Show meetings for the date specified by MONTH DAY YEAR. + +\(fn MONTH DAY YEAR)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "excorporate-calfw" '("exco" "cfw:cp-set-contents-sources"))) + +;;;*** + +;;;### (autoloads nil "excorporate-diary" "excorporate-diary.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from excorporate-diary.el + +(autoload 'excorporate-diary-enable "excorporate-diary" "\ +Enable Excorporate diary support. + +\(fn)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "excorporate-diary" '("exco"))) + +;;;*** + +;;;### (autoloads nil "excorporate-org" "excorporate-org.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from excorporate-org.el + +(autoload 'exco-org-show-day "excorporate-org" "\ +Show meetings for the date specified by MONTH DAY YEAR. + +\(fn MONTH DAY YEAR)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "excorporate-org" '("exco"))) + +;;;*** + +;;;### (autoloads nil nil ("excorporate-pkg.el") (0 0 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; excorporate-autoloads.el ends here diff --git a/.local/elpa/excorporate-0.8.1/excorporate-calendar.el b/.local/elpa/excorporate-0.8.1/excorporate-calendar.el new file mode 100644 index 00000000..506ac724 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate-calendar.el @@ -0,0 +1,46 @@ +;;; excorporate-calendar.el --- Exchange for calendar -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Thomas Fitzsimmons +;; Keywords: calendar + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Add a calendar keybinding for Excorporate. Default to the +;; excorporate-org interface. + +;;; Code: + +(require 'calendar) + +(defcustom excorporate-calendar-show-day-function 'exco-org-show-day + "A function to be called by pressing `e' in Calendar." + :type 'function + :group 'excorporate) + +(defun exco-calendar-show-day () + "Show meetings for the selected date." + (interactive) + (apply excorporate-calendar-show-day-function (calendar-cursor-to-date t))) + +;; I arrogantly claim "e" for now, but irresponsibly reserve the right +;; to change it later. +(define-key calendar-mode-map "e" #'exco-calendar-show-day) + +(provide 'excorporate-calendar) + +;;; excorporate-calendar.el ends here diff --git a/.local/elpa/excorporate-0.8.1/excorporate-calfw.el b/.local/elpa/excorporate-0.8.1/excorporate-calfw.el new file mode 100644 index 00000000..5eda6e45 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate-calfw.el @@ -0,0 +1,151 @@ +;;; excorporate-calfw.el --- Exchange calendar view -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Thomas Fitzsimmons +;; Keywords: calendar + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Use the Calfw calendar framework to display daily meetings. + +;; To use this handler, set excorporate-calendar-show-day to +;; exco-calfw-show-day using `customize-variable'. + +;; This Excorporate handler requires the Calfw package, which is not +;; included in GNU ELPA because not all Calfw contributors have +;; copyright assignment papers on file with the FSF. + +;;; Code: + +;; calfw is not FSF-assigned yet so it is not in GNU ELPA. The +;; following workarounds allow excorporate-calfw.elc to be built +;; regardless. +(require 'calfw nil t) + +(declare-function cfw:component-model "ext:calfw" t) +(declare-function cfw:cp-add-selection-change-hook "ext:calfw" t) +(declare-function cfw:cp-get-contents-sources "ext:calfw" t) +(declare-function cfw:create-calendar-component-buffer "ext:calfw" t) +(declare-function cfw:cursor-to-nearest-date "ext:calfw" t) +(declare-function cfw:date "ext:calfw" t) +(declare-function cfw:model-set-contents-sources "ext:calfw" t) +(declare-function cfw:refresh-calendar-buffer "ext:calfw" t) +(declare-function make-cfw:event "ext:calfw" t) +(declare-function make-cfw:source "ext:calfw" t) + +(defvar cfw:component) + +;; Fix a bad bug in calfw. See: +;; https://github.com/kiwanami/emacs-calfw/pull/79 +(defun cfw:cp-set-contents-sources (component sources) + "Set content SOURCES for COMPONENT. +SOURCES is a list of content sources." + (cfw:model-set-contents-sources + sources (cfw:component-model component))) + +(require 'excorporate) + +(defvar excorporate-calfw-buffer-name "*Excorporate*" + "The buffer into which Calfw output is inserted.") + +(defun exco-calfw-initialize-buffer (month day year) + "Set up an initial blank Calfw buffer for date MONTH DAY YEAR." + (with-current-buffer (get-buffer-create excorporate-calfw-buffer-name) + (display-buffer (current-buffer)) + (let ((status-source (make-cfw:source :name "Updating..." + :data (lambda (_b _e) nil)))) + (cfw:create-calendar-component-buffer + :date (cfw:date month day year) :view 'day + :contents-sources (list status-source) + :buffer (current-buffer))))) + +(defun exco-calfw-add-meeting (subject start end location + main-invitees optional-invitees) + "Add a scheduled meeting to the event list. +SUBJECT is a string, the subject of the meeting. START is the +meeting start time in Emacs internal date time format, and END is +the end of the meeting in the same format. LOCATION is a string +representing the location. MAIN-INVITEES and OPTIONAL-INVITEES +are the requested participants." + (let ((start-list (decode-time start)) + (end-list (decode-time end))) + (make-cfw:event :title (concat + (format "\n\t%s" subject) + (format "\n\tLocation: %s" location) + (when main-invitees + (format "\n\tInvitees: %s" + (mapconcat 'identity + main-invitees "; "))) + (when optional-invitees + (format "\n\tOptional: %s" + (mapconcat 'identity + optional-invitees "; ")))) + :start-date (list (elt start-list 4) + (elt start-list 3) + (elt start-list 5)) + :start-time (list (elt start-list 2) + (elt start-list 1)) + :end-date (list (elt end-list 4) + (elt end-list 3) + (elt end-list 5)) + :end-time (list (elt end-list 2) + (elt end-list 1))))) + +(defun exco-calfw-add-meetings (identifier response) + "Add the connection IDENTIFIER's meetings from RESPONSE." + (let ((event-list (exco-calendar-item-iterate response + #'exco-calfw-add-meeting))) + (with-current-buffer (get-buffer-create excorporate-calfw-buffer-name) + (let* ((new-source (make-cfw:source + :name (format "%S (as of %s)" + identifier + (format-time-string "%F %H:%M")) + :data (lambda (_b _e) + event-list))) + (sources (cfw:cp-get-contents-sources cfw:component)) + (new-sources (append sources (list new-source)))) + (cfw:cp-set-contents-sources cfw:component new-sources))))) + +(defun exco-calfw-finalize-buffer () + "Finalize the Calfw widget after retrievals have completed." + (with-current-buffer (get-buffer-create excorporate-calfw-buffer-name) + (let ((sources (cfw:cp-get-contents-sources cfw:component)) + (status-source (make-cfw:source :name "Done." + :data (lambda (_b _e) nil)))) + (cfw:cp-set-contents-sources cfw:component + (cons status-source (cdr sources)))) + (cfw:cp-add-selection-change-hook cfw:component + (lambda () + (apply #'exco-calfw-show-day + (cfw:cursor-to-nearest-date)))) + (cfw:refresh-calendar-buffer nil))) + +;;;###autoload +(defun exco-calfw-show-day (month day year) + "Show meetings for the date specified by MONTH DAY YEAR." + (exco-connection-iterate + (lambda () + (exco-calfw-initialize-buffer month day year)) + (lambda (identifier callback) + (exco-get-meetings-for-day identifier month day year + callback)) + #'exco-calfw-add-meetings + #'exco-calfw-finalize-buffer)) + +(provide 'excorporate-calfw) + +;;; excorporate-calfw.el ends here diff --git a/.local/elpa/excorporate-0.8.1/excorporate-diary.el b/.local/elpa/excorporate-0.8.1/excorporate-diary.el new file mode 100644 index 00000000..c4c94e1f --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate-diary.el @@ -0,0 +1,249 @@ +;;; excorporate-diary.el --- Diary integration -*- lexical-binding: t -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Thomas Fitzsimmons +;; Keywords: calendar + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Wrap interactive `diary-lib' functions so that they query the +;; Exchange server asynchronously, then display retrieved results +;; interleaved with local diary entries. + +;;; Code: + +(require 'diary-lib) +(require 'calendar) +(require 'icalendar) +(require 'appt) +(require 'excorporate) +(require 'nadvice) + +;; FIXME: Add something like this to diary-lib.el. +(defun exco-diary-diary-make-entry (string &optional nonmarking file) + "Insert a diary entry STRING which may be NONMARKING in FILE. +If omitted, NONMARKING defaults to nil and FILE defaults to +`diary-file'." + (with-current-buffer (find-file-noselect (or file diary-file)) + (when (eq major-mode (default-value 'major-mode)) (diary-mode)) + (widen) + (diary-unhide-everything) + (goto-char (point-max)) + (when (let ((case-fold-search t)) + (search-backward "Local Variables:" + (max (- (point-max) 3000) (point-min)) + t)) + (beginning-of-line) + (insert "\n") + (forward-line -1)) + (insert + (if (bolp) "" "\n") + (if nonmarking diary-nonmarking-symbol "") + string))) + +;; FIXME: Have icalendar--add-diary-entry use the new diary-lib +;; function instead of diary-make-entry. +(defun exco-diary-icalendar--add-diary-entry-around (original &rest arguments) + "Prevent whitespace workaround from selecting diary buffer. +Also prevent `diary-make-entry' from putting the diary file +where (other-buffer (current-buffer)) will return it." + (cl-letf (((symbol-function #'find-file) + (symbol-function #'find-file-noselect)) + ;; This override suppresses diary-make-entry's window + ;; and buffer manipulations. + ((symbol-function #'diary-make-entry) + (symbol-function #'exco-diary-diary-make-entry))) + (apply original arguments))) +(advice-add #'icalendar--add-diary-entry :around + #'exco-diary-icalendar--add-diary-entry-around) + +(defvar excorporate-diary-today-file + "~/.emacs.d/excorporate/diary-excorporate-today" + "The diary file where Excorporate should save today's meetings. +This file will be #include'd in `diary-file' by +`excorporate-diary-enable'.") + +(defvar excorporate-diary-transient-file + "~/.emacs.d/excorporate/diary-excorporate-transient" + "The diary file where Excorporate should save retrieved meetings. +This file will be #include'd in `diary-file' by +`excorporate-diary-enable'.") + +(defun exco-diary-initialize (today) + "Initialize diary files used by Excorporate. +Run before retrieving diary entries from servers. TODAY is t to +initialize for today's date, nil otherwise." + ;; Keep today's entries if running on a day other than today. If + ;; retrieving results for today, delete results from days other than + ;; today, in case the transient file (having been filled in on a + ;; prior day) contains duplicate or stale results for today. + (let ((files (if today + (list excorporate-diary-today-file + excorporate-diary-transient-file) + (list excorporate-diary-transient-file)))) + (dolist (file files) + (let ((directory (file-name-directory file))) + (unless (file-exists-p directory) + (make-directory directory)) + (with-current-buffer (find-file-noselect file) + (delete-region (point-min) (point-max)) + ;; Do not call `save-buffer' to avoid any hooks from being + ;; run. Otherwise `appt-update-list' in + ;; `write-file-functions' can cause an infinite + ;; connnection-callback loop. + (basic-save-buffer-1)))))) + +(defun exco-diary-insert-meeting (finalize + subject start _end _location + _main-invitees _optional-invitees + icalendar-text) + "Insert a retrieved meeting into the diary. +See also the documentation for `exco-calendar-item-iterate'. The +arguments are SUBJECT, a string, the subject of the meeting, +START, the start date and time in Emacs internal representation, +and ICALENDAR-TEXT, iCalendar text representing the meeting. +_END, _LOCATION, _MAIN-INVITEES, and _OPTIONAL-INVITEES are +unused. + +Call FINALIZE after the meeting has been inserted." + (when (not (string-match "^Cancel[l]?ed: " subject)) + ;; FIXME: Sometimes meetings are duplicated if they have + ;; overlapping (and (diary-cyclic ...) (diary-block ...)) ranges, + ;; e.g., on in the today file and one in the transient file. + ;; Maybe we should de-duplicate them in the final display. If the + ;; meeting start time is sometime today then put it in today's + ;; diary file, otherwise put it in the transient one. + (let* ((time (decode-time (current-time))) + (now (list (elt time 3) (elt time 4) (elt time 5))) + (dawn (apply #'encode-time 0 0 0 now)) + (dusk (time-add dawn (seconds-to-time 86400))) + (file (if (and (time-less-p dawn start) (time-less-p start dusk)) + excorporate-diary-today-file + excorporate-diary-transient-file))) + (with-temp-buffer + (insert icalendar-text) + (icalendar-import-buffer file t)))) + (funcall finalize)) + +;; Bound in appt-check. +(defvar appt-display-diary) + +(defun exco-diary-diary-advice (today date advisee &rest arguments) + "Advise `diary' and `diary-view-entries' to add Excorporate support. +TODAY is today's date in `calendar-current-date' format. DATE is +the desired date to retrieve meetings for, in the same format. +ADVISEE is the original function being advised. ARGUMENTS are +the arguments to the advisee." + ;; FIXME: Currently numeric arguments to `diary' and + ;; `diary-view-entries' are ignored. + (exco-connection-iterate + (lambda () + (message "Retrieving diary entries via Excorporate...") + (exco-diary-initialize (calendar-date-equal today date))) + (lambda (identifier callback) + (cl-destructuring-bind (month day year) date + (exco-get-meetings-for-day identifier month day year callback))) + (lambda (identifier response finalizer) + (exco-calendar-item-with-details-iterate identifier response + #'exco-diary-insert-meeting + finalizer)) + (lambda () + (apply advisee arguments) + ;; Warning: It is crucial to set appt-display-diary to nil here, + ;; so that diary advice isn't entered repeatedly (ultimately via + ;; the `appt-update-list' hook in `write-file-functions'), which + ;; would create a connection-callback loop. + (let ((appt-display-diary nil)) + (appt-check t)) + (message "Done retrieving diary entries via Excorporate.")) + t) + ;; Just return nil from this advice. We eventually run the advisee + ;; asynchronously so there is no way of providing the same return + ;; value as the unadvised `diary' and `diary-view-entries' + ;; functions. Luckily they seem to only be used interactively, at + ;; least within Emacs itself. + nil) + +(defun exco-diary-diary-around (original-diary &rest arguments) + "Call `diary' asynchronously. +Retrieve diary entries via Excorporate before showing results. +ORIGINAL-DIARY is the original `diary' function, and ARGUMENTS +are the arguments to it." + (let ((today (calendar-current-date)) + (date (calendar-current-date))) + (apply #'exco-diary-diary-advice today date original-diary arguments))) + +(defun exco-diary-diary-view-entries-override (&rest arguments) + "Override `diary-view-entries' to make it asynchronous. +Retrieve diary entries via Excorporate before showing results. +ARGUMENTS are the arguments to `diary-view-entries'." + (interactive "p") + (diary-check-diary-file) + (let ((today (calendar-current-date)) + (date (calendar-cursor-to-date t))) + (apply #'exco-diary-diary-advice today date + #'diary-list-entries date arguments))) + +;;;###autoload +(defun excorporate-diary-enable () + "Enable Excorporate diary support." + (interactive) + ;; Create the directory for Excorporate diary files if it doesn't + ;; already exist. + (exco-diary-initialize t) + ;; Remove advice first so that `diary' will not be run by any save + ;; hooks. + (advice-remove #'diary #'exco-diary-diary-around) + (advice-remove #'diary-view-entries #'exco-diary-diary-view-entries-override) + (with-current-buffer (find-file-noselect diary-file) + (dolist (file (list excorporate-diary-transient-file + excorporate-diary-today-file)) + (save-excursion + (goto-char (point-min)) + (when (not (re-search-forward + (concat "^ *" diary-include-string " *\"" file "\"") nil t)) + (exco-diary-diary-make-entry + (concat diary-include-string " \"" file "\"")) + (save-buffer))))) + (advice-add #'diary :around #'exco-diary-diary-around) + (advice-add #'diary-view-entries :override + #'exco-diary-diary-view-entries-override) + (add-hook 'diary-list-entries-hook #'diary-sort-entries) + (add-hook 'diary-list-entries-hook #'diary-include-other-diary-files) + (appt-activate 1) + (message "Excorporate diary support enabled.")) + +(defun excorporate-diary-disable () + "Disable Excorporate diary support." + (interactive) + (advice-remove #'diary #'exco-diary-diary-around) + (advice-remove #'diary-view-entries #'exco-diary-diary-view-entries-override) + (with-current-buffer (find-file-noselect diary-file) + (dolist (file (list excorporate-diary-transient-file + excorporate-diary-today-file)) + (save-excursion + (goto-char (point-min)) + (when (search-forward + (concat diary-include-string " \"" file "\"") nil t) + (delete-region (progn (beginning-of-line) (point)) + (progn (forward-line 1) (point))) + (save-buffer))))) + (message "Excorporate diary support disabled.")) + +(provide 'excorporate-diary) + +;;; excorporate-diary.el ends here diff --git a/.local/elpa/excorporate-0.8.1/excorporate-org.el b/.local/elpa/excorporate-0.8.1/excorporate-org.el new file mode 100644 index 00000000..22661619 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate-org.el @@ -0,0 +1,151 @@ +;;; excorporate-org.el --- Exchange Org Mode view -*- lexical-binding: t -*- + +;; Copyright (C) 2016 Free Software Foundation, Inc. + +;; Author: Thomas Fitzsimmons +;; Keywords: calendar + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Use the Org Mode to display daily meetings. + +;;; Code: + +(require 'org) +(require 'excorporate) + +(defvar excorporate-org-buffer-name "*Excorporate*" + "The buffer into which Org Mode output is inserted.") + +(defun exco-org-initialize-buffer () + "Add initial text to the destination buffer." + (with-current-buffer (get-buffer-create excorporate-org-buffer-name) + (setq buffer-read-only t) + ;; Some Org mode configurations need `buffer-file-name' to be + ;; non-nil, or they'll make `org-mode' error out, for example + ;; `org-startup-with-latex-preview'. Set `buffer-file-name' to + ;; something non-nil temporarily during initialization. Don't + ;; leave it set or `save-some-buffers' will always prompt about + ;; *Excorporate*. + (let ((buffer-file-name excorporate-org-buffer-name)) + (org-mode)) + (use-local-map (copy-keymap org-mode-map)) + (local-set-key "q" 'quit-window) + (display-buffer (current-buffer)) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max)) + (goto-char 1) + (insert "# Updated...\n")))) + +(defun exco-org-format-headline (identifier) + "Format an Org headline using IDENTIFIER." + (format "* Calendar (%s)\n" identifier)) + +(defun exco-org-insert-meeting-headline (subject start-time end-time) + "Insert and schedule a meeting. +SUBJECT is the meeting's subject, START-TIME and END-TIME are the +meeting's start and end times in the same format as is returned +by `current-time'." + (let* ((now (current-time)) + (keyword (if (time-less-p now end-time) + "TODO" + "DONE"))) + (insert (format "** %s %s\n" keyword subject)) + (org-schedule nil (format-time-string "<%Y-%m-%d %a %H:%M>" + start-time)) + (forward-line -1) + (end-of-line) + (insert "--" (format-time-string "<%Y-%m-%d %a %H:%M>" end-time)) + (forward-line) + (org-insert-time-stamp (current-time) t t "+ Retrieved " "\n"))) + +(defun exco-org-insert-invitees (invitees) + "Parse and insert a list of invitees, INVITEES." + (dolist (invitee invitees) + (insert (format " + %s\n" invitee)))) + +(defun exco-org-insert-headline (identifier month day year) + "Insert Org headline for IDENTIFIER on date MONTH DAY YEAR." + (with-current-buffer (get-buffer-create excorporate-org-buffer-name) + (let ((inhibit-read-only t)) + (insert (exco-org-format-headline identifier)) + (org-insert-time-stamp (encode-time 0 0 0 day month year) + nil t " + Date " "\n")))) + +(defun exco-org-insert-meeting (subject start end location + main-invitees optional-invitees) + "Insert a scheduled meeting. +SUBJECT is a string, the subject of the meeting. START is the +meeting start time in Emacs internal date time format, and END is +the end of the meeting in the same format. LOCATION is a string +representing the location. MAIN-INVITEES and OPTIONAL-INVITEES +are the requested participants." + (exco-org-insert-meeting-headline subject start end) + (insert (format "+ Duration: %d minutes\n" + (round (/ (float-time (time-subtract end start)) 60.0)))) + (insert (format "+ Location: %s\n" location)) + (when main-invitees + (insert "+ Invitees:\n") + (exco-org-insert-invitees main-invitees)) + (when optional-invitees + (insert "+ Optional invitees:\n") + (exco-org-insert-invitees optional-invitees))) + +(defun exco-org-insert-meetings (identifier response) + "Insert the connection IDENTIFIER's meetings from RESPONSE." + (with-current-buffer (get-buffer-create excorporate-org-buffer-name) + (let ((inhibit-read-only t) + (name-regexp (concat "\\" (exco-org-format-headline identifier)))) + (goto-char 1) + (end-of-line) + (insert (format "%s..." identifier)) + (goto-char (point-max)) + (re-search-backward name-regexp nil) + (forward-line 2) + (org-insert-time-stamp (current-time) t t " + Last checked " "\n") + (exco-calendar-item-iterate response #'exco-org-insert-meeting) + (re-search-backward name-regexp nil) + (if (save-excursion (org-goto-first-child)) + (org-sort-entries t ?s) + (forward-line 3) + (insert "`♘"))))) + +(defun exco-org-finalize-buffer () + "Finalize text in buffer after all connections have responded." + (with-current-buffer (get-buffer-create excorporate-org-buffer-name) + ;; Sort top-level entries alphabetically. + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (end-of-line) + (insert "done.") + (org-sort-entries t ?a)))) + +;;;###autoload +(defun exco-org-show-day (month day year) + "Show meetings for the date specified by MONTH DAY YEAR." + (exco-connection-iterate #'exco-org-initialize-buffer + (lambda (identifier callback) + (exco-org-insert-headline identifier + month day year) + (exco-get-meetings-for-day identifier + month day year + callback)) + #'exco-org-insert-meetings + #'exco-org-finalize-buffer)) + +(provide 'excorporate-org) + +;;; excorporate-org.el ends here diff --git a/.local/elpa/excorporate-0.8.1/excorporate-pkg.el b/.local/elpa/excorporate-0.8.1/excorporate-pkg.el new file mode 100644 index 00000000..cc5955c7 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from excorporate.el +(define-package "excorporate" "0.8.1" "Exchange integration" '((emacs "24.1") (fsm "0.2") (soap-client "3.1.4") (url-http-ntlm "2.0.3") (nadvice "0.3")) :url "http://elpa.gnu.org/packages/excorporate.html" :keywords '("calendar")) diff --git a/.local/elpa/excorporate-0.8.1/excorporate.el b/.local/elpa/excorporate-0.8.1/excorporate.el new file mode 100644 index 00000000..ce72fcd0 --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate.el @@ -0,0 +1,920 @@ +;;; excorporate.el --- Exchange integration -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Thomas Fitzsimmons +;; Maintainer: Thomas Fitzsimmons +;; Created: 2014-09-19 +;; Version: 0.8.1 +;; Keywords: calendar +;; Homepage: https://www.fitzsim.org/blog/ +;; Package-Requires: ((emacs "24.1") (fsm "0.2") (soap-client "3.1.4") (url-http-ntlm "2.0.3") (nadvice "0.3")) + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Excorporate provides Exchange integration for Emacs. + +;; To create a connection to a web service: + +;; M-x excorporate + +;; Excorporate will prompt for an email address that it will use to +;; automatically discover settings. Then it will connect to two or +;; three separate hosts: the autodiscovery host, the web service host +;; or load balancer, and the actual server if there is a load +;; balancer. Therefore you may be prompted for your credentials two +;; or three times. + +;; You should see a message indicating that the connection is ready +;; either in the minibuffer or failing that in the *Messages* buffer. + +;; Finally, run M-x calendar, and press 'e' to show today's meetings. + +;; Please try autodiscovery first and report issues not yet listed +;; below. When autodiscovery works it is very convenient; the goal is +;; to make it work for as many users as possible. + +;; If autodiscovery fails, customize `excorporate-configuration' to +;; skip autodiscovery. + +;; Autodiscovery will fail if: + +;; - Excorporate is accessing the server through a proxy (Emacs +;; bug#10). + +;; - The server is not configured to support autodiscovery. + +;; - The email address is at a different domain than the server, e.g., +;; user@domain1.com, autodiscover.domain2.com. + +;; - Authentication is Kerberos/GSSAPI. + +;; Excorporate does know about the special case where the mail address +;; is at a subdomain, e.g., user@sub.domain.com, and the server is at +;; the main domain, e.g., autodiscover.domain.com. Autodiscovery will +;; work in that case. + +;; Excorporate must be loaded before any other package that requires +;; `soap-client'. The version of `soap-client' that Excorporate +;; bundles is backward compatible. + +;; Acknowledgments: + +;; Alexandru Harsanyi provided help and +;; guidance on how to extend soap-client.el's WSDL and XSD handling, +;; enabling support for the full Exchange Web Services API. + +;; Alex Luccisano tested early versions of +;; this library against a corporate installation of Exchange. + +;; Jon Miller tested against Exchange 2013. He +;; also tracked down and reported a bad interaction with other +;; packages that require soap-client. + +;; Nicolas Lamirault tested the +;; autodiscovery feature. + +;; Trey Jackson confirmed autodiscovery worked +;; for him. + +;; Joakim Verona tested autodiscovery in a +;; Kerberos/GSSAPI environment. + +;; Wilfred Hughes tested on Exchange 2007 and +;; suggested documentation improvements. + +;; Erik Hetzner tested on Office 365 and helped debug +;; Office 365 support. + +;; Fabio Leimgruber tested NTLM +;; authentication against a challenging server configuration. + +;; Stefan Monnier wrote a variant of +;; nadvice.el for GNU ELPA so that Excorporate could continue +;; supporting Emacs versions 24.1, 24.2 and 24.3. + +;;; Code: + +;; Implementation-visible functions and variables. + +;; Add NTLM authorization scheme. +(require 'url-http-ntlm) +(require 'soap-client) +(require 'fsm) +(require 'excorporate-calendar) +(require 'org) + +(defconst exco--autodiscovery-templates + '("https://%s/autodiscover/autodiscover.svc" + "https://autodiscover.%s/autodiscover/autodiscover.svc") + "Autodiscovery URL templates. +URL templates to be formatted with a domain name, then searched +for autodiscovery files.") + +(defvar exco--connections nil + "A hash table of finite state machines. +The key is the identifier passed to `exco-connect'. Each finite +state machine represents a service connection.") + +(defvar exco--connection-identifiers nil + "An ordered list of connection identifiers.") + +(defun exco--parse-xml-in-current-buffer () + "Decode and parse the XML contents of the current buffer." + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (prog1 + (car (xml-parse-region (point-min) (point-max))) + (kill-buffer) + (mm-destroy-part mime-part))))) + +(defun exco--bind-wsdl (wsdl service-url port-name target-namespace + binding-name) + "Create a WSDL binding. +Create a binding port for WSDL from SERVICE-URL, PORT-NAME, +TARGET-NAMESPACE and BINDING-NAME." + (let* ((namespace (soap-wsdl-find-namespace target-namespace wsdl)) + (port (make-soap-port + :name port-name + :binding (cons target-namespace binding-name) + :service-url service-url))) + (soap-namespace-put port namespace) + (push port (soap-wsdl-ports wsdl)) + (soap-resolve-references port wsdl) + wsdl)) + +(defun exco--handle-url-error (url status) + "Handle an error that occurred when retrieving URL. +The details of the error are in STATUS, in the same format as the +argument to a `url-retrieve' callback. Return non-nil to retry, +nil to continue." + (if (eq (cl-third (plist-get status :error)) 500) + ;; The server reported an internal server error. Try to recover + ;; by re-requesting the target URL and its most recent redirect. + ;; I'm not sure what conditions cause the server to get into + ;; this state -- it might be because the server has stale + ;; knowledge of old keepalive connections -- but this should + ;; recover it. We need to disable ntlm in + ;; url-registered-auth-schemes so that it doesn't prevent + ;; setting keepalives to nil. + (let ((url-registered-auth-schemes nil) + (url-http-attempt-keepalives nil) + (redirect (plist-get status :redirect))) + (fsm-debug-output "exco--fsm received 500 error for %s" url) + (url-debug 'excorporate "Attempting 500 recovery") + (ignore-errors + ;; Emacs's url-retrieve does not respect the values of + ;; url-http-attempt-keepalives and + ;; url-registered-auth-schemes in asynchronous contexts. + ;; Unless url.el is eventually changed to do so, the + ;; following requests must be synchronous so that they run + ;; entirely within url-http-attempt-keepalives's dynamic + ;; extent. These calls block the main event loop, + ;; unfortunately, but only in this rare error recovery + ;; scenario. + (url-retrieve-synchronously url) + (when redirect (url-retrieve-synchronously redirect))) + (url-debug 'excorporate "Done 500 recovery attempt") + ;; Retry. + t) + ;; We received some other error, which just + ;; means we should try the next URL. + (fsm-debug-output "exco--fsm didn't find %s" url) + ;; Don't retry. + nil)) + +(defun exco--retrieve-next-import (fsm state-data return-for next-state) + "Retrieve the next XML schema import. +FSM is the finite state machine, STATE-DATA is FSM's state data, +and RETURN-FOR is one of :enter or :event to indicate what return +type the calling function expects. NEXT-STATE is the next state +the FSM should transition to on success." + (let* ((url (plist-get state-data :service-url)) + (xml (plist-get state-data :service-xml)) + (wsdl (plist-get state-data :service-wsdl)) + (imports (soap-wsdl-xmlschema-imports wsdl)) + (next-state (if imports :parsing-service-wsdl next-state))) + (when imports + (let ((import-url (url-expand-file-name (pop imports) url))) + (let ((url-request-method "GET") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-http-attempt-keepalives t)) + (url-retrieve + import-url + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (progn + (url-debug 'excorporate "Processing import %s" status) + (if (eq (car status) :error) + ;; There is an error. It may be recoverable + ;; if it's HTTP 500 (internal server error). + (if (and (exco--handle-url-error import-url status) + ;; Only retry once. + (not (plist-get state-data :retrying))) + ;; We should retry. Don't save the + ;; popped urls list to state-data, so + ;; that this :try-next-url will + ;; re-attempt to retrieve the same car as + ;; before. Set the retry flag. + (progn + (plist-put state-data :retrying t)) + ;; Save the popped urls list so that the next url + ;; is attempted, and clear the retry flag. + (plist-put state-data :retrying nil) + (setf (soap-wsdl-xmlschema-imports wsdl) imports) + (plist-put state-data :failure-message + (format "Failed to retrieve %s" + import-url)) + (fsm-send fsm :unrecoverable-error)) + ;; Success, parse WSDL. + (plist-put state-data :retrying nil) + (setf (soap-wsdl-xmlschema-imports wsdl) imports) + (soap-with-local-xmlns xml + (soap-wsdl-add-namespace + (soap-parse-schema (soap-parse-server-response) wsdl) + wsdl)) + (plist-put state-data :service-wsdl wsdl))) + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer)))) + (fsm-send fsm t)))))) + (if (eq return-for :enter) + (list state-data nil) + (list next-state state-data nil)))) + +(define-state-machine exco--fsm :start + ((identifier) + "Start an Excorporate finite state machine." + (if (stringp identifier) + (let ((domain (cadr (split-string identifier "@")))) + (unless (and domain (not (equal domain ""))) + (error "Invalid domain for address %s" identifier)) + (list :retrieving-autodiscovery-xml + (list + ;; State machine data. + ;; Unique finite state machine identifier. Either mail-address + ;; or (mail-address . service-url). The latter allows multiple + ;; state machines to operate on the same service URL. Login + ;; credentials are handled separately by auth-source and url, + ;; so these should be the only two identifier types needed here. + :identifier identifier + ;; User data. + :mail-address identifier + ;; Error recovery data. + :retrying nil + ;; Autodiscovery data. + :autodiscovery-urls + (append (mapcar (lambda (template) + (format template domain)) + exco--autodiscovery-templates) + ;; Handle the user@sub.domain.com => + ;; autodiscover.domain.com case reported by a + ;; user. Only try one extra level. + (let ((domain-parts (split-string domain "\\."))) + (when (> (length domain-parts) 2) + (mapcar (lambda (template) + (format template + (mapconcat + 'identity + (cdr domain-parts) "."))) + exco--autodiscovery-templates)))) + ;; Service data. + :service-url nil + :service-xml nil + :service-wsdl nil + ;; State data. + :next-state-after-success nil + :failure-message nil + :server-version nil) + ;; No timeout. + nil)) + ;; Go directly to :retrieving-service-xml, skipping autodiscovery. + (list :retrieving-service-xml + (list + :identifier identifier + :mail-address (car identifier) + :retrying nil + :autodiscovery-urls nil + ;; Use service-url field from identifier. + :service-url (cdr identifier) + :service-xml nil + :service-wsdl nil + :next-state-after-success nil + :failure-message nil + :server-version nil) + ;; No timeout. + nil)))) + +(define-state exco--fsm :retrieving-autodiscovery-xml + (fsm state-data event _callback) + (cl-case event + (:try-next-url + (let ((urls (plist-get state-data :autodiscovery-urls))) + (if urls + (let ((url (pop urls))) + (fsm-debug-output "exco--fsm will probe %s" url) + (condition-case nil + (url-retrieve + url + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (progn + (url-debug 'excorporate + "Processing status: %s" status) + (if (eq (car status) :error) + (progn + (if (and + (exco--handle-url-error url status) + ;; Only retry once. + (not (plist-get state-data :retrying))) + ;; We should retry. Don't save the popped + ;; urls list to state-data, so that this + ;; :try-next-url will re-attempt to + ;; retrieve the same car as before. Set + ;; the retry flag. + (plist-put state-data :retrying t) + ;; Save the popped urls list so that the + ;; next url is attempted, and clear the + ;; retry flag. + (plist-put state-data :retrying nil) + (plist-put state-data + :autodiscovery-urls urls)) + ;; Try next or retry. + (fsm-send fsm :try-next-url)) + ;; Success, save URL and parse returned XML. + (message + "Excorporate: Found autodiscovery URL for %S: %s" + (plist-get state-data :identifier) url) + (plist-put state-data :retrying nil) + (plist-put state-data :service-url url) + (plist-put state-data :service-xml + (exco--parse-xml-in-current-buffer)) + (fsm-send fsm :success)) + (url-debug 'excorporate "Done processing status")) + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer)))))) + (error + (fsm-debug-output "exco--fsm connection refused for %s" url) + (plist-put state-data :retrying nil) + (plist-put state-data :autodiscovery-urls urls) + (fsm-send fsm :try-next-url))) + (list :retrieving-autodiscovery-xml state-data nil)) + (plist-put state-data :failure-message + "Autodiscovery ran out of URLs to try") + (list :shutting-down-on-error state-data nil)))) + (:success + (plist-put state-data :next-state-after-success :retrieving-service-xml) + (list :parsing-service-wsdl state-data nil)))) + +(define-enter-state exco--fsm :shutting-down-on-error + (_fsm state-data) + (let ((failure-message (plist-get state-data :failure-message))) + (exco-disconnect (plist-get state-data :identifier)) + (message "Excorporate: %s" failure-message) + (url-debug 'excorporate "Failed: %s" failure-message) + (fsm-debug-output "exco--fsm failed: %s" failure-message)) + (list state-data nil)) + +(define-state exco--fsm :shutting-down-on-error + (_fsm state-data _event _callback) + (list :shutting-down-on-error state-data nil)) + +(define-enter-state exco--fsm :retrieving-service-xml + (fsm state-data) + (when (stringp (plist-get state-data :identifier)) + (let* ((xml (plist-get state-data :service-xml)) + (unbound-wsdl (plist-get state-data :service-wsdl)) + (wsdl + (progn + ;; Skip soap-parse-wsdl-phase-fetch-schema to avoid + ;; synchronous URL fetches. + (soap-parse-wsdl-phase-finish-parsing xml unbound-wsdl) + (exco--bind-wsdl + (soap-wsdl-resolve-references unbound-wsdl) + (plist-get state-data :service-url) + "AutodiscoverServicePort" + "http://schemas.microsoft.com/exchange/2010/Autodiscover" + "DefaultBinding_Autodiscover")))) + (soap-invoke-async + (lambda (response) + (let ((result-url + (exco-extract-value '(Response + UserResponses + UserResponse + UserSettings + UserSetting + Value) + response))) + (if result-url + (progn + (plist-put state-data :service-url result-url) + (message "Excorporate: Found service URL for %S: %s" + (plist-get state-data :identifier) + (plist-get state-data :service-url))) + ;; No result. Check for error. + (let ((error-message + (exco-extract-value '(Response + UserResponses + UserResponse + ErrorMessage) + response))) + (if error-message + (message "Excorporate: %s" error-message) + (message "Excorporate: Failed to find service URL")))) + (fsm-send fsm :retrieve-xml))) + nil + wsdl + "AutodiscoverServicePort" + "GetUserSettings" + `((RequestedServerVersion . "Exchange2010") + (Request + (Users + (User + (Mailbox . ,(plist-get state-data :mail-address)))) + (RequestedSettings + (Setting . "InternalEwsUrl"))))))) + (list state-data nil)) + +(define-state exco--fsm :retrieving-service-xml + (fsm state-data event _callback) + (cl-case event + (:unrecoverable-error + (list :shutting-down-on-error state-data nil)) + (:retrieve-xml + (let* ((service-url (plist-get state-data :service-url)) + (wsdl-url (replace-regexp-in-string "/[^/]*$" "/Services.wsdl" + service-url))) + (url-retrieve wsdl-url + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (if (eq (car status) :error) + (progn + (plist-put state-data :failure-message + (format "Failed to retrieve %s" + wsdl-url)) + (fsm-send fsm :unrecoverable-error)) + (plist-put state-data + :service-xml + (exco--parse-xml-in-current-buffer)) + (fsm-send fsm :success)) + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer))))))) + (list :retrieving-service-xml state-data nil)) + (:success + (plist-put state-data :next-state-after-success :retrieving-data) + (list :parsing-service-wsdl state-data nil)))) + +(define-enter-state exco--fsm :parsing-service-wsdl + (fsm state-data) + (let* ((url (plist-get state-data :service-url)) + (xml (plist-get state-data :service-xml)) + (next-state (plist-get state-data :next-state-after-success)) + (wsdl (soap-make-wsdl url))) + (soap-parse-wsdl-phase-validate-node xml) + ;; Skip soap-parse-wsdl-phase-fetch-imports to avoid synchronous + ;; fetches of import URLs. + (soap-parse-wsdl-phase-parse-schema xml wsdl) + (plist-put state-data :service-wsdl wsdl) + (exco--retrieve-next-import fsm state-data :enter next-state))) + +(define-state exco--fsm :parsing-service-wsdl + (fsm state-data event _callback) + (if (eq event :unrecoverable-error) + (list :shutting-down-on-error state-data nil) + (let ((next-state (plist-get state-data :next-state-after-success))) + (exco--retrieve-next-import fsm state-data :event next-state)))) + +(defun exco--get-server-version (wsdl) + "Extract server version from WSDL." + (let ((warning-message "Excorporate: Failed to determine server version") + (namespace "http://schemas.microsoft.com/exchange/services/2006/types") + (name "RequestServerVersion") + (found-version nil)) + (unwind-protect + (setq found-version + (catch 'found + (dolist (attribute + (soap-xs-type-attributes + (soap-xs-element-type (soap-wsdl-get + `(,namespace . ,name) + wsdl 'soap-xs-element-p)))) + (when (equal (soap-xs-attribute-name attribute) "Version") + (throw 'found (car (soap-xs-simple-type-enumeration + (soap-xs-attribute-type attribute)))))) + (warn warning-message) + nil)) + (if found-version + found-version + (warn warning-message) + nil)))) + +(define-enter-state exco--fsm :retrieving-data + (_fsm state-data) + (let ((wsdl (plist-get state-data :service-wsdl)) + (identifier (plist-get state-data :identifier))) + ;; Skip soap-parse-wsdl-phase-fetch-schema to avoid synchronous + ;; URL fetches. + (soap-parse-wsdl-phase-finish-parsing (plist-get state-data :service-xml) + wsdl) + (exco--bind-wsdl + (soap-wsdl-resolve-references wsdl) + (plist-get state-data :service-url) + "ExchangeServicePort" + "http://schemas.microsoft.com/exchange/services/2006/messages" + "ExchangeServiceBinding") + (plist-put state-data :server-version (exco--get-server-version wsdl)) + (fsm-debug-output "exco--fsm %s server version is %s" + identifier (exco-server-version identifier)) + (message "Excorporate: Connection %S is ready" identifier)) + (list state-data nil)) + +(define-state exco--fsm :retrieving-data + (_fsm state-data event _callback) + (let* ((identifier (plist-get state-data :identifier)) + (wsdl (plist-get state-data :service-wsdl)) + (name (pop event)) + (arguments (pop event)) + (callback (pop event))) + (apply #'soap-invoke-async + (lambda (response) + (funcall callback identifier response)) + nil + wsdl + "ExchangeServicePort" + name + arguments)) + (list :retrieving-data state-data nil)) + +(defun exco--ensure-connection () + "Ensure at least one connection exists or throw an error." + (unless exco--connection-identifiers + (error "Excorporate: No connections exist. Run M-x excorporate"))) + +(defmacro exco--with-fsm (identifier &rest body) + "With `fsm' set to IDENTIFIER, run BODY. +Run BODY with `fsm' set to the finite state machine specified by +IDENTIFIER." + (declare (indent 1) (debug t)) + `(progn + (exco--ensure-connection) + (let ((fsm (gethash ,identifier exco--connections))) + (unless fsm + (error "Excorporate: Connection %S does not exist" ,identifier)) + ,@body))) + +;; Developer-visible functions and variables. + +(defun exco-api-version () + "Return the Excorporate API version. +Return a non-negative integer representing the current +Excorporate application programming interface version. Version 0 +is subject to change." + 0) + +(defun exco-connect (identifier) + "Connect or reconnect to a web service. +IDENTIFIER is the mail address to use for autodiscovery or a +pair (mail-address . service-url)." + (if (stringp identifier) + (message "Excorporate: Starting autodiscovery for %S" + identifier)) + (let ((fsm (start-exco--fsm identifier))) + (unless exco--connections + (setq exco--connections (make-hash-table :test 'equal))) + (when (gethash identifier exco--connections) + (exco-disconnect identifier)) + (puthash identifier fsm exco--connections) + (push identifier exco--connection-identifiers) + (if (stringp identifier) + (fsm-send fsm :try-next-url) + (fsm-send fsm :retrieve-xml)) + nil)) + +(defun exco-operate (identifier name arguments callback) + "Execute a service operation asynchronously. +IDENTIFIER is the connection identifier. Execute operation NAME +with ARGUMENTS then call CALLBACK with two arguments, IDENTIFIER +and the server's response." + (exco--with-fsm identifier + (fsm-send fsm (list name arguments callback))) + nil) + +(defun exco-server-version (identifier) + "Return the server version for connection IDENTIFIER, as a string. +Examples are \"Exchange2010\", \"Exchange2010_SP1\", +\"Exchange2013\"." + (exco--with-fsm identifier + (plist-get (fsm-get-state-data fsm) :server-version))) + +(defun exco-disconnect (identifier) + "Disconnect from a web service. +IDENTIFIER is the mail address used to look up the connection." + (exco--with-fsm identifier + (setq exco--connection-identifiers + (delete identifier exco--connection-identifiers)) + (remhash identifier exco--connections)) + nil) + +(defun exco-extract-value (path result) + "Extract the value at PATH from RESULT. +PATH is an ordered list of node names." + (let ((values (nreverse (car result)))) + (dolist (path-element path) + (setq values (assoc path-element values))) + (cdr values))) + +(defun exco-calendar-item-get-details (identifier item-identifier process-item) + "Query server for details about ITEM-IDENTIFIER. +IDENTIFIER is the connection identifier. Call PROCESS-ITEM with +argument ICALENDAR-TEXT." + (exco-operate identifier + "GetItem" + `(((ItemShape + (BaseShape . "IdOnly") + (IncludeMimeContent . t)) + (ItemIds ,item-identifier)) + nil nil nil nil nil nil) + (lambda (_identifier response) + (let* ((mime-path '(ResponseMessages + GetItemResponseMessage + Items + CalendarItem + MimeContent)) + (character-set-path (append mime-path '(CharacterSet))) + (coding-system (intern (downcase (exco-extract-value + character-set-path + response))))) + (unless (member coding-system coding-system-list) + (error "Unrecognized coding system: %s" + (exco-extract-value character-set-path response))) + (funcall process-item (decode-coding-string + (base64-decode-string + (cdr (exco-extract-value + mime-path response))) + coding-system)))))) + +(defmacro exco--calendar-item-dolist (item items &rest forms) + "Iterate through ITEMS. +On each iteration, ITEM is set, and FORMS are run." + `(dolist (,item ,items) + (let* ((subject (cdr (assoc 'Subject ,item))) + (start (cdr (assoc 'Start ,item))) + (start-internal (apply #'encode-time + (soap-decode-date-time + start 'dateTime))) + (end (cdr (assoc 'End ,item))) + (end-internal (apply #'encode-time + (soap-decode-date-time + end 'dateTime))) + (location (cdr (assoc 'Location ,item))) + (to-invitees (cdr (assoc 'DisplayTo ,item))) + (main-invitees (when to-invitees + (mapcar 'org-trim + (split-string to-invitees ";")))) + (cc-invitees (cdr (assoc 'DisplayCc ,item))) + (optional-invitees (when cc-invitees + (mapcar 'org-trim + (split-string cc-invitees ";")))) + (item-identifier (assoc 'ItemId ,item))) + ,@forms))) + +(defun exco-calendar-item-with-details-iterate (identifier + response + callback + finalize) + "Iterate through calendar items in RESPONSE, calling CALLBACK on each. +IDENTIFIER identifies the connection. + +CALLBACK takes the following arguments: FINALIZE, which is the +FINALIZE argument to this function wrapped in a countdown, +SUBJECT, a string, the subject of the meeting, START, the start +date and time in Emacs internal representation, END, the start +date and time in Emacs internal representation, LOCATION, the +location of the meeting, MAIN-INVITEES, a list of strings +representing required participants, OPTIONAL-INVITEES, a list of +strings representing optional participants, DETAILS is the +meeting request message body, and ICALENDAR-TEXT, the iCalendar +text representing the meeting series. + +CALLBACK must arrange for FINALIZE to be called after its main +processing is done." + (let* ((items (exco-extract-value '(ResponseMessages + FindItemResponseMessage + RootFolder + Items) + response)) + (countdown (length items)) + (finalizer + (lambda (&rest arguments) + (setq countdown (1- countdown)) + (when (equal countdown 0) + (apply finalize arguments))))) + (if (equal countdown 0) + (funcall finalize) + (exco--calendar-item-dolist + calendar-item items + (exco-calendar-item-get-details + identifier item-identifier + (lambda (icalendar-text) + (funcall callback finalizer subject start-internal end-internal + location main-invitees optional-invitees + icalendar-text))))))) + +(defun exco-calendar-item-iterate (response callback) + "Iterate through calendar items in RESPONSE, calling CALLBACK on each. +Returns a list of results from callback. CALLBACK takes arguments: +SUBJECT, a string, the subject of the meeting. +START, the start date and time in Emacs internal representation. +END, the start date and time in Emacs internal representation. +LOCATION, the location of the meeting. +MAIN-INVITEES, a list of strings representing required participants. +OPTIONAL-INVITEES, a list of strings representing optional participants." + (let ((result-list '())) + (exco--calendar-item-dolist + calendar-item (exco-extract-value '(ResponseMessages + FindItemResponseMessage + RootFolder + Items) + response) + ;; Silence byte compiler unused warning. + item-identifier + (push (funcall callback subject start-internal end-internal + location main-invitees optional-invitees) + result-list)) + (nreverse result-list))) + +;; Date-time utility functions. +(defun exco-extend-timezone (date-time-string) + "Add a colon to the timezone in DATE-TIME-STRING. +DATE-TIME-STRING must be formatted as if returned by +`format-time-string' with FORMAT-STRING \"%FT%T%z\". Web +services require the ISO8601 extended format of timezone, which +includes the colon." + (concat + (substring date-time-string 0 22) ":" (substring date-time-string 22))) + +(defun exco-format-date-time (time-internal) + "Convert TIME-INTERNAL to an XSD compatible date-time string." + (exco-extend-timezone + (format-time-string "%FT%T%z" time-internal))) + +;; Use month day year order to be compatible with +;; calendar-cursor-to-date. I wish I could instead use the ISO 8601 +;; ordering, year month day. +(defun exco-get-meetings-for-day (identifier month day year callback) + "Return the meetings for the specified day. +IDENTIFIER is the connection identifier. MONTH, DAY and YEAR are +the meeting month, day and year. Call CALLBACK with two +arguments, IDENTIFIER and the server's response." + (let* ((start-of-day-time-internal + (apply #'encode-time `(0 0 0 ,day ,month ,year))) + (start-of-day-date-time + (exco-format-date-time start-of-day-time-internal)) + (start-of-next-day-date-time + (exco-extend-timezone + (format-time-string "%FT00:00:00%z" + (time-add start-of-day-time-internal + (seconds-to-time 86400)))))) + (exco-operate + identifier + "FindItem" + `(;; Main arguments. + (;; RequestVersion is usually overridden by a fixed value in + ;; the WSDL (the RequestServerVersion element); provide the + ;; maximally-compatible Exchange2007 if the fixed value isn't + ;; present. + (RequestVersion (Version . "Exchange2007")) + (Traversal . "Shallow") + (ItemShape + (BaseShape . "AllProperties")) + ;; To aid productivity, excorporate-calfw automatically prunes your + ;; meetings to a maximum of 100 per day. + (CalendarView (MaxEntriesReturned . "100") + (StartDate . ,start-of-day-date-time) + (EndDate . ,start-of-next-day-date-time)) + (ParentFolderIds + (DistinguishedFolderId (Id . "calendar")))) + ;; Empty arguments. + ,@(let* ((wsdl (exco--with-fsm identifier + (plist-get (fsm-get-state-data fsm) + :service-wsdl))) + (arity (soap-operation-arity wsdl + "ExchangeServicePort" + "FindItem"))) + (make-list (- arity 1) nil))) + callback))) + +(defun exco-connection-iterate (initialize-function + per-connection-function + per-connection-callback + finalize-function + &optional callback-will-call-finalize) + "Iterate Excorporate connections. +Call INITIALIZE-FUNCTION once before iterating. It takes no +arguments. + +Call PER-CONNECTION-FUNCTION once for each server connection. It +is run synchronously. It accepts two arguments, IDENTIFIER, the +current server connection, and CALLBACK, which is a wrapped +version of PER-CONNECTION-CALLBACK. + +PER-CONNECTION-CALLBACK takes a variable number of arguments, +depending on which callback it is. If +CALLBACK-WILL-CALL-FINALIZE is non-nil, it takes a final +FINALIZE-FUNCTION argument, which is a countdown-wrapped +finalizer function that PER-CONNECTION-CALLBACK should call (or +arrange to be called asynchronously) each time it is invoked. + +If CALLBACK-WILL-CALL-FINALIZE is non-nil, this function will not +call FINALIZE-FUNCTION itself. Instead it will wrap +FINALIZE-FUNCTION into a function that can be called once per +connection, then pass the wrapped finalizer to the callback as an +argument. CALLBACK-WILL-CALL-FINALIZE must be set if the +callback needs to make a recursive asynchronous call." + (exco--ensure-connection) + (funcall initialize-function) + (let* ((countdown (length exco--connection-identifiers)) + (wrapped-finalizer + (lambda (&rest arguments) + (setq countdown (1- countdown)) + (when (equal countdown 0) + (apply finalize-function arguments)))) + (wrapped-callback + (lambda (&rest arguments) + (apply per-connection-callback + (append arguments + (when callback-will-call-finalize + (list wrapped-finalizer)))) + (unless callback-will-call-finalize + (funcall wrapped-finalizer))))) + (dolist (identifier exco--connection-identifiers) + (funcall per-connection-function identifier + wrapped-callback)))) + +;; User-visible functions and variables. +(defgroup excorporate nil + "Exchange support." + :version "25.1" + :group 'comm + :group 'calendar) + +;; Name the excorporate-configuration variable vaguely. It is currently a +;; MAIL-ADDRESS string, a pair (MAIL-ADDRESS . SERVICE-URL), or nil. In the +;; future it could allow a list of strings and pairs. +(defcustom excorporate-configuration nil + "Excorporate configuration. +The mail address to use for autodiscovery." + :type '(choice + (const + :tag "Prompt for Exchange mail address to use for autodiscovery" nil) + (string :tag "Exchange mail address to use for autodiscovery") + (cons :tag "Skip autodiscovery" + (string :tag "Exchange mail address (e.g., hacker@gnu.org)") + (string :tag "Exchange Web Services URL\ + (e.g., https://mail.gnu.org/ews/exchange.asmx)")))) + +;;;###autoload +(defun excorporate () + "Start Excorporate. +Prompt for a mail address to use for autodiscovery, with an +initial suggestion of `user-mail-address'. However, if +`excorporate-configuration' is non-nil, `excorporate' will use +that without prompting." + (interactive) + (cond + ((eq excorporate-configuration nil) + (exco-connect (completing-read "Exchange mail address: " + (list user-mail-address) + nil nil user-mail-address))) + ((stringp excorporate-configuration) + (exco-connect excorporate-configuration)) + ((null (consp (cdr excorporate-configuration))) + (exco-connect excorporate-configuration)) + (t + (error "Excorporate: Invalid configuration")))) + +(provide 'excorporate) + +;;; excorporate.el ends here diff --git a/.local/elpa/excorporate-0.8.1/excorporate.info b/.local/elpa/excorporate-0.8.1/excorporate.info new file mode 100644 index 00000000..1b15e48d --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate.info @@ -0,0 +1,237 @@ +This is excorporate.info, produced by makeinfo version 6.4 from +excorporate.texi. + +Copyright (C) 2016 Free Software Foundation, Inc. + + Permission is granted to copy, distribute and/or modify this + document under the terms of the GNU Free Documentation License, + Version 1.2 or any later version published by the Free Software + Foundation; with no Invariant Sections, with the Front-Cover, or + Back-Cover Texts. A copy of the license is included in the section + entitled "GNU Free Documentation License" in the Emacs manual. + + This document is part of a collection distributed under the GNU + Free Documentation License. If you want to distribute this + document separately from the collection, you can do so by adding a + copy of the license to the document, as described in section 6 of + the license. + + All Emacs Lisp code contained in this document may be used, + distributed, and modified without restriction. +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Excorporate: (excorporate). Exchange Web Services integration for Emacs. +END-INFO-DIR-ENTRY + + +File: excorporate.info, Node: Top, Next: Installation, Up: (dir) + +Excorporate Manual +****************** + +Excorporate provides Exchange Web Services (EWS) support for Emacs. + + If the Exchange server you access is configured to provide EWS +support, then there's an 83% chance that Excorporate will enable you to +retrieve your calendar entries from the comfort of Emacs. + + The 17% failure rate is because authenticating against an Exchange +server can be challenging. + + Kerberos/GSSAPI authentication is known to fail. Accessing the +server through a proxy may be possible now that + is fixed. + + Reports of success or failure of different connection types are +welcome, as are patches to enable more of these access scenarios. See +*note Reporting Bugs::. + +* Menu: + +* Installation:: Getting and installing 'excorporate'. +* Configuration:: Configuring 'excorporate'. +* Usage:: Using 'excorporate'. +* Troubleshooting:: Debugging why a connection failed +* Reporting Bugs:: Reporting bugs + + +File: excorporate.info, Node: Installation, Next: Configuration, Prev: Top, Up: Top + +1 Installation +************** + +Excorporate works on Emacs versions >= 24.1. + +Install 'excorporate' from the GNU ELPA repository: + + 'M-x package-install RET excorporate' + + +File: excorporate.info, Node: Configuration, Next: Usage, Prev: Installation, Up: Top + +2 Configuration +*************** + +Ideally you won't need to configure Excorporate at all. On friendly +Exchange setups, Excorporate can discover the EWS URL automatically. + +First try: + + 'M-x excorporate' + +which will prompt you for the Exchange account email address. Follow +the prompts and if all goes well, you'll see a message in the minibuffer +or in *Messages* saying that the connection is ready. + +If autodiscovery runs out of URLs to try, then customize +'excorporate-configuration': + + 'M-x customize-variable RET excorporate-configuration' + +From the value menu select "Skip autodiscovery". This allows you to +enter the Exchange account email address and the EWS URL directly. The +EWS URL is of the form 'https://mail.gnu.org/ews/exchange.asmx'. + +After saving the configuration, try 'M-x excorporate' again. + +If that doesn't work, *note Troubleshooting::. + + +File: excorporate.info, Node: Usage, Next: Troubleshooting, Prev: Configuration, Up: Top + +3 Usage +******* + +Excorporate can put entries it retrieves into the Emacs Diary, and use +'appt' to remind you a few minutes before a meeting starts. To enable +this support, do: + + 'M-x excorporate-diary-enable' + +Open the calendar with: + + 'M-x calendar' + +move the cursor to the date you want to see meetings for, and press 'd'. +Some time later, asynchronously, a window will pop up containing events +retrieved from the Exchange server in addition to locally-entered diary +events. The events are all sorted by time. + + Excorporate also binds 'e' in '*Calendar*' buffers to +'excorporate-calendar-show-day-function' to allow a different view of +retrieved events. By default, 'excorporate-calendar-show-day-function' +is set to 'exco-org-show-day' which displays meetings in a temporary +read-only Org Mode buffer named '*Excorporate*'. + + If you prefer, you can install the 'calfw' package, and set +'excorporate-calendar-show-day-function' to 'exco-calfw-show-day'. + + After you've retrieved today's meetings, 'appt' will warn you several +minutes before your next meeting starts by popping up a window with the +meeting details. + + If you leave Emacs running overnight, at 12:01 AM 'appt' (via +Excorporate) will retrieve your meetings and display your diary so that +you see the day's events first thing in the morning. + + +File: excorporate.info, Node: Troubleshooting, Next: Reporting Bugs, Prev: Usage, Up: Top + +4 Troubleshooting +***************** + +First, you'll want to double-check that the Exchange server you're +trying to access provides EWS support. If it doesn't, Excorporate can't +do anything for you. Before asking your Exchange administrator, check +intranet wikis and so forth; other users of non-standard clients may +have already found the EWS URL. This is called the "EWS endpoint". It +can be as simple as, e.g.: + + 'https://mail.gnu.org/ews/exchange.asmx' + +First you need to make sure you can access the endpoint. + +For Exchange Web Services (EWS) which Excorporate uses, you'll have to +determine the EWS endpoint for your Exchange account, call it 'ews-url'. +It is usually something like: + + https:///ews/exchange.asmx + +Excorporate calculates the WSDL URL, call it 'wsdl-url', by replacing +the endpoint's last path element with "Services.wsdl": + + https:///ews/Services.wsdl + +Before even attempting Excorporate, you have to make these succeed: + + (with-current-buffer + (url-retrieve-synchronously ews-url) + (buffer-string)) + +When this works, you'll see web page text in *Messages*, containing a +message about having created a service. + + (with-current-buffer + (url-retrieve-synchronously wsdl-url) + (buffer-string)) + +When this works, it will show a bunch of WSDL (XML) in *Messages*. + +Debug the above URL retrievals with (setq url-debug t), and with this +patch: + + diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el + index d49e527..0f1c8ae 100644 + --- a/lisp/url/url-http.el + +++ b/lisp/url/url-http.el + @ -869,6 +869,7 @ url-http-parse-headers + (url-handle-content-transfer-encoding)) + (url-http-debug "Finished parsing HTTP headers: %S" success) + (widen) + + (url-http-debug "Response: %s" (buffer-string)) + (goto-char (point-min)) + success)) + + +(Beware that HTTP responses are out-of-order with this patch.) + +Once you're sure the above steps are working, try 'M-x excorporate'. + +The buffer '*fsm-debug*' shows 'excorporate' state transitions and +should provide details of where things went wrong. + +Also check '*Messages*' for anything obvious. + +If you suspect something wrong with accessing the EWS URL, try setting +'url-debug' to t and retry 'M-x excorporate', then check the +'*URL-DEBUG*' buffer for output. + +If you suspect NTLM authentication is failing, as a long shot, you might +try setting 'ntlm-compatibility-level' to 0 and retrying 'M-x +excorporate'. + +Excorporate's dependencies implement the tricky elements of asynchronous +Exchange access: a state machine ('fsm'), TLS negotiation ('gnutls'), +NTLM authentication ('ntlm' and 'url-http-ntlm') and SOAP communication +('soap-client'). + + +File: excorporate.info, Node: Reporting Bugs, Prev: Troubleshooting, Up: Top + +5 Reporting Bugs +**************** + +To report a bug, use 'M-x report-emacs-bug', and put Excorporate +somewhere in the subject. + + + +Tag Table: +Node: Top1103 +Node: Installation2222 +Node: Configuration2485 +Node: Usage3445 +Node: Troubleshooting4863 +Node: Reporting Bugs7698 + +End Tag Table diff --git a/.local/elpa/excorporate-0.8.1/excorporate.texi b/.local/elpa/excorporate-0.8.1/excorporate.texi new file mode 100644 index 00000000..43c4943a --- /dev/null +++ b/.local/elpa/excorporate-0.8.1/excorporate.texi @@ -0,0 +1,260 @@ +\input texinfo +@setfilename excorporate.info +@settitle Excorporate Manual + +@dircategory Emacs +@direntry +* Excorporate: (excorporate). Exchange Web Services integration for Emacs. +@end direntry + +@copying +Copyright @copyright{} 2016 Free Software Foundation, Inc. + +@quotation +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.2 or +any later version published by the Free Software Foundation; with no +Invariant Sections, with the Front-Cover, or Back-Cover Texts. A copy of +the license is included in the section entitled ``GNU Free Documentation +License'' in the Emacs manual. + +This document is part of a collection distributed under the GNU Free +Documentation License. If you want to distribute this document +separately from the collection, you can do so by adding a copy of the +license to the document, as described in section 6 of the license. + +All Emacs Lisp code contained in this document may be used, distributed, +and modified without restriction. +@end quotation +@end copying + +@titlepage +@title Excorporate Manual +@author Thomas Fitzsimmons +@page +@insertcopying +@end titlepage + +@contents + +@node Top +@top Excorporate Manual + +Excorporate provides Exchange Web Services (EWS) support for Emacs. + +If the Exchange server you access is configured to provide EWS +support, then there's an 83% chance that Excorporate will enable you +to retrieve your calendar entries from the comfort of Emacs. + +The 17% failure rate is because authenticating against an Exchange +server can be challenging. + +Kerberos/GSSAPI authentication is known to fail. Accessing the server +through a proxy may be possible now that +@uref{https://debbugs.gnu.org/cgi/bugreport.cgi?bug=10} is fixed. + +Reports of success or failure of different connection types are +welcome, as are patches to enable more of these access scenarios. See +@pxref{Reporting Bugs}. + +@menu +* Installation:: Getting and installing @code{excorporate}. +* Configuration:: Configuring @code{excorporate}. +* Usage:: Using @code{excorporate}. +* Troubleshooting:: Debugging why a connection failed +* Reporting Bugs:: Reporting bugs +@end menu + +@node Installation +@chapter Installation + +Excorporate works on Emacs versions >= 24.1. + +@noindent +Install @code{excorporate} from the GNU ELPA repository: + +@code{M-x package-install RET excorporate} + +@node Configuration +@chapter Configuration + +@noindent +Ideally you won't need to configure Excorporate at all. On friendly +Exchange setups, Excorporate can discover the EWS URL automatically. + +@noindent +First try: + +@code{M-x excorporate} + +@noindent +which will prompt you for the Exchange account email address. Follow +the prompts and if all goes well, you'll see a message in the +minibuffer or in *Messages* saying that the connection is ready. + +@noindent +If autodiscovery runs out of URLs to try, then customize +@code{excorporate-configuration}: + +@code{M-x customize-variable RET excorporate-configuration} + +@noindent +From the value menu select ``Skip autodiscovery''. This allows you to +enter the Exchange account email address and the EWS URL directly. +The EWS URL is of the form +@code{https://mail.gnu.org/ews/exchange.asmx}. + +@noindent +After saving the configuration, try @code{M-x excorporate} again. + +@noindent +If that doesn't work, @pxref{Troubleshooting}. + +@node Usage +@chapter Usage + +@noindent +Excorporate can put entries it retrieves into the Emacs Diary, and use +@code{appt} to remind you a few minutes before a meeting starts. To +enable this support, do: + +@code{M-x excorporate-diary-enable} + +@noindent +Open the calendar with: + +@code{M-x calendar} + +@noindent +move the cursor to the date you want to see meetings for, and press +`d'. Some time later, asynchronously, a window will pop up containing +events retrieved from the Exchange server in addition to +locally-entered diary events. The events are all sorted by time. + +Excorporate also binds `e' in @code{*Calendar*} buffers to +@code{excorporate-calendar-show-day-function} to allow a different +view of retrieved events. By default, +@code{excorporate-calendar-show-day-function} is set to +@code{exco-org-show-day} which displays meetings in a temporary +read-only Org Mode buffer named @code{*Excorporate*}. + +If you prefer, you can install the @code{calfw} package, and set +@code{excorporate-calendar-show-day-function} to +@code{exco-calfw-show-day}. + +After you've retrieved today's meetings, @code{appt} will warn you +several minutes before your next meeting starts by popping up a window +with the meeting details. + +If you leave Emacs running overnight, at 12:01 AM @code{appt} (via +Excorporate) will retrieve your meetings and display your diary so +that you see the day's events first thing in the morning. + +@node Troubleshooting +@chapter Troubleshooting + +@noindent +First, you'll want to double-check that the Exchange server you're +trying to access provides EWS support. If it doesn't, Excorporate +can't do anything for you. Before asking your Exchange administrator, +check intranet wikis and so forth; other users of non-standard clients +may have already found the EWS URL. This is called the ``EWS +endpoint''. It can be as simple as, e.g.: + +@code{https://mail.gnu.org/ews/exchange.asmx} + +@noindent +First you need to make sure you can access the endpoint. + +@noindent +For Exchange Web Services (EWS) which Excorporate uses, you'll have to +determine the EWS endpoint for your Exchange account, call it +@code{ews-url}. It is usually something like: + + https:///ews/exchange.asmx + +@noindent +Excorporate calculates the WSDL URL, call it @code{wsdl-url}, by +replacing the endpoint's last path element with ``Services.wsdl'': + + https:///ews/Services.wsdl + +@noindent +Before even attempting Excorporate, you have to make these succeed: + +@example +(with-current-buffer + (url-retrieve-synchronously ews-url) + (buffer-string)) +@end example + +@noindent +When this works, you'll see web page text in *Messages*, containing a +message about having created a service. + +@example +(with-current-buffer + (url-retrieve-synchronously wsdl-url) + (buffer-string)) +@end example + +@noindent +When this works, it will show a bunch of WSDL (XML) in *Messages*. + +@noindent +Debug the above URL retrievals with (setq url-debug t), and with this +patch: + +@example +diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el +index d49e527..0f1c8ae 100644 +--- a/lisp/url/url-http.el ++++ b/lisp/url/url-http.el +@@ -869,6 +869,7 @@ url-http-parse-headers + (url-handle-content-transfer-encoding)) + (url-http-debug "Finished parsing HTTP headers: %S" success) + (widen) ++ (url-http-debug "Response: %s" (buffer-string)) + (goto-char (point-min)) + success)) + +@end example + +@noindent +(Beware that HTTP responses are out-of-order with this patch.) + +@noindent +Once you're sure the above steps are working, try @code{M-x +excorporate}. + +@noindent +The buffer @code{*fsm-debug*} shows @code{excorporate} state +transitions and should provide details of where things went wrong. + +@noindent +Also check @code{*Messages*} for anything obvious. + +@noindent +If you suspect something wrong with accessing the EWS URL, try setting +@code{url-debug} to t and retry @code{M-x excorporate}, then check the +@code{*URL-DEBUG*} buffer for output. + +@noindent +If you suspect NTLM authentication is failing, as a long shot, you +might try setting @code{ntlm-compatibility-level} to 0 and retrying +@code{M-x excorporate}. + +@noindent +Excorporate's dependencies implement the tricky elements of +asynchronous Exchange access: a state machine (@code{fsm}), TLS +negotiation (@code{gnutls}), NTLM authentication (@code{ntlm} and +@code{url-http-ntlm}) and SOAP communication (@code{soap-client}). + +@node Reporting Bugs +@chapter Reporting Bugs + +@noindent +To report a bug, use @code{M-x report-emacs-bug}, and put Excorporate +somewhere in the subject. + +@bye diff --git a/.local/elpa/fsm-0.2.1/fsm-autoloads.el b/.local/elpa/fsm-0.2.1/fsm-autoloads.el new file mode 100644 index 00000000..956eb2e0 --- /dev/null +++ b/.local/elpa/fsm-0.2.1/fsm-autoloads.el @@ -0,0 +1,22 @@ +;;; fsm-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "fsm" "fsm.el" (0 0 0 0)) +;;; Generated autoloads from fsm.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "fsm" '("fsm-"))) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; fsm-autoloads.el ends here diff --git a/.local/elpa/fsm-0.2.1/fsm-pkg.el b/.local/elpa/fsm-0.2.1/fsm-pkg.el new file mode 100644 index 00000000..631035e4 --- /dev/null +++ b/.local/elpa/fsm-0.2.1/fsm-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "fsm" "0.2.1" "state machine library" '((emacs "24.1") (cl-lib "0.5")) :url "http://elpa.gnu.org/packages/fsm.html" :keywords '("extensions")) diff --git a/.local/elpa/fsm-0.2.1/fsm.el b/.local/elpa/fsm-0.2.1/fsm.el new file mode 100644 index 00000000..9cc77517 --- /dev/null +++ b/.local/elpa/fsm-0.2.1/fsm.el @@ -0,0 +1,503 @@ +;;; fsm.el --- state machine library -*- lexical-binding: t; -*- + +;; Copyright (C) 2006, 2007, 2008, 2015 Free Software Foundation, Inc. + +;; Author: Magnus Henoch +;; Maintainer: Thomas Fitzsimmons +;; Version: 0.2.1 +;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) +;; Keywords: extensions + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; fsm.el is an exercise in metaprogramming inspired by gen_fsm of +;; Erlang/OTP. It aims to make asynchronous programming in Emacs Lisp +;; easy and fun. By "asynchronous" I mean that long-lasting tasks +;; don't interfer with normal editing. + +;; Some people say that it would be nice if Emacs Lisp had threads +;; and/or continuations. They are probably right, but there are few +;; things that can't be made to run in the background using facilities +;; already available: timers, filters and sentinels. As the code can +;; become a bit messy when using such means, with callbacks everywhere +;; and such things, it can be useful to structure the program as a +;; state machine. + +;; In this model, a state machine passes between different "states", +;; which are actually only different event handler functions. The +;; state machine receives "events" (from timers, filters, user +;; requests, etc) and reacts to them, possibly entering another state, +;; possibly returning a value. + +;; The essential macros/functions are: +;; +;; define-state-machine - create start-FOO function +;; define-state - event handler for each state (required) +;; define-enter-state - called when entering a state (optional) +;; define-fsm - encapsulates the above three (more sugar!) +;; fsm-send - send an event to a state machine +;; fsm-call - send an event and wait for reply + +;; fsm.el is similar to but different from Distel: +;; +;; Emacs' tq library is a similar idea. + +;; Here is a simple (not using all the features of fsm.el) example: +;; +;; ;; -*- lexical-binding: t; -*- +;; (require 'fsm) +;; (cl-labels ((hey (n ev) +;; (message "%d (%s)\tp%sn%s!" n ev +;; (if (zerop (% n 4)) "o" "i") +;; (make-string (max 1 (abs n)) ?g)))) +;; (cl-macrolet ((zow (next timeout) +;; `(progn (hey (cl-incf count) event) +;; (list ,next count ,timeout)))) +;; (define-fsm pingpong +;; :start ((init) "Start a pingpong fsm." +;; (interactive "nInit (number, negative to auto-terminate): ") +;; (list :ping (ash (ash init -2) 2) ; 4 is death +;; (when (interactive-p) 0))) +;; :state-data-name count +;; :states +;; ((:ping +;; (:event (zow :pingg 0.1))) +;; (:pingg +;; (:event (zow :pinggg 0.1))) +;; (:pinggg +;; (:event (zow :pong 1))) +;; (:pong +;; (:event (zow :ping (if (= 0 count) +;; (fsm-goodbye-cruel-world 'pingpong) +;; 3)))))))) +;; (fsm-send (start-pingpong -16) t) +;; +;; Copy into a buffer, uncomment, and type M-x eval-buffer RET. +;; Alternatively, you can replace the `fsm-goodbye-cruel-world' +;; form with `nil', eval just the `cl-labels' form and then type +;; M-x start-pingpong RET -16 RET. + +;; Version 0.2: +;; -- Delete trailing whitespace. +;; -- Fix formatting. +;; -- Use lexical binding. +;; -- Port to cl-lib. +;; -- Remove unnecessary fsm-debug-output message. +;; -- Add FSM name to fsm-debug-output messages that were not including it. +;; -- Fix checkdoc errors. +;; -- Change FSMs from plists to uninterned symbols. + +;; NOTE: This is version 0.1ttn4 of fsm.el, with the following +;; mods (an exercise in meta-meta-programming ;-) by ttn: +;; -- Refill for easy (traditional 80-column) perusal. +;; -- New var `fsm-debug-timestamp-format'. +;; -- Make variables satisfy `user-variable-p'. +;; -- Use `format' instead of `concat'. +;; -- New func `fsm-goodbye-cruel-world'. +;; -- Make start-function respect `interactive' spec. +;; -- Make enter-/event-functions anonymous. +;; -- New macro `define-fsm'. +;; -- Example usage in Commentary. + +;;; Code: + +;; We require cl-lib at runtime, since we insert `cl-destructuring-bind' into +;; modules that use fsm.el. +(require 'cl-lib) + +(defvar fsm-debug "*fsm-debug*" + "*Name of buffer for fsm debug messages. +If nil, don't output debug messages.") + +(defvar fsm-debug-timestamp-format nil + "*Timestamp format (a string) for `fsm-debug-output'. +Default format is whatever `current-time-string' returns +followed by a colon and a space.") + +(defun fsm-debug-output (format &rest args) + "Append debug output to buffer named by the variable `fsm-debug'. +FORMAT and ARGS are passed to `format'." + (when fsm-debug + (with-current-buffer (get-buffer-create fsm-debug) + (save-excursion + (goto-char (point-max)) + (insert (if fsm-debug-timestamp-format + (format-time-string fsm-debug-timestamp-format) + (concat (current-time-string) ": ")) + (apply 'format format args) "\n"))))) + +(cl-defmacro define-state-machine (name &key start sleep) + "Define a state machine class called NAME. +A function called start-NAME is created, which uses the argument +list and body specified in the :start argument. BODY should +return a list of the form (STATE STATE-DATA [TIMEOUT]), where +STATE is the initial state (defined by `define-state'), +STATE-DATA is any object, and TIMEOUT is the number of seconds +before a :timeout event will be sent to the state machine. BODY +may refer to the instance being created through the dynamically +bound variable `fsm'. + +SLEEP-FUNCTION, if provided, takes one argument, the number of +seconds to sleep while allowing events concerning this state +machine to happen. There is probably no reason to change the +default, which is accept-process-output with rearranged +arguments. + +\(fn NAME :start ((ARG ...) DOCSTRING BODY) [:sleep SLEEP-FUNCTION])" + (declare (debug (&define name :name start + &rest + &or [":start" + (lambda-list + [&optional ("interactive" interactive)] + stringp def-body)] + [":sleep" function-form]))) + (let ((start-name (intern (format "start-%s" name))) + interactive-spec) + (cl-destructuring-bind (arglist docstring &body body) start + (when (and (consp (car body)) (eq 'interactive (caar body))) + (setq interactive-spec (list (pop body)))) + (unless (stringp docstring) + (error "Docstring is not a string")) + `(progn + (put ',name :fsm-enter (make-hash-table :size 11 :test 'eq)) + (put ',name :fsm-event (make-hash-table :size 11 :test 'eq)) + (defun ,start-name ,arglist + ,docstring + ,@interactive-spec + (fsm-debug-output "Starting %s" ',name) + (let ((fsm (cl-gensym (concat "fsm-" ,(symbol-name name) "-")))) + (cl-destructuring-bind (state state-data &optional timeout) + (progn ,@body) + (put fsm :name ',name) + (put fsm :state nil) + (put fsm :state-data nil) + (put fsm :sleep ,(or sleep '(lambda (secs) + (accept-process-output + nil secs)))) + + (put fsm :deferred nil) + (fsm-update fsm state state-data timeout) + fsm))))))) + +(cl-defmacro define-state (fsm-name state-name arglist &body body) + "Define a state called STATE-NAME in the state machine FSM-NAME. +ARGLIST and BODY make a function that gets called when the state +machine receives an event in this state. The arguments are: + +FSM the state machine instance (treat it as opaque) +STATE-DATA An object +EVENT The occurred event, an object. +CALLBACK A function of one argument that expects the response + to this event, if any (often `ignore' is used) + +If the event should return a response, the state machine should +arrange to call CALLBACK at some point in the future (not necessarily +in this handler). + +The function should return a list of the form (NEW-STATE +NEW-STATE-DATA TIMEOUT): + +NEW-STATE The next state, a symbol +NEW-STATE-DATA An object +TIMEOUT A number: send timeout event after this many seconds + nil: cancel existing timer + :keep: let existing timer continue + +Alternatively, the function may return the keyword :defer, in +which case the event will be resent when the state machine enters +another state." + (declare (debug (&define name name :name handler lambda-list def-body))) + `(setf (gethash ',state-name (get ',fsm-name :fsm-event)) + (lambda ,arglist ,@body))) + +(cl-defmacro define-enter-state (fsm-name state-name arglist &body body) + "Define a function to call when FSM-NAME enters the state STATE-NAME. +ARGLIST and BODY make a function that gets called when the state +machine enters this state. The arguments are: + +FSM the state machine instance (treat it as opaque) +STATE-DATA An object + +The function should return a list of the form (NEW-STATE-DATA +TIMEOUT): + +NEW-STATE-DATA An object +TIMEOUT A number: send timeout event after this many seconds + nil: cancel existing timer + :keep: let existing timer continue" + (declare (debug (&define name name :name enter lambda-list def-body))) + `(setf (gethash ',state-name (get ',fsm-name :fsm-enter)) + (lambda ,arglist ,@body))) + +(cl-defmacro define-fsm (name &key + start sleep states + (fsm-name 'fsm) + (state-data-name 'state-data) + (callback-name 'callback) + (event-name 'event)) + "Define a state machine class called NAME, along with its STATES. +This macro is (further) syntatic sugar for `define-state-machine', +`define-state' and `define-enter-state' macros, q.v. + +NAME is a symbol. Everything else is specified with a keyword arg. + +START and SLEEP are the same as for `define-state-machine'. + +STATES is a list, each element having the form (STATE-NAME . STATE-SPEC). +STATE-NAME is a symbol. STATE-SPEC is an alist with keys `:event' or +`:enter', and values a series of expressions representing the BODY of +a `define-state' or `define-enter-state' call, respectively. + +FSM-NAME, STATE-DATA-NAME, CALLBACK-NAME, and EVENT-NAME are symbols, +used to construct the state functions' arglists." + `(progn + (define-state-machine ,name :start ,start :sleep ,sleep) + ,@(cl-loop for (state-name . spec) in states + if (assq :enter spec) collect + `(define-enter-state ,name ,state-name + (,fsm-name ,state-data-name) + ,@(cdr it)) + end + if (assq :event spec) collect + `(define-state ,name ,state-name + (,fsm-name ,state-data-name + ,event-name + ,callback-name) + ,@(cdr it)) + end))) + +(defun fsm-goodbye-cruel-world (name) + "Unbind functions related to fsm NAME (a symbol). +Includes start-NAME, and each fsm-NAME-STATE and fsm-NAME-enter-STATE. +Functions are `fmakunbound', which will probably give (fatal) pause to +any state machines using them. Return nil." + (interactive "SUnbind function definitions for fsm named: ") + (fmakunbound (intern (format "start-%s" name))) + (let (ht) + (when (hash-table-p (setq ht (get name :fsm-event))) + (clrhash ht) + (cl-remprop name :fsm-event)) + (when (hash-table-p (setq ht (get name :fsm-enter))) + (clrhash ht) + (cl-remprop name :fsm-enter))) + nil) + +(defun fsm-start-timer (fsm secs) + "Send a timeout event to FSM after SECS seconds. +The timer is canceled if another event occurs before, unless the +event handler explicitly asks to keep the timer." + (fsm-stop-timer fsm) + (put fsm + :timeout (run-with-timer + secs nil + #'fsm-send-sync fsm :timeout))) + +(defun fsm-stop-timer (fsm) + "Stop the timeout timer of FSM." + (let ((timer (get fsm :timeout))) + (when (timerp timer) + (cancel-timer timer) + (put fsm :timeout nil)))) + +(defun fsm-maybe-change-timer (fsm timeout) + "Change the timer of FSM according to TIMEOUT." + (cond + ((numberp timeout) + (fsm-start-timer fsm timeout)) + ((null timeout) + (fsm-stop-timer fsm)) + ;; :keep needs no timer change + )) + +(defun fsm-send (fsm event &optional callback) + "Send EVENT to FSM asynchronously. +If the state machine generates a response, eventually call +CALLBACK with the response as only argument." + (run-with-timer 0 nil #'fsm-send-sync fsm event callback)) + +(defun fsm-update (fsm new-state new-state-data timeout) + "Update FSM with NEW-STATE, NEW-STATE-DATA and TIMEOUT." + (let ((fsm-name (get fsm :name)) + (old-state (get fsm :state))) + (put fsm :state new-state) + (put fsm :state-data new-state-data) + (fsm-maybe-change-timer fsm timeout) + + ;; On state change, call enter function and send deferred events + ;; again. + (unless (eq old-state new-state) + (fsm-debug-output "%s enters %s" fsm-name new-state) + (let ((enter-fn (gethash new-state (get fsm-name :fsm-enter)))) + (when (functionp enter-fn) + (fsm-debug-output "Found enter function for %s/%s" fsm-name new-state) + (condition-case e + (cl-destructuring-bind (newer-state-data newer-timeout) + (funcall enter-fn fsm new-state-data) + (put fsm :state-data newer-state-data) + (fsm-maybe-change-timer fsm newer-timeout)) + ((debug error) + (fsm-debug-output "%s/%s update didn't work: %S" + fsm-name new-state e))))) + + (let ((deferred (nreverse (get fsm :deferred)))) + (put fsm :deferred nil) + (dolist (event deferred) + (apply 'fsm-send-sync fsm event)))))) + +(defun fsm-send-sync (fsm event &optional callback) + "Send EVENT to FSM synchronously. +If the state machine generates a response, eventually call +CALLBACK with the response as only argument." + (save-match-data + (let* ((fsm-name (get fsm :name)) + (state (get fsm :state)) + (state-data (get fsm :state-data)) + (state-fn (gethash state (get fsm-name :fsm-event)))) + ;; If the event is a list, output only the car, to avoid an + ;; overflowing debug buffer. + (fsm-debug-output "Sent %S to %s in state %s" + (or (car-safe event) event) fsm-name state) + (let ((result (condition-case e + (funcall state-fn fsm state-data event + (or callback 'ignore)) + ((debug error) (cons :error-signaled e))))) + ;; Special case for deferring an event until next state change. + (cond + ((eq result :defer) + (let ((deferred (get fsm :deferred))) + (put fsm :deferred (cons (list event callback) deferred)))) + ((null result) + (fsm-debug-output "Warning: event %S ignored in state %s/%s" + event fsm-name state)) + ((eq (car-safe result) :error-signaled) + (fsm-debug-output "Error in %s/%s: %s" + fsm-name state + (error-message-string (cdr result)))) + ((and (listp result) + (<= 2 (length result)) + (<= (length result) 3)) + (cl-destructuring-bind (new-state new-state-data &optional timeout) + result + (fsm-update fsm new-state new-state-data timeout))) + (t + (fsm-debug-output "Incorrect return value in %s/%s: %S" + fsm-name state + result))))))) + +(defun fsm-call (fsm event) + "Send EVENT to FSM synchronously, and wait for a reply. +Return the reply. `with-timeout' might be useful." + (let (reply) + (fsm-send-sync fsm event (lambda (r) (setq reply (list r)))) + (while (null reply) + (fsm-sleep fsm 1)) + (car reply))) + +(defun fsm-make-filter (fsm) + "Return a filter function that sends events to FSM. +Events sent are of the form (:filter PROCESS STRING)." + (let ((fsm fsm)) + (lambda (process string) + (fsm-send-sync fsm (list :filter process string))))) + +(defun fsm-make-sentinel (fsm) + "Return a sentinel function that sends events to FSM. +Events sent are of the form (:sentinel PROCESS STRING)." + (let ((fsm fsm)) + (lambda (process string) + (fsm-send-sync fsm (list :sentinel process string))))) + +(defun fsm-sleep (fsm secs) + "Sleep up to SECS seconds in a way that lets FSM receive events." + (funcall (get fsm :sleep) secs)) + +(defun fsm-get-state-data (fsm) + "Return the state data of FSM. +Note the absence of a set function. The fsm should manage its +state data itself; other code should just send messages to it." + (get fsm :state-data)) + +;;;; ChangeLog: + +;; 2016-07-10 Thomas Fitzsimmons +;; +;; packages/fsm: Bump version to 0.2.1 +;; +;; 2016-07-10 Thomas Fitzsimmons +;; +;; packages/fsm: Fix compilation error +;; +;; * packages/fsm/fsm.el (define-state-machine): Quote default :sleep +;; lambda (bug#23920). +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Revert some changes suggested by checkdoc +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Bump version to 0.2 +;; +;; 2015-09-05 Magnus Henoch +;; +;; fsm: Change FSMs from plists to uninterned symbols +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Fix copyright +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Add packaging fields +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Fix checkdoc errors +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Add FSM name to some fsm-debug-output messages +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Port to cl-lib +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Use lexical binding +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Fix formatting +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Delete trailing whitespace +;; +;; 2015-09-05 Thomas Fitzsimmons +;; +;; fsm: Import fsm.el from emacs-jabber +;; +;; Import fsm.el from git://git.code.sf.net/p/emacs-jabber/git, commit +;; 1f858cc4f3cdabcd7380a7d08af273bcdd708c15. +;; + + +(provide 'fsm) + +;;; fsm.el ends here diff --git a/.local/elpa/nadvice-0.3/nadvice-autoloads.el b/.local/elpa/nadvice-0.3/nadvice-autoloads.el new file mode 100644 index 00000000..a9b62dba --- /dev/null +++ b/.local/elpa/nadvice-0.3/nadvice-autoloads.el @@ -0,0 +1,15 @@ +;;; nadvice-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; nadvice-autoloads.el ends here diff --git a/.local/elpa/nadvice-0.3/nadvice-pkg.el b/.local/elpa/nadvice-0.3/nadvice-pkg.el new file mode 100644 index 00000000..c3628a42 --- /dev/null +++ b/.local/elpa/nadvice-0.3/nadvice-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "nadvice" "0.3" "Forward compatibility for Emacs-24.4's nadvice" 'nil :url "http://elpa.gnu.org/packages/nadvice.html" :keywords nil) diff --git a/.local/elpa/nadvice-0.3/nadvice.el b/.local/elpa/nadvice-0.3/nadvice.el new file mode 100644 index 00000000..7c4ba046 --- /dev/null +++ b/.local/elpa/nadvice-0.3/nadvice.el @@ -0,0 +1,124 @@ +;;; nadvice.el --- Forward compatibility for Emacs-24.4's nadvice + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Version: 0.3 +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This package tries to re-implement some of nadvice.el's functionality +;; on top of the old defadvice system, to help users of defadvice +;; move to the new advice system without dropping support for Emacs<24.4. +;; +;; Limitations; +;; - only supports `advice-add' and `advice-remove'; +;; - only handles the :before, :after, :override, and :around kinds of advice; +;; - requires a named rather than anonymous function; +;; - and does not support any additional properties like `name' or `depth'. +;; +;; It was tested on Emacs-22 and I can't see any obvious reason why it +;; wouldn't work on older Emacsen. + +;;; Code: + +(declare-function ad-remove-advice "advice") + +(unless (fboundp 'add-function) + ;; If `add-function' is defined, we're presumably running on + ;; an Emacs that comes with the real nadvice.el, so let's be careful + ;; to do nothing in that case! + + ;; Load `advice' manually, in case `advice-remove' is called first, + ;; since ad-remove-advice is not autoloaded. + (require 'advice) + +;;;###autoload +(defun advice-add (symbol where function &optional props) + (when props + (error "This version of nadvice.el does not support PROPS")) + (unless (symbolp function) + (error "This version of nadvice.el requires FUNCTION to be a symbol")) + (let ((body (cond + ((eq where :before) + `(progn (apply #',function (ad-get-args 0)) ad-do-it)) + ((eq where :after) + `(progn ad-do-it (apply #',function (ad-get-args 0)))) + ((eq where :override) + `(setq ad-return-value (apply #',function (ad-get-args 0)))) + ((eq where :around) + `(setq ad-return-value + (apply #',function + (lambda (&rest nadvice--rest-arg) + (ad-set-args 0 nadvice--rest-arg) + ad-do-it) + (ad-get-args 0)))) + (t (error "This version of nadvice.el does not handle %S" + where))))) + (ad-add-advice symbol + `(,function nil t (advice lambda () ,body)) + 'around + nil) + (ad-activate symbol))) + +;;;###autoload +(defun advice-remove (symbol function) + ;; Just return nil if there is no advice, rather than signaling an + ;; error. + (condition-case nil + (ad-remove-advice symbol 'around function) + (error nil)) + (condition-case nil + (ad-activate symbol) + (error nil))) + +) + +;;;; ChangeLog: + +;; 2018-09-15 Thomas Fitzsimmons +;; +;; packages/nadvice: Fix advice-remove behaviour +;; +;; * packages/nadvice/nadvice.el: Bump version to 0.3. +;; (advice-remove): Do not signal an error if the function already has no +;; advice. +;; +;; 2018-09-12 Stefan Monnier +;; +;; * nadvice.el: ad-remove-advice is not autoloaded +;; +;; 2018-09-12 Stefan Monnier +;; +;; * nadvice.el: Fix typo +;; +;; 2018-09-12 Stefan Monnier +;; +;; * nadvice/nadvice.el (advice-add): Add support for :override +;; +;; 2018-09-12 Stefan Monnier +;; +;; * nadvice.el: Fix copyright! +;; +;; 2018-09-12 Stefan Monnier +;; +;; * nadvice: New forward compatibility package +;; + + +(provide 'nadvice) +;;; nadvice.el ends here diff --git a/.local/elpa/soap-client-3.1.5/soap-client-autoloads.el b/.local/elpa/soap-client-3.1.5/soap-client-autoloads.el new file mode 100644 index 00000000..a7b21d65 --- /dev/null +++ b/.local/elpa/soap-client-3.1.5/soap-client-autoloads.el @@ -0,0 +1,15 @@ +;;; soap-client-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; soap-client-autoloads.el ends here diff --git a/.local/elpa/soap-client-3.1.5/soap-client-pkg.el b/.local/elpa/soap-client-3.1.5/soap-client-pkg.el new file mode 100644 index 00000000..80602f92 --- /dev/null +++ b/.local/elpa/soap-client-3.1.5/soap-client-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from soap-client.el +(define-package "soap-client" "3.1.5" "Access SOAP web services" '((cl-lib "0.6.1")) :url "http://elpa.gnu.org/packages/soap-client.html" :keywords '("soap" "web-services" "comm" "hypermedia")) diff --git a/.local/elpa/soap-client-3.1.5/soap-client.el b/.local/elpa/soap-client-3.1.5/soap-client.el new file mode 100644 index 00000000..7c409665 --- /dev/null +++ b/.local/elpa/soap-client-3.1.5/soap-client.el @@ -0,0 +1,3166 @@ +;;; soap-client.el --- Access SOAP web services -*- lexical-binding: t -*- + +;; Copyright (C) 2009-2018 Free Software Foundation, Inc. + +;; Author: Alexandru Harsanyi +;; Author: Thomas Fitzsimmons +;; Created: December, 2009 +;; Version: 3.1.5 +;; Keywords: soap, web-services, comm, hypermedia +;; Package: soap-client +;; Homepage: https://github.com/alex-hhh/emacs-soap-client +;; Package-Requires: ((cl-lib "0.6.1")) + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; To use the SOAP client, you first need to load the WSDL document for the +;; service you want to access, using `soap-load-wsdl-from-url'. A WSDL +;; document describes the available operations of the SOAP service, how their +;; parameters and responses are encoded. To invoke operations, you use the +;; `soap-invoke' method passing it the WSDL, the service name, the operation +;; you wish to invoke and any required parameters. +;; +;; Ideally, the service you want to access will have some documentation about +;; the operations it supports. If it does not, you can try using +;; `soap-inspect' to browse the WSDL document and see the available operations +;; and their parameters. +;; + +;;; Code: + +(require 'cl-lib) + +(require 'xml) +(require 'xsd-regexp) +(require 'rng-xsd) +(require 'rng-dt) +(require 'warnings) +(require 'url) +(require 'url-http) +(require 'url-util) +(require 'url-vars) +(require 'mm-decode) + +(defsubst soap-warning (message &rest args) + "Display a warning MESSAGE with ARGS, using the `soap-client' warning type." + ;; Do not use #'format-message, to support older Emacs versions. + (display-warning 'soap-client (apply #'format message args) :warning)) + +(defgroup soap-client nil + "Access SOAP web services from Emacs." + :version "24.1" + :group 'tools) + +;;;; Support for parsing XML documents with namespaces + +;; XML documents with namespaces are difficult to parse because the names of +;; the nodes depend on what "xmlns" aliases have been defined in the document. +;; To work with such documents, we introduce a translation layer between a +;; "well known" namespace tag and the local namespace tag in the document +;; being parsed. + +(defconst soap-well-known-xmlns + '(("apachesoap" . "http://xml.apache.org/xml-soap") + ("soapenc" . "http://schemas.xmlsoap.org/soap/encoding/") + ("wsdl" . "http://schemas.xmlsoap.org/wsdl/") + ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") + ("xsd" . "http://www.w3.org/2001/XMLSchema") + ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") + ("wsa" . "http://www.w3.org/2005/08/addressing") + ("wsaw" . "http://www.w3.org/2006/05/addressing/wsdl") + ("soap" . "http://schemas.xmlsoap.org/soap/envelope/") + ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/") + ("http" . "http://schemas.xmlsoap.org/wsdl/http/") + ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/") + ("xml" . "http://www.w3.org/XML/1998/namespace")) + "A list of well known xml namespaces and their aliases.") + +(defvar soap-local-xmlns + '(("xml" . "http://www.w3.org/XML/1998/namespace")) + "A list of local namespace aliases. +This is a dynamically bound variable, controlled by +`soap-with-local-xmlns'.") + +(defvar soap-default-xmlns nil + "The default XML namespaces. +Names in this namespace will be unqualified. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defvar soap-target-xmlns nil + "The target XML namespace. +New XSD elements will be defined in this namespace, unless they +are fully qualified for a different namespace. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defvar soap-current-wsdl nil + "The current WSDL document used when decoding the SOAP response. +This is a dynamically bound variable.") + +(defun soap-wk2l (well-known-name) + "Return local variant of WELL-KNOWN-NAME. +This is done by looking up the namespace in the +`soap-well-known-xmlns' table and resolving the namespace to +the local name based on the current local translation table +`soap-local-xmlns'. See also `soap-with-local-xmlns'." + (let ((wk-name-1 (if (symbolp well-known-name) + (symbol-name well-known-name) + well-known-name))) + (cond + ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) + (let ((ns (match-string 1 wk-name-1)) + (name (match-string 2 wk-name-1))) + (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) + (cond ((equal namespace soap-default-xmlns) + ;; Name is unqualified in the default namespace + (if (symbolp well-known-name) + (intern name) + name)) + (t + (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) + (local-name (concat local-ns ":" name))) + (if (symbolp well-known-name) + (intern local-name) + local-name))))))) + (t well-known-name)))) + +(defun soap-l2wk (local-name) + "Convert LOCAL-NAME into a well known name. +The namespace of LOCAL-NAME is looked up in the +`soap-well-known-xmlns' table and a well known namespace tag is +used in the name. + +nil is returned if there is no well-known namespace for the +namespace of LOCAL-NAME." + (let ((l-name-1 (if (symbolp local-name) + (symbol-name local-name) + local-name)) + namespace name) + (cond + ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) + (setq name (match-string 2 l-name-1)) + (let ((ns (match-string 1 l-name-1))) + (setq namespace (cdr (assoc ns soap-local-xmlns))) + (unless namespace + (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) + (t + (setq name l-name-1) + (setq namespace soap-default-xmlns))) + + (if namespace + (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns)))) + (if well-known-ns + (let ((well-known-name (concat well-known-ns ":" name))) + (if (symbolp local-name) + (intern well-known-name) + well-known-name)) + nil)) + ;; if no namespace is defined, just return the unqualified name + name))) + + +(defun soap-l2fq (local-name &optional use-tns) + "Convert LOCAL-NAME into a fully qualified name. +A fully qualified name is a cons of the namespace name and the +name of the element itself. For example \"xsd:string\" is +converted to (\"http://www.w3.org/2001/XMLSchema\" . \"string\"). + +The USE-TNS argument specifies what to do when LOCAL-NAME has no +namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns' +will be used as the element's namespace, otherwise +`soap-default-xmlns' will be used. + +This is needed because different parts of a WSDL document can use +different namespace aliases for the same element." + (let ((local-name-1 (if (symbolp local-name) + (symbol-name local-name) + local-name))) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1) + (let ((ns (match-string 1 local-name-1)) + (name (match-string 2 local-name-1))) + (let ((namespace (cdr (assoc ns soap-local-xmlns)))) + (if namespace + (cons namespace name) + (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) + (t + (cons (if use-tns + soap-target-xmlns + soap-default-xmlns) + local-name-1))))) + +(defun soap-name-p (name) + "Return t if NAME is a valid name for XMLSchema types. +A valid name is either a string or a cons of (NAMESPACE . NAME)." + (or (stringp name) + (and (consp name) + (stringp (car name)) + (stringp (cdr name))))) + +(defun soap-extract-xmlns (node &optional xmlns-table) + "Return a namespace alias table for NODE by extending XMLNS-TABLE." + (let (xmlns default-ns target-ns) + (dolist (a (xml-node-attributes node)) + (let ((name (symbol-name (car a))) + (value (cdr a))) + (cond ((string= name "targetNamespace") + (setq target-ns value)) + ((string= name "xmlns") + (setq default-ns value)) + ((string-match "^xmlns:\\(.*\\)$" name) + (push (cons (match-string 1 name) value) xmlns))))) + + (let ((tns (assoc "tns" xmlns))) + (cond ((and tns target-ns) + ;; If a tns alias is defined for this node, it must match + ;; the target namespace. + (unless (equal target-ns (cdr tns)) + (soap-warning + "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch" + (xml-node-name node)))) + ((and tns (not target-ns)) + (setq target-ns (cdr tns))))) + + (list default-ns target-ns (append xmlns xmlns-table)))) + +(defmacro soap-with-local-xmlns (node &rest body) + "Install a local alias table from NODE and execute BODY." + (declare (debug (form &rest form)) (indent 1)) + (let ((xmlns (make-symbol "xmlns"))) + `(let ((,xmlns (soap-extract-xmlns ,node soap-local-xmlns))) + (let ((soap-default-xmlns (or (nth 0 ,xmlns) soap-default-xmlns)) + (soap-target-xmlns (or (nth 1 ,xmlns) soap-target-xmlns)) + (soap-local-xmlns (nth 2 ,xmlns))) + ,@body)))) + +(defun soap-get-target-namespace (node) + "Return the target namespace of NODE. +This is the namespace in which new elements will be defined." + (or (xml-get-attribute-or-nil node 'targetNamespace) + (cdr (assoc "tns" soap-local-xmlns)) + soap-target-xmlns)) + +(defun soap-xml-get-children1 (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children', but CHILD-NAME can have +namespace tag." + (let (result) + (dolist (c (xml-node-children node)) + (when (and (consp c) + (soap-with-local-xmlns c + ;; We use `ignore-errors' here because we want to silently + ;; skip nodes when we cannot convert them to a well-known + ;; name. + (eq (ignore-errors (soap-l2wk (xml-node-name c))) + child-name))) + (push c result))) + (nreverse result))) + +(defun soap-xml-node-find-matching-child (node set) + "Return the first child of NODE whose name is a member of SET." + (catch 'found + (dolist (child (xml-node-children node)) + (when (and (consp child) + (memq (soap-l2wk (xml-node-name child)) set)) + (throw 'found child))))) + +(defun soap-xml-get-attribute-or-nil1 (node attribute) + "Return the NODE's ATTRIBUTE, or nil if it does not exist. +This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can +be tagged with a namespace tag." + (catch 'found + (soap-with-local-xmlns node + (dolist (a (xml-node-attributes node)) + ;; We use `ignore-errors' here because we want to silently skip + ;; attributes for which we cannot convert them to a well-known name. + (when (eq (ignore-errors (soap-l2wk (car a))) attribute) + (throw 'found (cdr a))))))) + + +;;;; XML namespaces + +;; An element in an XML namespace, "things" stored in soap-xml-namespaces will +;; be derived from this object. + +(cl-defstruct soap-element + name + ;; The "well-known" namespace tag for the element. For example, while + ;; parsing XML documents, we can have different tags for the XMLSchema + ;; namespace, but internally all our XMLSchema elements will have the "xsd" + ;; tag. + namespace-tag) + +(defun soap-element-fq-name (element) + "Return a fully qualified name for ELEMENT. +A fq name is the concatenation of the namespace tag and the +element name." + (cond ((soap-element-namespace-tag element) + (concat (soap-element-namespace-tag element) + ":" (soap-element-name element))) + ((soap-element-name element) + (soap-element-name element)) + (t + "*unnamed*"))) + +;; a namespace link stores an alias for an object in once namespace to a +;; "target" object possibly in a different namespace + +(cl-defstruct (soap-namespace-link (:include soap-element)) + target) + +;; A namespace is a collection of soap-element objects under a name (the name +;; of the namespace). + +(cl-defstruct soap-namespace + (name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap" + (elements (make-hash-table :test 'equal) :read-only t)) + +(defun soap-namespace-put (element ns) + "Store ELEMENT in NS. +Multiple elements with the same name can be stored in a +namespace. When retrieving the element you can specify a +discriminant predicate to `soap-namespace-get'" + (let ((name (soap-element-name element))) + (push element (gethash name (soap-namespace-elements ns))))) + +(defun soap-namespace-put-link (name target ns) + "Store a link from NAME to TARGET in NS. +TARGET can be either a SOAP-ELEMENT or a string denoting an +element name into another namespace. + +If NAME is nil, an element with the same name as TARGET will be +added to the namespace." + + (unless (and name (not (equal name ""))) + ;; if name is nil, use TARGET as a name... + (cond ((soap-element-p target) + (setq name (soap-element-name target))) + ((consp target) ; a fq name: (namespace . name) + (setq name (cdr target))) + ((stringp target) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" target) + (setq name (match-string 2 target))) + (t + (setq name target)))))) + + ;; by now, name should be valid + (cl-assert (and name (not (equal name ""))) + nil + "Cannot determine name for namespace link") + (push (make-soap-namespace-link :name name :target target) + (gethash name (soap-namespace-elements ns)))) + +(defun soap-namespace-get (name ns &optional discriminant-predicate) + "Retrieve an element with NAME from the namespace NS. +If multiple elements with the same name exist, +DISCRIMINANT-PREDICATE is used to pick one of them. This allows +storing elements of different types (like a message type and a +binding) but the same name." + (cl-assert (stringp name)) + (let ((elements (gethash name (soap-namespace-elements ns)))) + (cond (discriminant-predicate + (catch 'found + (dolist (e elements) + (when (funcall discriminant-predicate e) + (throw 'found e))))) + ((= (length elements) 1) (car elements)) + ((> (length elements) 1) + (error + "Soap-namespace-get(%s): multiple elements, discriminant needed" + name)) + (t + nil)))) + + +;;;; XML Schema + +;; SOAP WSDL documents use XML Schema to define the types that are part of the +;; message exchange. We include here an XML schema model with a parser and +;; serializer/deserializer. + +(cl-defstruct (soap-xs-type (:include soap-element)) + id + attributes + attribute-groups) + +;;;;; soap-xs-basic-type + +(cl-defstruct (soap-xs-basic-type (:include soap-xs-type)) + ;; Basic types are "built in" and we know how to handle them directly. + ;; Other type definitions reference basic types, so we need to create them + ;; in a namespace (see `soap-make-xs-basic-types') + + ;; a symbol of: string, dateTime, long, int, etc + kind + ) + +(defun soap-make-xs-basic-types (namespace-name &optional namespace-tag) + "Construct NAMESPACE-NAME containing the XMLSchema basic types. +An optional NAMESPACE-TAG can also be specified." + (let ((ns (make-soap-namespace :name namespace-name))) + (dolist (type '("string" "language" "ID" "IDREF" + "dateTime" "time" "date" "boolean" + "gYearMonth" "gYear" "gMonthDay" "gDay" "gMonth" + "long" "short" "int" "integer" "nonNegativeInteger" + "unsignedLong" "unsignedShort" "unsignedInt" + "decimal" "duration" + "byte" "unsignedByte" + "float" "double" + "base64Binary" "anyType" "anyURI" "QName" "Array" "byte[]")) + (soap-namespace-put + (make-soap-xs-basic-type :name type + :namespace-tag namespace-tag + :kind (intern type)) + ns)) + ns)) + +(defun soap-encode-xs-basic-type-attributes (value type) + "Encode the XML attributes for VALUE according to TYPE. +The xsi:type and an optional xsi:nil attributes are added. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-basic-type' objects." + (let ((xsi-type (soap-element-fq-name type)) + (basic-type (soap-xs-basic-type-kind type))) + ;; try to classify the type based on the value type and use that type when + ;; encoding + (when (eq basic-type 'anyType) + (cond ((stringp value) + (setq xsi-type "xsd:string" basic-type 'string)) + ((integerp value) + (setq xsi-type "xsd:int" basic-type 'int)) + ((memq value '(t nil)) + (setq xsi-type "xsd:boolean" basic-type 'boolean)) + (t + (error "Cannot classify anyType value")))) + + (insert " xsi:type=\"" xsi-type "\"") + ;; We have some ambiguity here, as a nil value represents "false" when the + ;; type is boolean, we will never have a "nil" boolean type... + (unless (or value (eq basic-type 'boolean)) + (insert " xsi:nil=\"true\"")))) + +(defun soap-encode-xs-basic-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-basic-type' objects." + (let ((kind (soap-xs-basic-type-kind type))) + + (when (eq kind 'anyType) + (cond ((stringp value) + (setq kind 'string)) + ((integerp value) + (setq kind 'int)) + ((memq value '(t nil)) + (setq kind 'boolean)) + (t + (error "Cannot classify anyType value")))) + + ;; NOTE: a nil value is not encoded, as an xsi:nil="true" attribute was + ;; encoded for it. However, we have some ambiguity here, as a nil value + ;; also represents "false" when the type is boolean... + + (when (or value (eq kind 'boolean)) + (let ((value-string + (cl-case kind + ((string anyURI QName ID IDREF language) + (unless (stringp value) + (error "Not a string value: %s" value)) + (url-insert-entities-in-string value)) + ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth) + (cond ((consp value) + ;; Value is a (current-time) style value, + ;; convert to the ISO 8601-inspired XSD + ;; string format in UTC. + (format-time-string + (concat + (cl-ecase kind + (dateTime "%Y-%m-%dT%H:%M:%S") + (time "%H:%M:%S") + (date "%Y-%m-%d") + (gYearMonth "%Y-%m") + (gYear "%Y") + (gMonthDay "--%m-%d") + (gDay "---%d") + (gMonth "--%m")) + ;; Internal time is always in UTC. + "Z") + value t)) + ((stringp value) + ;; Value is a string in the ISO 8601-inspired XSD + ;; format. Validate it. + (soap-decode-date-time value kind) + (url-insert-entities-in-string value)) + (t + (error "Invalid date-time format")))) + (boolean + (unless (memq value '(t nil)) + (error "Not a boolean value")) + (if value "true" "false")) + + ((long short int integer byte unsignedInt unsignedLong + unsignedShort nonNegativeInteger decimal duration) + (unless (integerp value) + (error "Not an integer value")) + (when (and (memq kind '(unsignedInt unsignedLong + unsignedShort + nonNegativeInteger)) + (< value 0)) + (error "Not a positive integer")) + (number-to-string value)) + + ((float double) + (unless (numberp value) + (error "Not a number")) + (number-to-string value)) + + (base64Binary + (unless (stringp value) + (error "Not a string value for base64Binary")) + (base64-encode-string value)) + + (otherwise + (error "Don't know how to encode %s for type %s" + value (soap-element-fq-name type)))))) + (soap-validate-xs-basic-type value-string type) + (insert value-string))))) + +;; Inspired by rng-xsd-convert-date-time. +(defun soap-decode-date-time (date-time-string datatype) + "Decode DATE-TIME-STRING as DATATYPE. +DATE-TIME-STRING should be in ISO 8601 basic or extended format. +DATATYPE is one of dateTime, time, date, gYearMonth, gYear, +gMonthDay, gDay or gMonth. + +Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR +SEC-FRACTION DATATYPE ZONE). This format is meant to be similar +to that returned by `decode-time' (and compatible with +`encode-time'). The differences are the DOW (day-of-week) field +is replaced with SEC-FRACTION, a float representing the +fractional seconds, and the DST (daylight savings time) field is +replaced with DATATYPE, a symbol representing the XSD primitive +datatype. This symbol can be used to determine which fields +apply and which don't when it's not already clear from context. +For example a datatype of `time' means the year, month and day +fields should be ignored. + +This function will throw an error if DATE-TIME-STRING represents +a leap second, since the XML Schema 1.1 standard explicitly +disallows them." + (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert))) + (year-sign (progn + (string-match datetime-regexp date-time-string) + (match-string 1 date-time-string))) + (year (match-string 2 date-time-string)) + (month (match-string 3 date-time-string)) + (day (match-string 4 date-time-string)) + (hour (match-string 5 date-time-string)) + (minute (match-string 6 date-time-string)) + (second (match-string 7 date-time-string)) + (second-fraction (match-string 8 date-time-string)) + (has-time-zone (match-string 9 date-time-string)) + (time-zone-sign (match-string 10 date-time-string)) + (time-zone-hour (match-string 11 date-time-string)) + (time-zone-minute (match-string 12 date-time-string))) + (setq year-sign (if year-sign -1 1)) + (setq year + (if year + (* year-sign + (string-to-number year)) + ;; By defaulting to the epoch date, a time value can be treated as + ;; a relative number of seconds. + 1970)) + (setq month + (if month (string-to-number month) 1)) + (setq day + (if day (string-to-number day) 1)) + (setq hour + (if hour (string-to-number hour) 0)) + (setq minute + (if minute (string-to-number minute) 0)) + (setq second + (if second (string-to-number second) 0)) + (setq second-fraction + (if second-fraction + (float (string-to-number second-fraction)) + 0.0)) + (setq has-time-zone (and has-time-zone t)) + (setq time-zone-sign + (if (equal time-zone-sign "-") -1 1)) + (setq time-zone-hour + (if time-zone-hour (string-to-number time-zone-hour) 0)) + (setq time-zone-minute + (if time-zone-minute (string-to-number time-zone-minute) 0)) + (unless (and + ;; XSD does not allow year 0. + (> year 0) + (>= month 1) (<= month 12) + (>= day 1) (<= day (rng-xsd-days-in-month year month)) + (>= hour 0) (<= hour 23) + (>= minute 0) (<= minute 59) + ;; 60 represents a leap second, but leap seconds are explicitly + ;; disallowed by the XML Schema 1.1 specification. This agrees + ;; with typical Emacs installations, which don't count leap + ;; seconds in time values. + (>= second 0) (<= second 59) + (>= time-zone-hour 0) + (<= time-zone-hour 23) + (>= time-zone-minute 0) + (<= time-zone-minute 59)) + (error "Invalid or unsupported time: %s" date-time-string)) + ;; Return a value in a format similar to that returned by decode-time, and + ;; suitable for (apply 'encode-time ...). + (list second minute hour day month year second-fraction datatype + (if has-time-zone + (* (rng-xsd-time-to-seconds + time-zone-hour + time-zone-minute + 0) + time-zone-sign) + ;; UTC. + 0)))) + +(defun soap-decode-xs-basic-type (type node) + "Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (let ((contents (xml-node-children node)) + (kind (soap-xs-basic-type-kind type)) + (attributes (xml-node-attributes node)) + (validate-type type) + (is-nil nil)) + + (dolist (attribute attributes) + (let ((attribute-type (soap-l2fq (car attribute))) + (attribute-value (cdr attribute))) + ;; xsi:type can override an element's expected type. + (when (equal attribute-type (soap-l2fq "xsi:type")) + (setq validate-type + (soap-wsdl-get attribute-value soap-current-wsdl))) + ;; xsi:nil can specify that an element is nil in which case we don't + ;; validate it. + (when (equal attribute-type (soap-l2fq "xsi:nil")) + (setq is-nil (string= (downcase attribute-value) "true"))))) + + (unless is-nil + ;; For validation purposes, when xml-node-children returns nil, treat it + ;; as the empty string. + (soap-validate-xs-basic-type (car (or contents (list ""))) validate-type)) + + (if (null contents) + nil + (cl-ecase kind + ((string anyURI QName ID IDREF language) (car contents)) + ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth) + (car contents)) + ((long short int integer + unsignedInt unsignedLong unsignedShort nonNegativeInteger + decimal byte float double duration) + (string-to-number (car contents))) + (boolean (string= (downcase (car contents)) "true")) + (base64Binary (base64-decode-string (car contents))) + (anyType (soap-decode-any-type node)) + (Array (soap-decode-array node)))))) + +(defalias 'soap-type-of + (if (eq 'soap-xs-basic-type (type-of (make-soap-xs-basic-type))) + ;; `type-of' in Emacs ≥ 26 already does what we need. + #'type-of + ;; For Emacs < 26, use our own function. + (lambda (element) + "Return the type of ELEMENT." + (if (vectorp element) + (aref element 0) ;Assume this vector is actually a struct! + ;; This should never happen. + (type-of element))))) + +;; Register methods for `soap-xs-basic-type' +(let ((tag (soap-type-of (make-soap-xs-basic-type)))) + (put tag 'soap-attribute-encoder #'soap-encode-xs-basic-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-basic-type) + (put tag 'soap-decoder #'soap-decode-xs-basic-type)) + +;;;;; soap-xs-element + +(cl-defstruct (soap-xs-element (:include soap-element)) + ;; NOTE: we don't support exact number of occurrences via minOccurs, + ;; maxOccurs. Instead we support optional? and multiple? + + id + type^ ; note: use soap-xs-element-type to retrieve this member + optional? + multiple? + reference + substitution-group + ;; contains a list of elements who point to this one via their + ;; substitution-group slot + alternatives + is-group) + +(defun soap-xs-element-type (element) + "Retrieve the type of ELEMENT. +This is normally stored in the TYPE^ slot, but if this element +contains a reference, retrieve the type of the reference." + (if (soap-xs-element-reference element) + (soap-xs-element-type (soap-xs-element-reference element)) + (soap-xs-element-type^ element))) + +(defun soap-node-optional (node) + "Return t if NODE specifies an optional element." + (or (equal (xml-get-attribute-or-nil node 'nillable) "true") + (let ((e (xml-get-attribute-or-nil node 'minOccurs))) + (and e (equal e "0"))))) + +(defun soap-node-multiple (node) + "Return t if NODE permits multiple elements." + (let* ((e (xml-get-attribute-or-nil node 'maxOccurs))) + (and e (not (equal e "1"))))) + +(defun soap-xs-parse-element (node) + "Construct a `soap-xs-element' from NODE." + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (type (xml-get-attribute-or-nil node 'type)) + (optional? (soap-node-optional node)) + (multiple? (soap-node-multiple node)) + (ref (xml-get-attribute-or-nil node 'ref)) + (substitution-group (xml-get-attribute-or-nil node 'substitutionGroup)) + (node-name (soap-l2wk (xml-node-name node)))) + (cl-assert (memq node-name '(xsd:element xsd:group)) + "expecting xsd:element or xsd:group, got %s" node-name) + + (when type + (setq type (soap-l2fq type 'tns))) + + (when ref + (setq ref (soap-l2fq ref 'tns))) + + (when substitution-group + (setq substitution-group (soap-l2fq substitution-group 'tns))) + + (unless (or ref type) + ;; no type specified and this is not a reference. Must be a type + ;; defined within this node. + (let ((simple-type (soap-xml-get-children1 node 'xsd:simpleType))) + (if simple-type + (setq type (soap-xs-parse-simple-type (car simple-type))) + ;; else + (let ((complex-type (soap-xml-get-children1 node 'xsd:complexType))) + (if complex-type + (setq type (soap-xs-parse-complex-type (car complex-type))) + ;; else + (error "Soap-xs-parse-element: missing type or ref")))))) + + (make-soap-xs-element :name name + ;; Use the full namespace name for now, we will + ;; convert it to a nstag in + ;; `soap-resolve-references-for-xs-element' + :namespace-tag soap-target-xmlns + :id id :type^ type + :optional? optional? :multiple? multiple? + :reference ref + :substitution-group substitution-group + :is-group (eq node-name 'xsd:group)))) + +(defun soap-resolve-references-for-xs-element (element wsdl) + "Replace names in ELEMENT with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-element' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag element))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag element) nstag))))) + + (let ((type (soap-xs-element-type^ element))) + (cond ((soap-name-p type) + (setf (soap-xs-element-type^ element) + (soap-wsdl-get type wsdl 'soap-xs-type-p))) + ((soap-xs-type-p type) + ;; an inline defined type, this will not be reached from anywhere + ;; else, so we must resolve references now. + (soap-resolve-references type wsdl)))) + (let ((reference (soap-xs-element-reference element))) + (when (and (soap-name-p reference) + ;; xsd:group reference nodes will be converted to inline types + ;; by soap-resolve-references-for-xs-complex-type, so skip them + ;; here. + (not (soap-xs-element-is-group element))) + (setf (soap-xs-element-reference element) + (soap-wsdl-get reference wsdl 'soap-xs-element-p)))) + + (let ((subst (soap-xs-element-substitution-group element))) + (when (soap-name-p subst) + (let ((target (soap-wsdl-get subst wsdl))) + (if target + (push element (soap-xs-element-alternatives target)) + (soap-warning "No target found for substitution-group" subst)))))) + +(defun soap-encode-xs-element-attributes (value element) + "Encode the XML attributes for VALUE according to ELEMENT. +Currently no attributes are needed. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-basic-type' objects." + ;; Use the variables to suppress checkdoc and compiler warnings. + (list value element) + nil) + +(defun soap-should-encode-value-for-xs-element (value element) + "Return t if VALUE should be encoded for ELEMENT, nil otherwise." + (cond + ;; if value is not nil, attempt to encode it + (value) + + ;; value is nil, but the element's type is a boolean, so nil in this case + ;; means "false". We need to encode it. + ((let ((type (soap-xs-element-type element))) + (and (soap-xs-basic-type-p type) + (eq (soap-xs-basic-type-kind type) 'boolean)))) + + ;; This is not an optional element. Force encoding it (although this + ;; might fail at the validation step, but this is what we intend. + + ;; value is nil, but the element's type has some attributes which supply a + ;; default value. We need to encode it. + + ((let ((type (soap-xs-element-type element))) + (catch 'found + (dolist (a (soap-xs-type-attributes type)) + (when (soap-xs-attribute-default a) + (throw 'found t)))))) + + ;; otherwise, we don't need to encode it + (t nil))) + +(defun soap-type-is-array? (type) + "Return t if TYPE defines an ARRAY." + (and (soap-xs-complex-type-p type) + (eq (soap-xs-complex-type-indicator type) 'array))) + +(defvar soap-encoded-namespaces nil + "A list of namespace tags used during encoding a message. +This list is populated by `soap-encode-value' and used by +`soap-create-envelope' to add aliases for these namespace to the +XML request. + +This variable is dynamically bound in `soap-create-envelope'.") + +(defun soap-encode-xs-element (value element) + "Encode the VALUE according to ELEMENT. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-basic-type' objects." + (let ((fq-name (soap-element-fq-name element)) + (type (soap-xs-element-type element))) + ;; Only encode the element if it has a name. NOTE: soap-element-fq-name + ;; will return *unnamed* for such elements + (if (soap-element-name element) + ;; Don't encode this element if value is nil. However, even if value + ;; is nil we still want to encode this element if it has any attributes + ;; with default values. + (when (soap-should-encode-value-for-xs-element value element) + (progn + (insert "<" fq-name) + (soap-encode-attributes value type) + ;; If value is nil and type is boolean encode the value as "false". + ;; Otherwise don't encode the value. + (if (or value (and (soap-xs-basic-type-p type) + (eq (soap-xs-basic-type-kind type) 'boolean))) + (progn (insert ">") + ;; ARRAY's need special treatment, as each element of + ;; the array is encoded with the same tag as the + ;; current element... + (if (soap-type-is-array? type) + (let ((new-element (copy-soap-xs-element element))) + (when (soap-element-namespace-tag type) + (add-to-list 'soap-encoded-namespaces + (soap-element-namespace-tag type))) + (setf (soap-xs-element-type^ new-element) + (soap-xs-complex-type-base type)) + (cl-loop for i below (length value) + do (soap-encode-xs-element + (aref value i) new-element))) + (soap-encode-value value type)) + (insert "\n")) + ;; else + (insert "/>\n")))) + (when (soap-should-encode-value-for-xs-element value element) + (soap-encode-value value type))))) + +(defun soap-decode-xs-element (element node) + "Use ELEMENT, a `soap-xs-element', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in ELEMENT. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (let ((type (soap-xs-element-type element))) + (soap-decode-type type node))) + +;; Register methods for `soap-xs-element' +(let ((tag (soap-type-of (make-soap-xs-element)))) + (put tag 'soap-resolve-references #'soap-resolve-references-for-xs-element) + (put tag 'soap-attribute-encoder #'soap-encode-xs-element-attributes) + (put tag 'soap-encoder #'soap-encode-xs-element) + (put tag 'soap-decoder #'soap-decode-xs-element)) + +;;;;; soap-xs-attribute + +(cl-defstruct (soap-xs-attribute (:include soap-element)) + type ; a simple type or basic type + default ; the default value, if any + reference) + +(cl-defstruct (soap-xs-attribute-group (:include soap-xs-type)) + reference) + +(defun soap-xs-parse-attribute (node) + "Construct a `soap-xs-attribute' from NODE." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'xsd:attribute) + "expecting xsd:attribute, got %s" (soap-l2wk (xml-node-name node))) + (let* ((name (xml-get-attribute-or-nil node 'name)) + (type (soap-l2fq (xml-get-attribute-or-nil node 'type))) + (default (xml-get-attribute-or-nil node 'fixed)) + (attribute (xml-get-attribute-or-nil node 'ref)) + (ref (when attribute (soap-l2fq attribute)))) + (unless (or type ref) + (setq type (soap-xs-parse-simple-type + (soap-xml-node-find-matching-child + node '(xsd:restriction xsd:list xsd:union))))) + (make-soap-xs-attribute + :name name :type type :default default :reference ref))) + +(defun soap-xs-parse-attribute-group (node) + "Construct a `soap-xs-attribute-group' from NODE." + (let ((node-name (soap-l2wk (xml-node-name node)))) + (cl-assert (eq node-name 'xsd:attributeGroup) + "expecting xsd:attributeGroup, got %s" node-name) + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (ref (xml-get-attribute-or-nil node 'ref)) + attribute-group) + (when (and name ref) + (soap-warning "name and ref set for attribute group %s" node-name)) + (setq attribute-group + (make-soap-xs-attribute-group :id id + :name name + :reference (and ref (soap-l2fq ref)))) + (when (not ref) + (dolist (child (xml-node-children node)) + ;; Ignore whitespace. + (unless (stringp child) + ;; Ignore optional annotation. + ;; Ignore anyAttribute nodes. + (cl-case (soap-l2wk (xml-node-name child)) + (xsd:attribute + (push (soap-xs-parse-attribute child) + (soap-xs-type-attributes attribute-group))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group child) + (soap-xs-attribute-group-attribute-groups + attribute-group))))))) + attribute-group))) + +(defun soap-resolve-references-for-xs-attribute (attribute wsdl) + "Replace names in ATTRIBUTE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-attribute' objects. + +See also `soap-wsdl-resolve-references'." + (let* ((type (soap-xs-attribute-type attribute)) + (reference (soap-xs-attribute-reference attribute)) + (predicate 'soap-xs-element-p) + (xml-reference + (and (soap-name-p reference) + (equal (car reference) "http://www.w3.org/XML/1998/namespace")))) + (cond (xml-reference + ;; Convert references to attributes defined by the XML + ;; schema (xml:base, xml:lang, xml:space and xml:id) to + ;; xsd:string, to avoid needing to bundle and parse + ;; xml.xsd. + (setq reference '("http://www.w3.org/2001/XMLSchema" . "string")) + (setq predicate 'soap-xs-basic-type-p)) + ((soap-name-p type) + (setf (soap-xs-attribute-type attribute) + (soap-wsdl-get type wsdl + (lambda (type) + (or (soap-xs-basic-type-p type) + (soap-xs-simple-type-p type)))))) + ((soap-xs-type-p type) + ;; an inline defined type, this will not be reached from anywhere + ;; else, so we must resolve references now. + (soap-resolve-references type wsdl))) + (when (soap-name-p reference) + (setf (soap-xs-attribute-reference attribute) + (soap-wsdl-get reference wsdl predicate))))) + +(put (soap-type-of (make-soap-xs-attribute)) + 'soap-resolve-references #'soap-resolve-references-for-xs-attribute) + +(defun soap-resolve-references-for-xs-attribute-group (attribute-group wsdl) + "Set slots in ATTRIBUTE-GROUP to the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-attribute-group' objects. + +See also `soap-wsdl-resolve-references'." + (let ((reference (soap-xs-attribute-group-reference attribute-group))) + (when (soap-name-p reference) + (let ((resolved (soap-wsdl-get reference wsdl + 'soap-xs-attribute-group-p))) + (dolist (attribute (soap-xs-attribute-group-attributes resolved)) + (soap-resolve-references attribute wsdl)) + (setf (soap-xs-attribute-group-name attribute-group) + (soap-xs-attribute-group-name resolved)) + (setf (soap-xs-attribute-group-id attribute-group) + (soap-xs-attribute-group-id resolved)) + (setf (soap-xs-attribute-group-reference attribute-group) nil) + (setf (soap-xs-attribute-group-attributes attribute-group) + (soap-xs-attribute-group-attributes resolved)) + (setf (soap-xs-attribute-group-attribute-groups attribute-group) + (soap-xs-attribute-group-attribute-groups resolved)))))) + +(put (soap-type-of (make-soap-xs-attribute-group)) + 'soap-resolve-references #'soap-resolve-references-for-xs-attribute-group) + +;;;;; soap-xs-simple-type + +(cl-defstruct (soap-xs-simple-type (:include soap-xs-type)) + ;; A simple type is an extension on the basic type to which some + ;; restrictions can be added. For example we can define a simple type based + ;; off "string" with the restrictions that only the strings "one", "two" and + ;; "three" are valid values (this is an enumeration). + + base ; can be a single type, or a list of types for union types + enumeration ; nil, or list of permitted values for the type + pattern ; nil, or value must match this pattern + length-range ; a cons of (min . max) length, inclusive range. + ; For exact length, use (l, l). + ; nil means no range, + ; (nil . l) means no min range, + ; (l . nil) means no max range. + integer-range ; a pair of (min, max) integer values, inclusive range, + ; same meaning as `length-range' + is-list ; t if this is an xs:list, nil otherwise + ) + +(defun soap-xs-parse-simple-type (node) + "Construct an `soap-xs-simple-type' object from the XML NODE." + (cl-assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:simpleType xsd:simpleContent)) + nil + "expecting xsd:simpleType or xsd:simpleContent node, got %s" + (soap-l2wk (xml-node-name node))) + + ;; NOTE: name can be nil for inline types. Such types cannot be added to a + ;; namespace. + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id))) + + (let ((type (make-soap-xs-simple-type + :name name :namespace-tag soap-target-xmlns :id id)) + (def (soap-xml-node-find-matching-child + node '(xsd:restriction xsd:extension xsd:union xsd:list)))) + (cl-ecase (soap-l2wk (xml-node-name def)) + (xsd:restriction (soap-xs-add-restriction def type)) + (xsd:extension (soap-xs-add-extension def type)) + (xsd:union (soap-xs-add-union def type)) + (xsd:list (soap-xs-add-list def type))) + + type))) + +(defun soap-xs-add-restriction (node type) + "Add restrictions defined in XML NODE to TYPE, an `soap-xs-simple-type'." + + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction) + nil + "expecting xsd:restriction node, got %s" + (soap-l2wk (xml-node-name node))) + + (setf (soap-xs-simple-type-base type) + (soap-l2fq (xml-get-attribute node 'base))) + + (dolist (r (xml-node-children node)) + (unless (stringp r) ; skip the white space + (let ((value (xml-get-attribute r 'value))) + (cl-case (soap-l2wk (xml-node-name r)) + (xsd:enumeration + (push value (soap-xs-simple-type-enumeration type))) + (xsd:pattern + (setf (soap-xs-simple-type-pattern type) + (concat "\\`" (xsdre-translate value) "\\'"))) + (xsd:length + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (cons value value)))) + (xsd:minLength + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (if (soap-xs-simple-type-length-range type) + (cons value + (cdr (soap-xs-simple-type-length-range type))) + ;; else + (cons value nil))))) + (xsd:maxLength + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (if (soap-xs-simple-type-length-range type) + (cons (car (soap-xs-simple-type-length-range type)) + value) + ;; else + (cons nil value))))) + (xsd:minExclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (1+ value) + (cdr (soap-xs-simple-type-integer-range type))) + ;; else + (cons (1+ value) nil))))) + (xsd:maxExclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (car (soap-xs-simple-type-integer-range type)) + (1- value)) + ;; else + (cons nil (1- value)))))) + (xsd:minInclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons value + (cdr (soap-xs-simple-type-integer-range type))) + ;; else + (cons value nil))))) + (xsd:maxInclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (car (soap-xs-simple-type-integer-range type)) + value) + ;; else + (cons nil value)))))))))) + +(defun soap-xs-add-union (node type) + "Add union members defined in XML NODE to TYPE, an `soap-xs-simple-type'." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'xsd:union) + nil + "expecting xsd:union node, got %s" + (soap-l2wk (xml-node-name node))) + + (setf (soap-xs-simple-type-base type) + (mapcar 'soap-l2fq + (split-string + (or (xml-get-attribute-or-nil node 'memberTypes) "")))) + + ;; Additional simple types can be defined inside the union node. Add them + ;; to the base list. The "memberTypes" members will have to be resolved by + ;; the "resolve-references" method, the inline types will not. + (let (result) + (dolist (simple-type (soap-xml-get-children1 node 'xsd:simpleType)) + (push (soap-xs-parse-simple-type simple-type) result)) + (setf (soap-xs-simple-type-base type) + (append (soap-xs-simple-type-base type) (nreverse result))))) + +(defun soap-xs-add-list (node type) + "Add list defined in XML NODE to TYPE, a `soap-xs-simple-type'." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'xsd:list) + nil + "expecting xsd:list node, got %s" (soap-l2wk (xml-node-name node))) + + ;; A simple type can be defined inline inside the list node or referenced by + ;; the itemType attribute, in which case it will be resolved by the + ;; resolve-references method. + (let* ((item-type (xml-get-attribute-or-nil node 'itemType)) + (children (soap-xml-get-children1 node 'xsd:simpleType))) + (if item-type + (if (= (length children) 0) + (setf (soap-xs-simple-type-base type) (soap-l2fq item-type)) + (soap-warning + "xsd:list node with itemType has more than zero children: %s" + (soap-xs-type-name type))) + (if (= (length children) 1) + (setf (soap-xs-simple-type-base type) + (soap-xs-parse-simple-type + (car (soap-xml-get-children1 node 'xsd:simpleType)))) + (soap-warning "xsd:list node has more than one child %s" + (soap-xs-type-name type)))) + (setf (soap-xs-simple-type-is-list type) t))) + +(defun soap-xs-add-extension (node type) + "Add the extended type defined in XML NODE to TYPE, an `soap-xs-simple-type'." + (setf (soap-xs-simple-type-base type) + (soap-l2fq (xml-get-attribute node 'base))) + (dolist (attribute (soap-xml-get-children1 node 'xsd:attribute)) + (push (soap-xs-parse-attribute attribute) + (soap-xs-type-attributes type))) + (dolist (attribute-group (soap-xml-get-children1 node 'xsd:attributeGroup)) + (push (soap-xs-parse-attribute-group attribute-group) + (soap-xs-type-attribute-groups type)))) + +(defun soap-validate-xs-basic-type (value type) + "Validate VALUE against the basic type TYPE." + (let* ((kind (soap-xs-basic-type-kind type))) + (cl-case kind + ((anyType Array byte[]) + value) + (t + (let ((convert (get kind 'rng-xsd-convert))) + (if convert + (if (rng-dt-make-value convert value) + value + (error "Invalid %s: %s" (symbol-name kind) value)) + (error "Don't know how to convert %s" kind))))))) + +(defun soap-validate-xs-simple-type (value type) + "Validate VALUE against the restrictions of TYPE." + + (let* ((base-type (soap-xs-simple-type-base type)) + (messages nil)) + (if (listp base-type) + (catch 'valid + (dolist (base base-type) + (condition-case error-object + (cond ((soap-xs-simple-type-p base) + (throw 'valid + (soap-validate-xs-simple-type value base))) + ((soap-xs-basic-type-p base) + (throw 'valid + (soap-validate-xs-basic-type value base)))) + (error (push (cadr error-object) messages)))) + (when messages + (error (mapconcat 'identity (nreverse messages) "; and: ")))) + (cl-labels ((fail-with-message (format value) + (push (format format value) messages) + (throw 'invalid nil))) + (catch 'invalid + (let ((enumeration (soap-xs-simple-type-enumeration type))) + (when (and (> (length enumeration) 1) + (not (member value enumeration))) + (fail-with-message "bad value, should be one of %s" enumeration))) + + (let ((pattern (soap-xs-simple-type-pattern type))) + (when (and pattern (not (string-match-p pattern value))) + (fail-with-message "bad value, should match pattern %s" pattern))) + + (let ((length-range (soap-xs-simple-type-length-range type))) + (when length-range + (unless (stringp value) + (fail-with-message + "bad value, should be a string with length range %s" + length-range)) + (when (car length-range) + (unless (>= (length value) (car length-range)) + (fail-with-message "short string, should be at least %s chars" + (car length-range)))) + (when (cdr length-range) + (unless (<= (length value) (cdr length-range)) + (fail-with-message "long string, should be at most %s chars" + (cdr length-range)))))) + + (let ((integer-range (soap-xs-simple-type-integer-range type))) + (when integer-range + (unless (numberp value) + (fail-with-message "bad value, should be a number with range %s" + integer-range)) + (when (car integer-range) + (unless (>= value (car integer-range)) + (fail-with-message "small value, should be at least %s" + (car integer-range)))) + (when (cdr integer-range) + (unless (<= value (cdr integer-range)) + (fail-with-message "big value, should be at most %s" + (cdr integer-range)))))))) + (when messages + (error "Xs-simple-type(%s, %s): %s" + value (or (soap-xs-type-name type) (soap-xs-type-id type)) + (car messages))))) + ;; Return the validated value. + value) + +(defun soap-resolve-references-for-xs-simple-type (type wsdl) + "Replace names in TYPE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-simple-type' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag type))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag type) nstag))))) + + (let ((base (soap-xs-simple-type-base type))) + (cond + ((soap-name-p base) + (setf (soap-xs-simple-type-base type) + (soap-wsdl-get base wsdl 'soap-xs-type-p))) + ((soap-xs-type-p base) + (soap-resolve-references base wsdl)) + ((listp base) + (setf (soap-xs-simple-type-base type) + (mapcar (lambda (type) + (cond ((soap-name-p type) + (soap-wsdl-get type wsdl 'soap-xs-type-p)) + ((soap-xs-type-p type) + (soap-resolve-references type wsdl) + type) + (t ; signal an error? + type))) + base))) + (t (error "Oops")))) + (dolist (attribute (soap-xs-type-attributes type)) + (soap-resolve-references attribute wsdl)) + (dolist (attribute-group (soap-xs-type-attribute-groups type)) + (soap-resolve-references attribute-group wsdl))) + +(defun soap-encode-xs-simple-type-attributes (value type) + "Encode the XML attributes for VALUE according to TYPE. +The xsi:type and an optional xsi:nil attributes are added. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-simple-type' objects." + (insert " xsi:type=\"" (soap-element-fq-name type) "\"") + (unless value (insert " xsi:nil=\"true\""))) + +(defun soap-encode-xs-simple-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-simple-type' objects." + (soap-validate-xs-simple-type value type) + (if (soap-xs-simple-type-is-list type) + (progn + (dolist (v (butlast value)) + (soap-encode-value v (soap-xs-simple-type-base type)) + (insert " ")) + (soap-encode-value (car (last value)) (soap-xs-simple-type-base type))) + (soap-encode-value value (soap-xs-simple-type-base type)))) + +(defun soap-decode-xs-simple-type (type node) + "Use TYPE, a `soap-xs-simple-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-simple-type' objects." + (if (soap-xs-simple-type-is-list type) + ;; Technically, we could construct fake XML NODEs and pass them to + ;; soap-decode-value... + (split-string (car (xml-node-children node))) + (let ((value (soap-decode-type (soap-xs-simple-type-base type) node))) + (soap-validate-xs-simple-type value type)))) + +;; Register methods for `soap-xs-simple-type' +(let ((tag (soap-type-of (make-soap-xs-simple-type)))) + (put tag 'soap-resolve-references + #'soap-resolve-references-for-xs-simple-type) + (put tag 'soap-attribute-encoder #'soap-encode-xs-simple-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-simple-type) + (put tag 'soap-decoder #'soap-decode-xs-simple-type)) + +;;;;; soap-xs-complex-type + +(cl-defstruct (soap-xs-complex-type (:include soap-xs-type)) + indicator ; sequence, choice, all, array + base + elements + optional? + multiple? + is-group) + +(defun soap-xs-parse-complex-type (node) + "Construct a `soap-xs-complex-type' by parsing the XML NODE." + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (node-name (soap-l2wk (xml-node-name node))) + type + attributes + attribute-groups) + (cl-assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group)) + nil "unexpected node: %s" node-name) + + (dolist (def (xml-node-children node)) + (when (consp def) ; skip text nodes + (cl-case (soap-l2wk (xml-node-name def)) + (xsd:attribute (push (soap-xs-parse-attribute def) attributes)) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) + attribute-groups)) + (xsd:simpleContent (setq type (soap-xs-parse-simple-type def))) + ((xsd:sequence xsd:all xsd:choice) + (setq type (soap-xs-parse-sequence def))) + (xsd:complexContent + (dolist (def (xml-node-children def)) + (when (consp def) + (cl-case (soap-l2wk (xml-node-name def)) + (xsd:attribute + (push (soap-xs-parse-attribute def) attributes)) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) + attribute-groups)) + ((xsd:extension xsd:restriction) + (setq type + (soap-xs-parse-extension-or-restriction def))) + ((xsd:sequence xsd:all xsd:choice) + (soap-xs-parse-sequence def))))))))) + (unless type + ;; the type has not been built, this is a shortcut for a simpleContent + ;; node + (setq type (make-soap-xs-complex-type))) + + (setf (soap-xs-type-name type) name) + (setf (soap-xs-type-namespace-tag type) soap-target-xmlns) + (setf (soap-xs-type-id type) id) + (setf (soap-xs-type-attributes type) + (append attributes (soap-xs-type-attributes type))) + (setf (soap-xs-type-attribute-groups type) + (append attribute-groups (soap-xs-type-attribute-groups type))) + (when (soap-xs-complex-type-p type) + (setf (soap-xs-complex-type-is-group type) + (eq node-name 'xsd:group))) + type)) + +(defun soap-xs-parse-sequence (node) + "Parse a sequence definition from XML NODE. +Returns a `soap-xs-complex-type'" + (cl-assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:sequence xsd:choice xsd:all)) + nil + "unexpected node: %s" (soap-l2wk (xml-node-name node))) + + (let ((type (make-soap-xs-complex-type))) + + (setf (soap-xs-complex-type-indicator type) + (cl-ecase (soap-l2wk (xml-node-name node)) + (xsd:sequence 'sequence) + (xsd:all 'all) + (xsd:choice 'choice))) + + (setf (soap-xs-complex-type-optional? type) (soap-node-optional node)) + (setf (soap-xs-complex-type-multiple? type) (soap-node-multiple node)) + + (dolist (r (xml-node-children node)) + (unless (stringp r) ; skip the white space + (cl-case (soap-l2wk (xml-node-name r)) + ((xsd:element xsd:group) + (push (soap-xs-parse-element r) + (soap-xs-complex-type-elements type))) + ((xsd:sequence xsd:choice xsd:all) + ;; an inline sequence, choice or all node + (let ((choice (soap-xs-parse-sequence r))) + (push (make-soap-xs-element :name nil :type^ choice) + (soap-xs-complex-type-elements type)))) + (xsd:attribute + (push (soap-xs-parse-attribute r) + (soap-xs-type-attributes type))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group r) + (soap-xs-type-attribute-groups type)))))) + + (setf (soap-xs-complex-type-elements type) + (nreverse (soap-xs-complex-type-elements type))) + + type)) + +(defun soap-xs-parse-extension-or-restriction (node) + "Parse an extension or restriction definition from XML NODE. +Return a `soap-xs-complex-type'." + (cl-assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:extension xsd:restriction)) + nil + "unexpected node: %s" (soap-l2wk (xml-node-name node))) + (let (type + attributes + attribute-groups + array? + (base (xml-get-attribute-or-nil node 'base))) + + ;; Array declarations are recognized specially, it is unclear to me how + ;; they could be treated generally... + (setq array? + (and (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction) + (equal base (soap-wk2l "soapenc:Array")))) + + (dolist (def (xml-node-children node)) + (when (consp def) ; skip text nodes + (cl-case (soap-l2wk (xml-node-name def)) + ((xsd:sequence xsd:choice xsd:all) + (setq type (soap-xs-parse-sequence def))) + (xsd:attribute + (if array? + (let ((array-type + (soap-xml-get-attribute-or-nil1 def 'wsdl:arrayType))) + (when (and array-type + (string-match "^\\(.*\\)\\[\\]$" array-type)) + ;; Override + (setq base (match-string 1 array-type)))) + ;; else + (push (soap-xs-parse-attribute def) attributes))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) attribute-groups))))) + + (unless type + (setq type (make-soap-xs-complex-type)) + (when array? + (setf (soap-xs-complex-type-indicator type) 'array))) + + (setf (soap-xs-complex-type-base type) (soap-l2fq base)) + (setf (soap-xs-complex-type-attributes type) attributes) + (setf (soap-xs-complex-type-attribute-groups type) attribute-groups) + type)) + +(defun soap-resolve-references-for-xs-complex-type (type wsdl) + "Replace names in TYPE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-complex-type' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag type))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag type) nstag))))) + + (let ((base (soap-xs-complex-type-base type))) + (cond ((soap-name-p base) + (setf (soap-xs-complex-type-base type) + (soap-wsdl-get base wsdl 'soap-xs-type-p))) + ((soap-xs-type-p base) + (soap-resolve-references base wsdl)))) + (let (all-elements) + (dolist (element (soap-xs-complex-type-elements type)) + (if (soap-xs-element-is-group element) + ;; This is an xsd:group element that references an xsd:group node, + ;; which we treat as a complex type. We replace the reference + ;; element by inlining the elements of the referenced xsd:group + ;; (complex type) node. + (let ((type (soap-wsdl-get + (soap-xs-element-reference element) + wsdl (lambda (type) + (and + (soap-xs-complex-type-p type) + (soap-xs-complex-type-is-group type)))))) + (dolist (element (soap-xs-complex-type-elements type)) + (soap-resolve-references element wsdl) + (push element all-elements))) + ;; This is a non-xsd:group node so just add it directly. + (soap-resolve-references element wsdl) + (push element all-elements))) + (setf (soap-xs-complex-type-elements type) (nreverse all-elements))) + (dolist (attribute (soap-xs-type-attributes type)) + (soap-resolve-references attribute wsdl)) + (dolist (attribute-group (soap-xs-type-attribute-groups type)) + (soap-resolve-references attribute-group wsdl))) + +(defun soap-encode-xs-complex-type-attributes (value type) + "Encode the XML attributes for encoding VALUE according to TYPE. +The xsi:type and optional xsi:nil attributes are added, plus +additional attributes needed for arrays types, if applicable. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-complex-type' objects." + (if (eq (soap-xs-complex-type-indicator type) 'array) + (let ((element-type (soap-xs-complex-type-base type))) + (insert " xsi:type=\"soapenc:Array\"") + (insert " soapenc:arrayType=\"" + (soap-element-fq-name element-type) + "[" (format "%s" (length value)) "]" "\"")) + ;; else + (progn + (dolist (a (soap-get-xs-attributes type)) + (let ((element-name (soap-element-name a))) + (if (soap-xs-attribute-default a) + (insert " " element-name + "=\"" (soap-xs-attribute-default a) "\"") + (dolist (value-pair value) + (when (equal element-name (symbol-name (car value-pair))) + (insert " " element-name + "=\"" (cdr value-pair) "\"")))))) + ;; If this is not an empty type, and we have no value, mark it as nil + (when (and (soap-xs-complex-type-indicator type) (null value)) + (insert " xsi:nil=\"true\""))))) + +(defun soap-get-candidate-elements (element) + "Return a list of elements that are compatible with ELEMENT. +The returned list includes ELEMENT's references and +alternatives." + (let ((reference (soap-xs-element-reference element))) + ;; If the element is a reference, append the reference and its + ;; alternatives... + (if reference + (append (list reference) + (soap-xs-element-alternatives reference)) + ;; ...otherwise append the element itself and its alternatives. + (append (list element) + (soap-xs-element-alternatives element))))) + +(defun soap-encode-xs-complex-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-complex-type' objects." + (cl-case (soap-xs-complex-type-indicator type) + (array + (error "Arrays of type soap-encode-xs-complex-type are handled elsewhere")) + ((sequence choice all nil) + (let ((type-list (list type))) + + ;; Collect all base types + (let ((base (soap-xs-complex-type-base type))) + (while base + (push base type-list) + (setq base (soap-xs-complex-type-base base)))) + + (dolist (type type-list) + (dolist (element (soap-xs-complex-type-elements type)) + (catch 'done + (let ((instance-count 0)) + (dolist (candidate (soap-get-candidate-elements element)) + (let ((e-name (soap-xs-element-name candidate))) + (if e-name + (let ((e-name (intern e-name))) + (dolist (v value) + (when (equal (car v) e-name) + (cl-incf instance-count) + (soap-encode-value (cdr v) candidate)))) + (if (soap-xs-complex-type-indicator type) + (let ((current-point (point))) + ;; Check if encoding happened by checking if + ;; characters were inserted in the buffer. + (soap-encode-value value candidate) + (when (not (equal current-point (point))) + (cl-incf instance-count))) + (dolist (v value) + (let ((current-point (point))) + (soap-encode-value v candidate) + (when (not (equal current-point (point))) + (cl-incf instance-count)))))))) + ;; Do some sanity checking + (let* ((indicator (soap-xs-complex-type-indicator type)) + (element-type (soap-xs-element-type element)) + (reference (soap-xs-element-reference element)) + (e-name (or (soap-xs-element-name element) + (and reference + (soap-xs-element-name reference))))) + (cond ((and (eq indicator 'choice) + (> instance-count 0)) + ;; This was a choice node and we encoded + ;; one instance. + (throw 'done t)) + ((and (not (eq indicator 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + value e-name)) + ((and (> instance-count 1) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning + (concat "While encoding %s: expected single," + " found multiple elements for slot %s") + value e-name)))))))))) + (t + (error "Don't know how to encode complex type: %s" + (soap-xs-complex-type-indicator type))))) + +(defun soap-xml-get-children-fq (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children1', but NODE's local +namespace is used to resolve the children's namespace tags." + (let (result) + (dolist (c (xml-node-children node)) + (when (and (consp c) + (soap-with-local-xmlns node + ;; We use `ignore-errors' here because we want to silently + ;; skip nodes for which we cannot convert them to a + ;; well-known name. + (equal (ignore-errors + (soap-l2fq (xml-node-name c))) + child-name))) + (push c result))) + (nreverse result))) + +(defun soap-xs-element-get-fq-name (element wsdl) + "Return ELEMENT's fully-qualified name using WSDL's alias table. +Return nil if ELEMENT does not have a name." + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag element) + ns-aliases)))) + (when ns-name + (cons ns-name (soap-element-name element))))) + +(defun soap-xs-complex-type-optional-p (type) + "Return t if TYPE or any of TYPE's ancestor types is optional. +Return nil otherwise." + (when type + (or (soap-xs-complex-type-optional? type) + (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-optional-p + (soap-xs-complex-type-base type)))))) + +(defun soap-xs-complex-type-multiple-p (type) + "Return t if TYPE or any of TYPE's ancestor types permits multiple elements. +Return nil otherwise." + (when type + (or (soap-xs-complex-type-multiple? type) + (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-multiple-p + (soap-xs-complex-type-base type)))))) + +(defun soap-get-xs-attributes-from-groups (attribute-groups) + "Return a list of attributes from all ATTRIBUTE-GROUPS." + (let (attributes) + (dolist (group attribute-groups) + (let ((sub-groups (soap-xs-attribute-group-attribute-groups group))) + (setq attributes (append attributes + (soap-get-xs-attributes-from-groups sub-groups) + (soap-xs-attribute-group-attributes group))))) + attributes)) + +(defun soap-get-xs-attributes (type) + "Return a list of all of TYPE's and TYPE's ancestors' attributes." + (let* ((base (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-base type))) + (attributes (append (soap-xs-type-attributes type) + (soap-get-xs-attributes-from-groups + (soap-xs-type-attribute-groups type))))) + (if base + (append attributes (soap-get-xs-attributes base)) + attributes))) + +(defun soap-decode-xs-attributes (type node) + "Use TYPE, a `soap-xs-complex-type', to decode the attributes of NODE." + (let (result) + (dolist (attribute (soap-get-xs-attributes type)) + (let* ((name (soap-xs-attribute-name attribute)) + (attribute-type (soap-xs-attribute-type attribute)) + (symbol (intern name)) + (value (xml-get-attribute-or-nil node symbol))) + ;; We don't support attribute uses: required, optional, prohibited. + (cond + ((soap-xs-basic-type-p attribute-type) + ;; Basic type values are validated by xml.el. + (when value + (push (cons symbol + ;; Create a fake XML node to satisfy the + ;; soap-decode-xs-basic-type API. + (soap-decode-xs-basic-type attribute-type + (list symbol nil value))) + result))) + ((soap-xs-simple-type-p attribute-type) + (when value + (push (cons symbol + (soap-validate-xs-simple-type value attribute-type)) + result))) + (t + (error (concat "Attribute %s is of type %s which is" + " not a basic or simple type") + name (soap-name-p attribute)))))) + result)) + +(defun soap-decode-xs-complex-type (type node) + "Use TYPE, a `soap-xs-complex-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (cl-case (soap-xs-complex-type-indicator type) + (array + (let ((result nil) + (element-type (soap-xs-complex-type-base type))) + (dolist (node (xml-node-children node)) + (when (consp node) + (push (soap-decode-type element-type node) result))) + (nreverse result))) + ((sequence choice all nil) + (let ((result nil) + (base (soap-xs-complex-type-base type))) + (when base + (setq result (nreverse (soap-decode-type base node)))) + (catch 'done + (dolist (element (soap-xs-complex-type-elements type)) + (let* ((instance-count 0) + (e-name (soap-xs-element-name element)) + ;; Heuristic: guess if we need to decode using local + ;; namespaces. + (use-fq-names (string-match ":" (symbol-name (car node)))) + (children (if e-name + (if use-fq-names + ;; Find relevant children + ;; using local namespaces by + ;; searching for the element's + ;; fully-qualified name. + (soap-xml-get-children-fq + node + (soap-xs-element-get-fq-name + element soap-current-wsdl)) + ;; No local namespace resolution + ;; needed so use the element's + ;; name unqualified. + (xml-get-children node (intern e-name))) + ;; e-name is nil so a) we don't know which + ;; children to operate on, and b) we want to + ;; re-use soap-decode-xs-complex-type, which + ;; expects a node argument with a complex + ;; type; therefore we need to operate on the + ;; entire node. We wrap node in a list so + ;; that it will carry through as "node" in the + ;; loop below. + ;; + ;; For example: + ;; + ;; Element Type: + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; + ;; Node: + ;; + ;; + ;; 1 + ;; + ;; + ;; soap-decode-type will be called below with: + ;; + ;; element = + ;; + ;; + ;; + ;; + ;; node = + ;; + ;; + ;; 1 + ;; + (list node))) + (element-type (soap-xs-element-type element))) + (dolist (node children) + (cl-incf instance-count) + (let* ((attributes + (soap-decode-xs-attributes element-type node)) + ;; Attributes may specify xsi:type override. + (element-type + (if (soap-xml-get-attribute-or-nil1 node 'xsi:type) + (soap-wsdl-get + (soap-l2fq + (soap-xml-get-attribute-or-nil1 node + 'xsi:type)) + soap-current-wsdl 'soap-xs-type-p t) + element-type)) + (decoded-child (soap-decode-type element-type node))) + (if e-name + (push (cons (intern e-name) + (append attributes decoded-child)) result) + ;; When e-name is nil we don't want to introduce an extra + ;; level of nesting, so we splice the decoding into + ;; result. + (setq result (append decoded-child result))))) + (cond ((and (eq (soap-xs-complex-type-indicator type) 'choice) + ;; Choices can allow multiple values. + (not (soap-xs-complex-type-multiple-p type)) + (> instance-count 0)) + ;; This was a choice node, and we decoded one value. + (throw 'done t)) + + ;; Do some sanity checking + ((and (not (eq (soap-xs-complex-type-indicator type) + 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning "missing non-nillable slot %s" e-name)) + ((and (> instance-count 1) + (not (soap-xs-complex-type-multiple-p type)) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning "expected single %s slot, found multiple" + e-name)))))) + (nreverse result))) + (t + (error "Don't know how to decode complex type: %s" + (soap-xs-complex-type-indicator type))))) + +;; Register methods for `soap-xs-complex-type' +(let ((tag (soap-type-of (make-soap-xs-complex-type)))) + (put tag 'soap-resolve-references + #'soap-resolve-references-for-xs-complex-type) + (put tag 'soap-attribute-encoder #'soap-encode-xs-complex-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-complex-type) + (put tag 'soap-decoder #'soap-decode-xs-complex-type)) + +;;;; WSDL documents +;;;;; WSDL document elements + + +(cl-defstruct (soap-message (:include soap-element)) + parts ; ALIST of NAME => WSDL-TYPE name + ) + +(cl-defstruct (soap-operation (:include soap-element)) + parameter-order + input ; (NAME . MESSAGE) + output ; (NAME . MESSAGE) + faults ; a list of (NAME . MESSAGE) + input-action ; WS-addressing action string + output-action) ; WS-addressing action string + +(cl-defstruct (soap-port-type (:include soap-element)) + operations) ; a namespace of operations + +;; A bound operation is an operation which has a soap action and a use +;; method attached -- these are attached as part of a binding and we +;; can have different bindings for the same operations. +(cl-defstruct soap-bound-operation + operation ; SOAP-OPERATION + soap-action ; value for SOAPAction HTTP header + soap-headers ; list of (message part use) + soap-body ; message parts present in the body + use ; 'literal or 'encoded, see + ; http://www.w3.org/TR/wsdl#_soap:body + ) + +(cl-defstruct (soap-binding (:include soap-element)) + port-type + (operations (make-hash-table :test 'equal) :readonly t)) + +(cl-defstruct (soap-port (:include soap-element)) + service-url + binding) + + +;;;;; The WSDL document + +;; The WSDL data structure used for encoding/decoding SOAP messages +(cl-defstruct (soap-wsdl + ;; NOTE: don't call this constructor, see `soap-make-wsdl' + (:constructor soap-make-wsdl^) + (:copier soap-copy-wsdl)) + origin ; file or URL from which this wsdl was loaded + current-file ; most-recently fetched file or URL + xmlschema-imports ; a list of schema imports + ports ; a list of SOAP-PORT instances + alias-table ; a list of namespace aliases + namespaces ; a list of namespaces + ) + +(defun soap-make-wsdl (origin) + "Create a new WSDL document, loaded from ORIGIN, and initialize it." + (let ((wsdl (soap-make-wsdl^ :origin origin))) + + ;; Add the XSD types to the wsdl document + (let ((ns (soap-make-xs-basic-types + "http://www.w3.org/2001/XMLSchema" "xsd"))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) + + ;; Add the soapenc types to the wsdl document + (let ((ns (soap-make-xs-basic-types + "http://schemas.xmlsoap.org/soap/encoding/" "soapenc"))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) + + wsdl)) + +(defun soap-wsdl-add-alias (alias name wsdl) + "Add a namespace ALIAS for NAME to the WSDL document." + (let ((existing (assoc alias (soap-wsdl-alias-table wsdl)))) + (if existing + (unless (equal (cdr existing) name) + (warn "Redefining alias %s from %s to %s" + alias (cdr existing) name) + (push (cons alias name) (soap-wsdl-alias-table wsdl))) + (push (cons alias name) (soap-wsdl-alias-table wsdl))))) + +(defun soap-wsdl-find-namespace (name wsdl) + "Find a namespace by NAME in the WSDL document." + (catch 'found + (dolist (ns (soap-wsdl-namespaces wsdl)) + (when (equal name (soap-namespace-name ns)) + (throw 'found ns))))) + +(defun soap-wsdl-add-namespace (ns wsdl) + "Add the namespace NS to the WSDL document. +If a namespace by this name already exists in WSDL, individual +elements will be added to it." + (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl))) + (if existing + ;; Add elements from NS to EXISTING, replacing existing values. + (maphash (lambda (_key value) + (dolist (v value) + (soap-namespace-put v existing))) + (soap-namespace-elements ns)) + (push ns (soap-wsdl-namespaces wsdl))))) + +(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table) + "Retrieve element NAME from the WSDL document. + +PREDICATE is used to differentiate between elements when NAME +refers to multiple elements. A typical value for this would be a +structure predicate for the type of element you want to retrieve. +For example, to retrieve a message named \"foo\" when other +elements named \"foo\" exist in the WSDL you could use: + + (soap-wsdl-get \"foo\" WSDL \\='soap-message-p) + +If USE-LOCAL-ALIAS-TABLE is not nil, `soap-local-xmlns' will be +used to resolve the namespace alias." + (let ((alias-table (soap-wsdl-alias-table wsdl)) + namespace element-name element) + + (when (symbolp name) + (setq name (symbol-name name))) + + (when use-local-alias-table + (setq alias-table (append soap-local-xmlns alias-table))) + + (cond ((consp name) ; a fully qualified name, as returned by `soap-l2fq' + (setq element-name (cdr name)) + (when (symbolp element-name) + (setq element-name (symbol-name element-name))) + (setq namespace (soap-wsdl-find-namespace (car name) wsdl)) + (unless namespace + (error "Soap-wsdl-get(%s): unknown namespace: %s" name namespace))) + + ((string-match "^\\(.*\\):\\(.*\\)$" name) + (setq element-name (match-string 2 name)) + + (let* ((ns-alias (match-string 1 name)) + (ns-name (cdr (assoc ns-alias alias-table)))) + (unless ns-name + (error "Soap-wsdl-get(%s): cannot find namespace alias %s" + name ns-alias)) + + (setq namespace (soap-wsdl-find-namespace ns-name wsdl)) + (unless namespace + (error + "Soap-wsdl-get(%s): unknown namespace %s, referenced as %s" + name ns-name ns-alias)))) + (t + (error "Soap-wsdl-get(%s): bad name" name))) + + (setq element (soap-namespace-get + element-name namespace + (if predicate + (lambda (e) + (or (funcall 'soap-namespace-link-p e) + (funcall predicate e))) + nil))) + + (unless element + (error "Soap-wsdl-get(%s): cannot find element" name)) + + (if (soap-namespace-link-p element) + ;; NOTE: don't use the local alias table here + (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate) + element))) + +;;;;; soap-parse-schema + +(defun soap-parse-schema (node wsdl) + "Parse a schema NODE, placing the results in WSDL. +Return a SOAP-NAMESPACE containing the elements." + (soap-with-local-xmlns node + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + nil + "expecting an xsd:schema node, got %s" + (soap-l2wk (xml-node-name node))) + + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + + (dolist (def (xml-node-children node)) + (unless (stringp def) ; skip text nodes + (cl-case (soap-l2wk (xml-node-name def)) + (xsd:import + ;; Imports will be processed later + ;; NOTE: we should expand the location now! + (let ((location (or + (xml-get-attribute-or-nil def 'schemaLocation) + (xml-get-attribute-or-nil def 'location)))) + (when location + (push location (soap-wsdl-xmlschema-imports wsdl))))) + (xsd:element + (soap-namespace-put (soap-xs-parse-element def) ns)) + (xsd:attribute + (soap-namespace-put (soap-xs-parse-attribute def) ns)) + (xsd:attributeGroup + (soap-namespace-put (soap-xs-parse-attribute-group def) ns)) + (xsd:simpleType + (soap-namespace-put (soap-xs-parse-simple-type def) ns)) + ((xsd:complexType xsd:group) + (soap-namespace-put (soap-xs-parse-complex-type def) ns))))) + ns))) + +;;;;; Resolving references for wsdl types + +;; See `soap-wsdl-resolve-references', which is the main entry point for +;; resolving references + +(defun soap-resolve-references (element wsdl) + "Replace names in ELEMENT with the referenced objects in the WSDL. +This is a generic function which invokes a specific resolver +function depending on the type of the ELEMENT. + +If ELEMENT has no resolver function, it is silently ignored." + (let ((resolver (get (soap-type-of element) 'soap-resolve-references))) + (when resolver + (funcall resolver element wsdl)))) + +(defun soap-resolve-references-for-message (message wsdl) + "Replace names in MESSAGE with the referenced objects in the WSDL. +This is a generic function, called by `soap-resolve-references', +you should use that function instead. + +See also `soap-wsdl-resolve-references'." + (let (resolved-parts) + (dolist (part (soap-message-parts message)) + (let ((name (car part)) + (element (cdr part))) + (when (stringp name) + (setq name (intern name))) + (if (soap-name-p element) + (setq element (soap-wsdl-get + element wsdl + (lambda (x) + (or (soap-xs-type-p x) (soap-xs-element-p x))))) + ;; else, inline element, resolve recursively, as the element + ;; won't be reached. + (soap-resolve-references element wsdl) + (unless (soap-element-namespace-tag element) + (setf (soap-element-namespace-tag element) + (soap-element-namespace-tag message)))) + (push (cons name element) resolved-parts))) + (setf (soap-message-parts message) (nreverse resolved-parts)))) + +(defun soap-resolve-references-for-operation (operation wsdl) + "Resolve references for an OPERATION type using the WSDL document. +See also `soap-resolve-references' and +`soap-wsdl-resolve-references'" + + (let ((namespace (soap-element-namespace-tag operation))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag operation) nstag))))) + + (let ((input (soap-operation-input operation)) + (counter 0)) + (let ((name (car input)) + (message (cdr input))) + ;; Name this part if it was not named + (when (or (null name) (equal name "")) + (setq name (format "in%d" (cl-incf counter)))) + (when (soap-name-p message) + (setf (soap-operation-input operation) + (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((output (soap-operation-output operation)) + (counter 0)) + (let ((name (car output)) + (message (cdr output))) + (when (or (null name) (equal name "")) + (setq name (format "out%d" (cl-incf counter)))) + (when (soap-name-p message) + (setf (soap-operation-output operation) + (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((resolved-faults nil) + (counter 0)) + (dolist (fault (soap-operation-faults operation)) + (let ((name (car fault)) + (message (cdr fault))) + (when (or (null name) (equal name "")) + (setq name (format "fault%d" (cl-incf counter)))) + (if (soap-name-p message) + (push (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)) + resolved-faults) + (push fault resolved-faults)))) + (setf (soap-operation-faults operation) resolved-faults)) + + (when (= (length (soap-operation-parameter-order operation)) 0) + (setf (soap-operation-parameter-order operation) + (mapcar 'car (soap-message-parts + (cdr (soap-operation-input operation)))))) + + (setf (soap-operation-parameter-order operation) + (mapcar (lambda (p) + (if (stringp p) + (intern p) + p)) + (soap-operation-parameter-order operation)))) + +(defun soap-resolve-references-for-binding (binding wsdl) + "Resolve references for a BINDING type using the WSDL document. +See also `soap-resolve-references' and +`soap-wsdl-resolve-references'" + (when (soap-name-p (soap-binding-port-type binding)) + (setf (soap-binding-port-type binding) + (soap-wsdl-get (soap-binding-port-type binding) + wsdl 'soap-port-type-p))) + + (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding)))) + (maphash (lambda (k v) + (setf (soap-bound-operation-operation v) + (soap-namespace-get k port-ops 'soap-operation-p)) + (let (resolved-headers) + (dolist (h (soap-bound-operation-soap-headers v)) + (push (list (soap-wsdl-get (nth 0 h) wsdl) + (intern (nth 1 h)) + (nth 2 h)) + resolved-headers)) + (setf (soap-bound-operation-soap-headers v) + (nreverse resolved-headers)))) + (soap-binding-operations binding)))) + +(defun soap-resolve-references-for-port (port wsdl) + "Replace names in PORT with the referenced objects in the WSDL. +This is a generic function, called by `soap-resolve-references', +you should use that function instead. + +See also `soap-wsdl-resolve-references'." + (when (soap-name-p (soap-port-binding port)) + (setf (soap-port-binding port) + (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p)))) + +;; Install resolvers for our types +(progn + (put (soap-type-of (make-soap-message)) 'soap-resolve-references + 'soap-resolve-references-for-message) + (put (soap-type-of (make-soap-operation)) 'soap-resolve-references + 'soap-resolve-references-for-operation) + (put (soap-type-of (make-soap-binding)) 'soap-resolve-references + 'soap-resolve-references-for-binding) + (put (soap-type-of (make-soap-port)) 'soap-resolve-references + 'soap-resolve-references-for-port)) + +(defun soap-wsdl-resolve-references (wsdl) + "Resolve all references inside the WSDL structure. + +When the WSDL elements are created from the XML document, they +refer to each other by name. For example, the ELEMENT-TYPE slot +of an SOAP-ARRAY-TYPE will contain the name of the element and +the user would have to call `soap-wsdl-get' to obtain the actual +element. + +After the entire document is loaded, we resolve all these +references to the actual elements they refer to so that at +runtime, we don't have to call `soap-wsdl-get' each time we +traverse an element tree." + (let ((nprocessed 0) + (nstag-id 0) + (alias-table (soap-wsdl-alias-table wsdl))) + (dolist (ns (soap-wsdl-namespaces wsdl)) + (let ((nstag (car-safe (rassoc (soap-namespace-name ns) alias-table)))) + (unless nstag + ;; If this namespace does not have an alias, create one for it. + (catch 'done + (while t + (setq nstag (format "ns%d" (cl-incf nstag-id))) + (unless (assoc nstag alias-table) + (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) + (throw 'done t))))) + + (maphash (lambda (_name element) + (cond ((soap-element-p element) ; skip links + (cl-incf nprocessed) + (soap-resolve-references element wsdl)) + ((listp element) + (dolist (e element) + (when (soap-element-p e) + (cl-incf nprocessed) + (soap-resolve-references e wsdl)))))) + (soap-namespace-elements ns))))) + wsdl) + +;;;;; Loading WSDL from XML documents + +(defun soap-parse-server-response () + "Error-check and parse the XML contents of the current buffer." + (let ((mime-part (mm-dissect-buffer t t))) + (when (and + (equal (mm-handle-media-type mime-part) "multipart/related") + (equal (get-text-property 0 'type (mm-handle-media-type mime-part)) + "text/xml")) + (setq mime-part + (mm-make-handle + (get-text-property 0 'buffer (mm-handle-media-type mime-part)) + `(,(get-text-property 0 'type (mm-handle-media-type mime-part)))))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (prog1 + (car (xml-parse-region (point-min) (point-max))) + (kill-buffer) + (mm-destroy-part mime-part))))) + +(defvar url-http-response-status) + +(defun soap-fetch-xml-from-url (url wsdl) + "Load an XML document from URL and return it. +The previously parsed URL is read from WSDL." + (message "Fetching from %s" url) + (let ((current-file (url-expand-file-name url (soap-wsdl-current-file wsdl))) + (url-request-method "GET") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-http-attempt-keepalives t)) + (setf (soap-wsdl-current-file wsdl) current-file) + (let ((buffer (url-retrieve-synchronously current-file))) + (with-current-buffer buffer + (if (> url-http-response-status 299) + (error "Error retrieving WSDL: %s" url-http-response-status)) + (soap-parse-server-response))))) + +(defun soap-fetch-xml-from-file (file wsdl) + "Load an XML document from FILE and return it. +The previously parsed file is read from WSDL." + (let* ((current-file (soap-wsdl-current-file wsdl)) + (expanded-file (expand-file-name file + (if current-file + (file-name-directory current-file) + default-directory)))) + (setf (soap-wsdl-current-file wsdl) expanded-file) + (with-temp-buffer + (insert-file-contents expanded-file) + (car (xml-parse-region (point-min) (point-max)))))) + +(defun soap-fetch-xml (file-or-url wsdl) + "Load an XML document from FILE-OR-URL and return it. +The previously parsed file or URL is read from WSDL." + (let ((current-file (or (soap-wsdl-current-file wsdl) file-or-url))) + (if (or (and current-file (file-exists-p current-file)) + (file-exists-p file-or-url)) + (soap-fetch-xml-from-file file-or-url wsdl) + (soap-fetch-xml-from-url file-or-url wsdl)))) + +(defun soap-load-wsdl (file-or-url &optional wsdl) + "Load a document from FILE-OR-URL and return it. +Build on WSDL if it is provided." + (let* ((wsdl (or wsdl (soap-make-wsdl file-or-url))) + (xml (soap-fetch-xml file-or-url wsdl))) + (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl)) + wsdl)) + +(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl) + +(defun soap-parse-wsdl-phase-validate-node (node) + "Assert that NODE is valid." + (soap-with-local-xmlns node + (let ((node-name (soap-l2wk (xml-node-name node)))) + (cl-assert (eq node-name 'wsdl:definitions) + nil + "expecting wsdl:definitions node, got %s" node-name)))) + +(defun soap-parse-wsdl-phase-fetch-imports (node wsdl) + "Fetch and load files imported by NODE into WSDL." + (soap-with-local-xmlns node + (dolist (node (soap-xml-get-children1 node 'wsdl:import)) + (let ((location (xml-get-attribute-or-nil node 'location))) + (when location + (soap-load-wsdl location wsdl)))))) + +(defun soap-parse-wsdl-phase-parse-schema (node wsdl) + "Load types found in NODE into WSDL." + (soap-with-local-xmlns node + ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes and + ;; build our type-library. + (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) + (dolist (node (xml-node-children types)) + ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) because + ;; each node can install its own alias type so the schema nodes might + ;; have a different prefix. + (when (consp node) + (soap-with-local-xmlns + node + (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + (soap-wsdl-add-namespace (soap-parse-schema node wsdl) + wsdl)))))))) + +(defun soap-parse-wsdl-phase-fetch-schema (node wsdl) + "Fetch and load schema imports defined by NODE into WSDL." + (soap-with-local-xmlns node + (while (soap-wsdl-xmlschema-imports wsdl) + (let* ((import (pop (soap-wsdl-xmlschema-imports wsdl))) + (xml (soap-fetch-xml import wsdl))) + (soap-wsdl-add-namespace (soap-parse-schema xml wsdl) wsdl))))) + +(defun soap-parse-wsdl-phase-finish-parsing (node wsdl) + "Finish parsing NODE into WSDL." + (soap-with-local-xmlns node + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + (dolist (node (soap-xml-get-children1 node 'wsdl:message)) + (soap-namespace-put (soap-parse-message node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) + (let ((port-type (soap-parse-port-type node))) + (soap-namespace-put port-type ns) + (soap-wsdl-add-namespace + (soap-port-type-operations port-type) wsdl))) + + (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) + (soap-namespace-put (soap-parse-binding node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:service)) + (dolist (node (soap-xml-get-children1 node 'wsdl:port)) + (let ((name (xml-get-attribute node 'name)) + (binding (xml-get-attribute node 'binding)) + (url (let ((n (car (soap-xml-get-children1 + node 'wsdlsoap:address)))) + (xml-get-attribute n 'location)))) + (let ((port (make-soap-port + :name name :binding (soap-l2fq binding 'tns) + :service-url url))) + (soap-namespace-put port ns) + (push port (soap-wsdl-ports wsdl)))))) + + (soap-wsdl-add-namespace ns wsdl)))) + +(defun soap-parse-wsdl (node wsdl) + "Construct from NODE a WSDL structure, which is an XML document." + ;; Break this into phases to allow for asynchronous parsing. + (soap-parse-wsdl-phase-validate-node node) + ;; Makes synchronous calls. + (soap-parse-wsdl-phase-fetch-imports node wsdl) + (soap-parse-wsdl-phase-parse-schema node wsdl) + ;; Makes synchronous calls. + (soap-parse-wsdl-phase-fetch-schema node wsdl) + (soap-parse-wsdl-phase-finish-parsing node wsdl) + wsdl) + +(defun soap-parse-message (node) + "Parse NODE as a wsdl:message and return the corresponding type." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message) + nil + "expecting wsdl:message node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + parts) + (dolist (p (soap-xml-get-children1 node 'wsdl:part)) + (let ((name (xml-get-attribute-or-nil p 'name)) + (type (xml-get-attribute-or-nil p 'type)) + (element (xml-get-attribute-or-nil p 'element))) + + (when type + (setq type (soap-l2fq type 'tns))) + + (if element + (setq element (soap-l2fq element 'tns)) + ;; else + (setq element (make-soap-xs-element + :name name + :namespace-tag soap-target-xmlns + :type^ type))) + + (push (cons name element) parts))) + (make-soap-message :name name :parts (nreverse parts)))) + +(defun soap-parse-port-type (node) + "Parse NODE as a wsdl:portType and return the corresponding port." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType) + nil + "expecting wsdl:portType node got %s" + (soap-l2wk (xml-node-name node))) + (let* ((soap-target-xmlns (concat "urn:" (xml-get-attribute node 'name))) + (ns (make-soap-namespace :name soap-target-xmlns))) + (dolist (node (soap-xml-get-children1 node 'wsdl:operation)) + (let ((o (soap-parse-operation node))) + + (let ((other-operation (soap-namespace-get + (soap-element-name o) ns 'soap-operation-p))) + (if other-operation + ;; Unfortunately, the Confluence WSDL defines two operations + ;; named "search" which differ only in parameter names... + (soap-warning "Discarding duplicate operation: %s" + (soap-element-name o)) + + (progn + (soap-namespace-put o ns) + + ;; link all messages from this namespace, as this namespace + ;; will be used for decoding the response. + (cl-destructuring-bind (name . message) (soap-operation-input o) + (soap-namespace-put-link name message ns)) + + (cl-destructuring-bind (name . message) (soap-operation-output o) + (soap-namespace-put-link name message ns)) + + (dolist (fault (soap-operation-faults o)) + (cl-destructuring-bind (name . message) fault + (soap-namespace-put-link name message ns))) + + ))))) + + (make-soap-port-type :name (xml-get-attribute node 'name) + :operations ns))) + +(defun soap-parse-operation (node) + "Parse NODE as a wsdl:operation and return the corresponding type." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation) + nil + "expecting wsdl:operation node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute node 'name)) + (parameter-order (split-string + (xml-get-attribute node 'parameterOrder))) + input output faults input-action output-action) + (dolist (n (xml-node-children node)) + (when (consp n) ; skip string nodes which are whitespace + (let ((node-name (soap-l2wk (xml-node-name n)))) + (cond + ((eq node-name 'wsdl:input) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name)) + (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action))) + (setq input (cons name (soap-l2fq message 'tns))) + (setq input-action action))) + ((eq node-name 'wsdl:output) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name)) + (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action))) + (setq output (cons name (soap-l2fq message 'tns))) + (setq output-action action))) + ((eq node-name 'wsdl:fault) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (push (cons name (soap-l2fq message 'tns)) faults))))))) + (make-soap-operation + :name name + :namespace-tag soap-target-xmlns + :parameter-order parameter-order + :input input + :output output + :faults (nreverse faults) + :input-action input-action + :output-action output-action))) + +(defun soap-parse-binding (node) + "Parse NODE as a wsdl:binding and return the corresponding type." + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding) + nil + "expecting wsdl:binding node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute node 'name)) + (type (xml-get-attribute node 'type))) + (let ((binding (make-soap-binding :name name + :port-type (soap-l2fq type 'tns)))) + (dolist (wo (soap-xml-get-children1 node 'wsdl:operation)) + (let ((name (xml-get-attribute wo 'name)) + soap-action + soap-headers + soap-body + use) + (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) + (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) + + ;; Search a wsdlsoap:body node and find a "use" tag. The + ;; same use tag is assumed to be present for both input and + ;; output types (although the WDSL spec allows separate + ;; "use"-s for each of them... + + (dolist (i (soap-xml-get-children1 wo 'wsdl:input)) + + ;; There can be multiple headers ... + (dolist (h (soap-xml-get-children1 i 'wsdlsoap:header)) + (let ((message (soap-l2fq (xml-get-attribute-or-nil h 'message))) + (part (xml-get-attribute-or-nil h 'part)) + (use (xml-get-attribute-or-nil h 'use))) + (when (and message part) + (push (list message part use) soap-headers)))) + + ;; ... but only one body + (let ((body (car (soap-xml-get-children1 i 'wsdlsoap:body)))) + (setq soap-body (xml-get-attribute-or-nil body 'parts)) + (when soap-body + (setq soap-body + (mapcar #'intern (split-string soap-body + nil + 'omit-nulls)))) + (setq use (xml-get-attribute-or-nil body 'use)))) + + (unless use + (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) + (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) + (setq use (or use + (xml-get-attribute-or-nil b 'use)))))) + + (puthash name (make-soap-bound-operation + :operation name + :soap-action soap-action + :soap-headers (nreverse soap-headers) + :soap-body soap-body + :use (and use (intern use))) + (soap-binding-operations binding)))) + binding))) + +;;;; SOAP type decoding + +(defvar soap-multi-refs nil + "The list of multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defvar soap-decoded-multi-refs nil + "List of decoded multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defun soap-decode-type (type node) + "Use TYPE (an xsd type) to decode the contents of NODE. + +NODE is an XML node, representing some SOAP encoded value or a +reference to another XML node (a multiRef). This function will +resolve the multiRef reference, if any, than call a TYPE specific +decode function to perform the actual decoding." + (let ((href (xml-get-attribute-or-nil node 'href))) + (cond (href + (catch 'done + ;; NODE is actually a HREF, find the target and decode that. + ;; Check first if we already decoded this multiref. + + (let ((decoded (cdr (assoc href soap-decoded-multi-refs)))) + (when decoded + (throw 'done decoded))) + + (unless (string-match "^#\\(.*\\)$" href) + (error "Invalid multiRef: %s" href)) + + (let ((id (match-string 1 href))) + (dolist (mr soap-multi-refs) + (let ((mrid (xml-get-attribute mr 'id))) + (when (equal id mrid) + ;; recurse here, in case there are multiple HREF's + (let ((decoded (soap-decode-type type mr))) + (push (cons href decoded) soap-decoded-multi-refs) + (throw 'done decoded))))) + (error "Cannot find href %s" href)))) + (t + (soap-with-local-xmlns node + (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true") + nil + ;; Handle union types. + (cond ((listp type) + (catch 'done + (dolist (union-member type) + (let* ((decoder (get (soap-type-of union-member) + 'soap-decoder)) + (result (ignore-errors + (funcall decoder + union-member node)))) + (when result (throw 'done result)))))) + (t + (let ((decoder (get (soap-type-of type) 'soap-decoder))) + (cl-assert decoder nil + "no soap-decoder for %s type" + (soap-type-of type)) + (funcall decoder type node)))))))))) + +(defun soap-decode-any-type (node) + "Decode NODE using type information inside it." + ;; If the NODE has type information, we use that... + (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type))) + (when type + (setq type (soap-l2fq type))) + (if type + (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-xs-type-p))) + (if wtype + (soap-decode-type wtype node) + ;; The node has type info encoded in it, but we don't know how + ;; to decode it... + (error "Node has unknown type: %s" type))) + + ;; No type info in the node... + + (let ((contents (xml-node-children node))) + (if (and (= (length contents) 1) (stringp (car contents))) + ;; contents is just a string + (car contents) + + ;; we assume the NODE is a sequence with every element a + ;; structure name + (let (result) + (dolist (element contents) + ;; skip any string contents, assume they are whitespace + (unless (stringp element) + (let ((key (xml-node-name element)) + (value (soap-decode-any-type element))) + (push (cons key value) result)))) + (nreverse result))))))) + +(defun soap-decode-array (node) + "Decode NODE as an Array using type information inside it." + (let ((type (soap-xml-get-attribute-or-nil1 node 'soapenc:arrayType)) + (wtype nil) + (contents (xml-node-children node)) + result) + (when type + ;; Type is in the format "someType[NUM]" where NUM is the number of + ;; elements in the array. We discard the [NUM] part. + (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) + (setq wtype (soap-wsdl-get (soap-l2fq type) + soap-current-wsdl 'soap-xs-type-p)) + (unless wtype + ;; The node has type info encoded in it, but we don't know how to + ;; decode it... + (error "Soap-decode-array: node has unknown type: %s" type))) + (dolist (e contents) + (when (consp e) + (push (if wtype + (soap-decode-type wtype e) + (soap-decode-any-type e)) + result))) + (nreverse result))) + +;;;; Soap Envelope parsing + +(if (fboundp 'define-error) + (define-error 'soap-error "SOAP error") + ;; Support older Emacs versions that do not have define-error, so + ;; that soap-client can remain unchanged in GNU ELPA. + (put 'soap-error + 'error-conditions + '(error soap-error)) + (put 'soap-error 'error-message "SOAP error")) + +(defun soap-parse-envelope (node operation wsdl) + "Parse the SOAP envelope in NODE and return the response. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE" + (soap-with-local-xmlns node + (cl-assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) + nil + "expecting soap:Envelope node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((headers (soap-xml-get-children1 node 'soap:Header)) + (body (car (soap-xml-get-children1 node 'soap:Body)))) + + (let ((fault (car (soap-xml-get-children1 body 'soap:Fault)))) + (when fault + (let ((fault-code (let ((n (car (xml-get-children + fault 'faultcode)))) + (car-safe (xml-node-children n)))) + (fault-string (let ((n (car (xml-get-children + fault 'faultstring)))) + (car-safe (xml-node-children n)))) + (detail (xml-get-children fault 'detail))) + (while t + (signal 'soap-error (list fault-code fault-string detail)))))) + + ;; First (non string) element of the body is the root node of he + ;; response + (let ((response (if (eq (soap-bound-operation-use operation) 'literal) + ;; For 'literal uses, the response is the actual body + body + ;; ...otherwise the first non string element + ;; of the body is the response + (catch 'found + (dolist (n (xml-node-children body)) + (when (consp n) + (throw 'found n))))))) + (soap-parse-response response operation wsdl headers body))))) + +(defun soap-parse-response (response-node operation wsdl soap-headers soap-body) + "Parse RESPONSE-NODE and return the result as a LISP value. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE. + +SOAP-HEADERS is a list of the headers of the SOAP envelope or nil +if there are no headers. + +SOAP-BODY is the body of the SOAP envelope (of which +RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE +reference multiRef parts which are external to RESPONSE-NODE." + (let* ((soap-current-wsdl wsdl) + (op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-output op)))) + + (soap-with-local-xmlns response-node + + (when (eq use 'encoded) + (let* ((received-message-name (soap-l2fq (xml-node-name response-node))) + (received-message (soap-wsdl-get + received-message-name wsdl 'soap-message-p))) + (unless (eq received-message message) + (error "Unexpected message: got %s, expecting %s" + received-message-name + (soap-element-name message))))) + + (let ((decoded-parts nil) + (soap-multi-refs (xml-get-children soap-body 'multiRef)) + (soap-decoded-multi-refs nil)) + + (dolist (part (soap-message-parts message)) + (let ((tag (car part)) + (type (cdr part)) + node) + + (setq node + (cond + ((eq use 'encoded) + (car (xml-get-children response-node tag))) + + ((eq use 'literal) + (catch 'found + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag type) + ns-aliases))) + (fqname (cons ns-name (soap-element-name type)))) + (dolist (c (append (mapcar (lambda (header) + (car (xml-node-children + header))) + soap-headers) + (xml-node-children response-node))) + (when (consp c) + (soap-with-local-xmlns c + (when (equal (soap-l2fq (xml-node-name c)) + fqname) + (throw 'found c)))))))))) + + (unless node + (error "Soap-parse-response(%s): cannot find message part %s" + (soap-element-name op) tag)) + (let ((decoded-value (soap-decode-type type node))) + (when decoded-value + (push decoded-value decoded-parts))))) + + decoded-parts)))) + +;;;; SOAP type encoding + +;; FIXME: Use `cl-defmethod' (but this requires Emacs-25). + +(defun soap-encode-attributes (value type) + "Encode XML attributes for VALUE according to TYPE. +This is a generic function which determines the attribute encoder +for the type and calls that specialized function to do the work. + +Attributes are inserted in the current buffer at the current +position." + (let ((attribute-encoder (get (soap-type-of type) 'soap-attribute-encoder))) + (cl-assert attribute-encoder nil + "no soap-attribute-encoder for %s type" (soap-type-of type)) + (funcall attribute-encoder value type))) + +(defun soap-encode-value (value type) + "Encode the VALUE using TYPE. +The resulting XML data is inserted in the current buffer +at (point)/ + +TYPE is one of the soap-*-type structures which defines how VALUE +is to be encoded. This is a generic function which finds an +encoder function based on TYPE and calls that encoder to do the +work." + (let ((encoder (get (soap-type-of type) 'soap-encoder))) + (cl-assert encoder nil "no soap-encoder for %s type" (soap-type-of type)) + (funcall encoder value type)) + (when (soap-element-namespace-tag type) + (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type)))) + +(defun soap-encode-body (operation parameters &optional service-url) + "Create the body of a SOAP request for OPERATION in the current buffer. +PARAMETERS is a list of parameters supplied to the OPERATION. + +The OPERATION and PARAMETERS are encoded according to the WSDL +document. SERVICE-URL should be provided when WS-Addressing is +being used." + (let* ((op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-input op))) + (parameter-order (soap-operation-parameter-order op)) + (param-table (cl-loop for formal in parameter-order + for value in parameters + collect (cons formal value)))) + + (unless (= (length parameter-order) (length parameters)) + (error "Wrong number of parameters for %s: expected %d, got %s" + (soap-element-name op) + (length parameter-order) + (length parameters))) + + (let ((headers (soap-bound-operation-soap-headers operation)) + (input-action (soap-operation-input-action op))) + (when headers + (insert "\n") + (when input-action + (add-to-list 'soap-encoded-namespaces "wsa") + (insert "" input-action "\n") + (insert "" service-url "\n")) + (dolist (h headers) + (let* ((message (nth 0 h)) + (part (assq (nth 1 h) (soap-message-parts message))) + (value (cdr (assoc (car part) (car parameters)))) + (use (nth 2 h)) + (element (cdr part))) + (when (eq use 'encoded) + (when (soap-element-namespace-tag element) + (add-to-list 'soap-encoded-namespaces + (soap-element-namespace-tag element))) + (insert "<" (soap-element-fq-name element) ">\n")) + (soap-encode-value value element) + (when (eq use 'encoded) + (insert "\n")))) + (insert "\n"))) + + (insert "\n") + (when (eq use 'encoded) + (when (soap-element-namespace-tag op) + (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op))) + (insert "<" (soap-element-fq-name op) ">\n")) + + (dolist (part (soap-message-parts message)) + (let* ((param-name (car part)) + (element (cdr part)) + (value (cdr (assoc param-name param-table)))) + (when (or (null (soap-bound-operation-soap-body operation)) + (member param-name + (soap-bound-operation-soap-body operation))) + (soap-encode-value value element)))) + + (when (eq use 'encoded) + (insert "\n")) + (insert "\n"))) + +(defun soap-create-envelope (operation parameters wsdl &optional service-url) + "Create a SOAP request envelope for OPERATION using PARAMETERS. +WSDL is the wsdl document used to encode the PARAMETERS. +SERVICE-URL should be provided when WS-Addressing is being used." + (with-temp-buffer + (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc")) + (use (soap-bound-operation-use operation))) + + ;; Create the request body + (soap-encode-body operation parameters service-url) + + ;; Put the envelope around the body + (goto-char (point-min)) + (insert "\n\n") + (goto-char (point-max)) + (insert "\n")) + + (buffer-string))) + +;;;; invoking soap methods + +(defcustom soap-debug nil + "When t, enable some debugging facilities." + :type 'boolean + :group 'soap-client) + +(defun soap-find-port (wsdl service) + "Return the WSDL port having SERVICE name. +Signal an error if not found." + (or (catch 'found + (dolist (p (soap-wsdl-ports wsdl)) + (when (equal service (soap-element-name p)) + (throw 'found p)))) + (error "Unknown SOAP service: %s" service))) + +(defun soap-find-operation (port operation-name) + "Inside PORT, find OPERATION-NAME, a `soap-port-type'. +Signal an error if not found." + (let* ((binding (soap-port-binding port)) + (op (gethash operation-name (soap-binding-operations binding)))) + (or op + (error "No operation %s for SOAP service %s" + operation-name (soap-element-name port))))) + +(defun soap-operation-arity (wsdl service operation-name) + "Return the number of arguments required by a soap operation. +WSDL, SERVICE, OPERATION-NAME and PARAMETERS are as described in +`soap-invoke'." + (let* ((port (soap-find-port wsdl service)) + (op (soap-find-operation port operation-name)) + (bop (soap-bound-operation-operation op))) + (length (soap-operation-parameter-order bop)))) + +(defun soap-invoke-internal (callback cbargs wsdl service operation-name + &rest parameters) + "Implement `soap-invoke' and `soap-invoke-async'. +If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply +CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result. +If CALLBACK is nil, operate synchronously. WSDL, SERVICE, +OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." + (let* ((port (soap-find-port wsdl service)) + (operation (soap-find-operation port operation-name))) + (let ((url-request-method "POST") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-request-data + ;; url-request-data expects a unibyte string already encoded... + (encode-coding-string + (soap-create-envelope operation parameters wsdl + (soap-port-service-url port)) + 'utf-8)) + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-http-attempt-keepalives t) + (url-request-extra-headers + (list + (cons "SOAPAction" + (concat "\"" (encode-coding-string + (soap-bound-operation-soap-action + operation) + 'utf-8) + "\"")) + (cons "Content-Type" + "text/xml; charset=utf-8")))) + (if callback + (url-retrieve + (soap-port-service-url port) + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (let ((error-status (plist-get status :error))) + (if error-status + (signal (car error-status) (cdr error-status)) + (apply callback + (soap-parse-envelope + (soap-parse-server-response) + operation wsdl) + cbargs))) + ;; Ensure the url-retrieve buffer is not leaked. + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer)))))) + (let ((buffer (url-retrieve-synchronously + (soap-port-service-url port)))) + (condition-case err + (with-current-buffer buffer + (if (null url-http-response-status) + (error "No HTTP response from server")) + (if (and soap-debug (> url-http-response-status 299)) + ;; This is a warning because some SOAP errors come + ;; back with a HTTP response 500 (internal server + ;; error) + (warn "Error in SOAP response: HTTP code %s" + url-http-response-status)) + (soap-parse-envelope (soap-parse-server-response) + operation wsdl)) + (soap-error + ;; Propagate soap-errors -- they are error replies of the + ;; SOAP protocol and don't indicate a communication + ;; problem or a bug in this code. + (signal (car err) (cdr err))) + (error + (when soap-debug + (pop-to-buffer buffer)) + (error (error-message-string err))))))))) + +(defun soap-invoke (wsdl service operation-name &rest parameters) + "Invoke a SOAP operation and return the result. + +WSDL is used for encoding the request and decoding the response. +It also contains information about the WEB server address that +will service the request. + +SERVICE is the SOAP service to invoke. + +OPERATION-NAME is the operation to invoke. + +PARAMETERS -- the remaining parameters are used as parameters for +the SOAP request. + +NOTE: The SOAP service provider should document the available +operations and their parameters for the service. You can also +use the `soap-inspect' function to browse the available +operations in a WSDL document. + +NOTE: `soap-invoke' base64-decodes xsd:base64Binary return values +into unibyte strings; these byte-strings require further +interpretation by the caller." + (apply #'soap-invoke-internal nil nil wsdl service operation-name parameters)) + +(defun soap-invoke-async (callback cbargs wsdl service operation-name + &rest parameters) + "Like `soap-invoke', but call CALLBACK asynchronously with response. +CALLBACK is called as (apply CALLBACK RESPONSE CBARGS), where +RESPONSE is the SOAP invocation result. WSDL, SERVICE, +OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." + (unless callback + (error "Callback argument is nil")) + (apply #'soap-invoke-internal callback cbargs wsdl service operation-name + parameters)) + +(provide 'soap-client) + + +;; Local Variables: +;; eval: (outline-minor-mode 1) +;; outline-regexp: ";;;;+" +;; End: + +;;; soap-client.el ends here diff --git a/.local/elpa/soap-client-3.1.5/soap-inspect.el b/.local/elpa/soap-client-3.1.5/soap-inspect.el new file mode 100644 index 00000000..252b1f35 --- /dev/null +++ b/.local/elpa/soap-client-3.1.5/soap-inspect.el @@ -0,0 +1,546 @@ +;;; soap-inspect.el --- Interactive WSDL inspector -*- lexical-binding: t -*- + +;; Copyright (C) 2010-2018 Free Software Foundation, Inc. + +;; Author: Alexandru Harsanyi +;; Created: October 2010 +;; Keywords: soap, web-services, comm, hypermedia +;; Package: soap-client +;; Homepage: https://github.com/alex-hhh/emacs-soap-client + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This package provides an inspector for a WSDL document loaded with +;; `soap-load-wsdl' or `soap-load-wsdl-from-url'. To use it, evaluate: +;; +;; (soap-inspect *wsdl*) +;; +;; This will pop-up the inspector buffer. You can click on ports, operations +;; and types to explore the structure of the wsdl document. +;; + + +;;; Code: + +(require 'cl-lib) +(require 'soap-client) + +;;; sample-value + +(defun soap-sample-value (type) + "Provide a sample value for TYPE, a WSDL type. +A sample value is a LISP value which soap-client.el will accept +for encoding it using TYPE when making SOAP requests. + +This is a generic function, depending on TYPE a specific function +will be called." + (let ((sample-value (get (soap-type-of type) 'soap-sample-value))) + (if sample-value + (funcall sample-value type) + (error "Cannot provide sample value for type %s" (soap-type-of type))))) + +(defun soap-sample-value-for-xs-basic-type (type) + "Provide a sample value for TYPE, an xs-basic-type. +This is a specialization of `soap-sample-value' for xs-basic-type +objects." + (cl-case (soap-xs-basic-type-kind type) + (string "a string") + (anyURI "an URI") + (QName "a QName") + (dateTime "a time-value-p or string") + (boolean "t or nil") + ((long int integer byte unsignedInt) 42) + ((float double) 3.14) + (base64Binary "a string") + (t (format "%s" (soap-xs-basic-type-kind type))))) + +(defun soap-sample-value-for-xs-element (element) + "Provide a sample value for ELEMENT, a WSDL element. +This is a specialization of `soap-sample-value' for xs-element +objects." + (if (soap-xs-element-name element) + (cons (intern (soap-xs-element-name element)) + (soap-sample-value (soap-xs-element-type element))) + (soap-sample-value (soap-xs-element-type element)))) + +(defun soap-sample-value-for-xs-attribute (attribute) + "Provide a sample value for ATTRIBUTE, a WSDL attribute. +This is a specialization of `soap-sample-value' for +soap-xs-attribute objects." + (if (soap-xs-attribute-name attribute) + (cons (intern (soap-xs-attribute-name attribute)) + (soap-sample-value (soap-xs-attribute-type attribute))) + (soap-sample-value (soap-xs-attribute-type attribute)))) + +(defun soap-sample-value-for-xs-attribute-group (attribute-group) + "Provide a sample value for ATTRIBUTE-GROUP, a WSDL attribute group. +This is a specialization of `soap-sample-value' for +soap-xs-attribute objects." + (let ((sample-values nil)) + (dolist (attribute (soap-xs-attribute-group-attributes attribute-group)) + (if (soap-xs-attribute-name attribute) + (setq sample-values + (append sample-values + (cons (intern (soap-xs-attribute-name attribute)) + (soap-sample-value (soap-xs-attribute-type + attribute))))) + (setq sample-values + (append sample-values + (soap-sample-value + (soap-xs-attribute-type attribute)))))))) + +(defun soap-sample-value-for-xs-simple-type (type) + "Provide a sample value for TYPE, a `soap-xs-simple-type'. +This is a specialization of `soap-sample-value' for +`soap-xs-simple-type' objects." + (append + (mapcar 'soap-sample-value-for-xs-attribute + (soap-xs-type-attributes type)) + (cond + ((soap-xs-simple-type-enumeration type) + (let ((enumeration (soap-xs-simple-type-enumeration type))) + (nth (random (length enumeration)) enumeration))) + ((soap-xs-simple-type-pattern type) + (format "a string matching %s" (soap-xs-simple-type-pattern type))) + ((soap-xs-simple-type-length-range type) + (cl-destructuring-bind (low . high) (soap-xs-simple-type-length-range type) + (cond + ((and low high) + (format "a string between %d and %d chars long" low high)) + (low (format "a string at least %d chars long" low)) + (high (format "a string at most %d chars long" high)) + (t (format "a string OOPS"))))) + ((soap-xs-simple-type-integer-range type) + (cl-destructuring-bind (min . max) (soap-xs-simple-type-integer-range type) + (cond + ((and min max) (+ min (random (- max min)))) + (min (+ min (random 10))) + (max (random max)) + (t (random 100))))) + ((consp (soap-xs-simple-type-base type)) ; an union of values + (let ((base (soap-xs-simple-type-base type))) + (soap-sample-value (nth (random (length base)) base)))) + ((soap-xs-basic-type-p (soap-xs-simple-type-base type)) + (soap-sample-value (soap-xs-simple-type-base type)))))) + +(defun soap-sample-value-for-xs-complex-type (type) + "Provide a sample value for TYPE, a `soap-xs-complex-type'. +This is a specialization of `soap-sample-value' for +`soap-xs-complex-type' objects." + (append + (mapcar 'soap-sample-value-for-xs-attribute + (soap-xs-type-attributes type)) + (cl-case (soap-xs-complex-type-indicator type) + (array + (let* ((element-type (soap-xs-complex-type-base type)) + (sample1 (soap-sample-value element-type)) + (sample2 (soap-sample-value element-type))) + ;; Our sample value is a vector of two elements, but any number of + ;; elements are permissible + (vector sample1 sample2 '&etc))) + ((sequence choice all) + (let ((base (soap-xs-complex-type-base type))) + (let ((value (append (and base (soap-sample-value base)) + (mapcar #'soap-sample-value + (soap-xs-complex-type-elements type))))) + (if (eq (soap-xs-complex-type-indicator type) 'choice) + (cons '***choice-of*** value) + value))))))) + +(defun soap-sample-value-for-message (message) + "Provide a sample value for a WSDL MESSAGE. +This is a specialization of `soap-sample-value' for +`soap-message' objects." + ;; NOTE: parameter order is not considered. + (let (sample-value) + (dolist (part (soap-message-parts message)) + (push (soap-sample-value (cdr part)) sample-value)) + (nreverse sample-value))) + +(progn + ;; Install soap-sample-value methods for our types + (put (soap-type-of (make-soap-xs-basic-type)) + 'soap-sample-value + 'soap-sample-value-for-xs-basic-type) + + (put (soap-type-of (make-soap-xs-element)) + 'soap-sample-value + 'soap-sample-value-for-xs-element) + + (put (soap-type-of (make-soap-xs-attribute)) + 'soap-sample-value + 'soap-sample-value-for-xs-attribute) + + (put (soap-type-of (make-soap-xs-attribute)) + 'soap-sample-value + 'soap-sample-value-for-xs-attribute-group) + + (put (soap-type-of (make-soap-xs-simple-type)) + 'soap-sample-value + 'soap-sample-value-for-xs-simple-type) + + (put (soap-type-of (make-soap-xs-complex-type)) + 'soap-sample-value + 'soap-sample-value-for-xs-complex-type) + + (put (soap-type-of (make-soap-message)) + 'soap-sample-value + 'soap-sample-value-for-message)) + + + +;;; soap-inspect + +(defvar soap-inspect-previous-items nil + "A stack of previously inspected items in the *soap-inspect* buffer. +Used to implement the BACK button.") + +(defvar soap-inspect-current-item nil + "The current item being inspected in the *soap-inspect* buffer.") + +(progn + (make-variable-buffer-local 'soap-inspect-previous-items) + (make-variable-buffer-local 'soap-inspect-current-item)) + +(defun soap-inspect (element) + "Inspect a SOAP ELEMENT in the *soap-inspect* buffer. +The buffer is populated with information about ELEMENT with links +to its sub elements. If ELEMENT is the WSDL document itself, the +entire WSDL can be inspected." + (let ((inspect (get (soap-type-of element) 'soap-inspect))) + (unless inspect + (error "Soap-inspect: no inspector for element")) + + (with-current-buffer (get-buffer-create "*soap-inspect*") + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + + (when soap-inspect-current-item + (push soap-inspect-current-item + soap-inspect-previous-items)) + (setq soap-inspect-current-item element) + + (funcall inspect element) + + (unless (null soap-inspect-previous-items) + (insert "\n\n") + (insert-text-button + "[back]" + 'type 'soap-client-describe-back-link + 'item element) + (insert "\n")) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))))) + + +(define-button-type 'soap-client-describe-link + 'face 'link + 'help-echo "mouse-2, RET: describe item" + 'follow-link t + 'action (lambda (button) + (let ((item (button-get button 'item))) + (soap-inspect item))) + 'skip t) + +(define-button-type 'soap-client-describe-back-link + 'face 'link + 'help-echo "mouse-2, RET: browse the previous item" + 'follow-link t + 'action (lambda (_button) + (let ((item (pop soap-inspect-previous-items))) + (when item + (setq soap-inspect-current-item nil) + (soap-inspect item)))) + 'skip t) + +(defun soap-insert-describe-button (element) + "Insert a button to inspect ELEMENT when pressed." + (insert-text-button + (soap-element-fq-name element) + 'type 'soap-client-describe-link + 'item element)) + +(defun soap-inspect-xs-basic-type (type) + "Insert information about TYPE, a soap-xs-basic-type, in the current buffer." + (insert "Basic type: " (soap-element-fq-name type)) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + +(defun soap-inspect-xs-element (element) + "Insert information about ELEMENT, a soap-xs-element, in the current buffer." + (insert "Element: " (soap-element-fq-name element)) + (insert "\nType: ") + (soap-insert-describe-button (soap-xs-element-type element)) + (insert "\nAttributes:") + (when (soap-xs-element-optional? element) + (insert " optional")) + (when (soap-xs-element-multiple? element) + (insert " multiple")) + (insert "\nSample value:\n") + (pp (soap-sample-value element) (current-buffer))) + +(defun soap-inspect-xs-attribute (attribute) + "Insert information about ATTRIBUTE in the current buffer. +ATTRIBUTE is a soap-xs-attribute." + (insert "Attribute: " (soap-element-fq-name attribute)) + (insert "\nType: ") + (soap-insert-describe-button (soap-xs-attribute-type attribute)) + (insert "\nSample value:\n") + (pp (soap-sample-value attribute) (current-buffer))) + +(defun soap-inspect-xs-attribute-group (attribute-group) + "Insert information about ATTRIBUTE-GROUP in the current buffer. +ATTRIBUTE is a soap-xs-attribute-group." + (insert "Attribute group: " (soap-element-fq-name attribute-group)) + (insert "\nSample values:\n") + (pp (soap-sample-value attribute-group) (current-buffer))) + +(defun soap-inspect-xs-simple-type (type) + "Insert information about TYPE, a soap-xs-simple-type, in the current buffer." + (insert "Simple type: " (soap-element-fq-name type)) + (insert "\nBase: " ) + (if (listp (soap-xs-simple-type-base type)) + (let ((first-time t)) + (dolist (b (soap-xs-simple-type-base type)) + (unless first-time + (insert ", ") + (setq first-time nil)) + (soap-insert-describe-button b))) + (soap-insert-describe-button (soap-xs-simple-type-base type))) + (insert "\nAttributes: ") + (dolist (attribute (soap-xs-simple-type-attributes type)) + (let ((name (or (soap-xs-attribute-name attribute) "*inline*")) + (type (soap-xs-attribute-type attribute))) + (insert "\n\t") + (insert name) + (insert "\t") + (soap-insert-describe-button type))) + (when (soap-xs-simple-type-enumeration type) + (insert "\nEnumeration values: ") + (dolist (e (soap-xs-simple-type-enumeration type)) + (insert "\n\t") + (pp e))) + (when (soap-xs-simple-type-pattern type) + (insert "\nPattern: " (soap-xs-simple-type-pattern type))) + (when (car (soap-xs-simple-type-length-range type)) + (insert "\nMin length: " + (number-to-string (car (soap-xs-simple-type-length-range type))))) + (when (cdr (soap-xs-simple-type-length-range type)) + (insert "\nMin length: " + (number-to-string (cdr (soap-xs-simple-type-length-range type))))) + (when (car (soap-xs-simple-type-integer-range type)) + (insert "\nMin value: " + (number-to-string (car (soap-xs-simple-type-integer-range type))))) + (when (cdr (soap-xs-simple-type-integer-range type)) + (insert "\nMin value: " + (number-to-string (cdr (soap-xs-simple-type-integer-range type))))) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + +(defun soap-inspect-xs-complex-type (type) + "Insert information about TYPE in the current buffer. +TYPE is a `soap-xs-complex-type'" + (insert "Complex type: " (soap-element-fq-name type)) + (insert "\nKind: ") + (cl-case (soap-xs-complex-type-indicator type) + ((sequence all) + (insert "a sequence ") + (when (soap-xs-complex-type-base type) + (insert "extending ") + (soap-insert-describe-button (soap-xs-complex-type-base type))) + (insert "\nAttributes: ") + (dolist (attribute (soap-xs-complex-type-attributes type)) + (let ((name (or (soap-xs-attribute-name attribute) "*inline*")) + (type (soap-xs-attribute-type attribute))) + (insert "\n\t") + (insert name) + (insert "\t") + (soap-insert-describe-button type))) + (insert "\nElements: ") + (let ((name-width 0) + (type-width 0)) + (dolist (element (soap-xs-complex-type-elements type)) + (let ((name (or (soap-xs-element-name element) "*inline*")) + (type (soap-xs-element-type element))) + (setq name-width (max name-width (length name))) + (setq type-width + (max type-width (length (soap-element-fq-name type)))))) + (setq name-width (+ name-width 2)) + (setq type-width (+ type-width 2)) + (dolist (element (soap-xs-complex-type-elements type)) + (let ((name (or (soap-xs-element-name element) "*inline*")) + (type (soap-xs-element-type element))) + (insert "\n\t") + (insert name) + (insert (make-string (- name-width (length name)) ?\ )) + (soap-insert-describe-button type) + (insert + (make-string + (- type-width (length (soap-element-fq-name type))) ?\ )) + (when (soap-xs-element-multiple? element) + (insert " multiple")) + (when (soap-xs-element-optional? element) + (insert " optional")))))) + (choice + (insert "a choice ") + (when (soap-xs-complex-type-base type) + (insert "extending ") + (soap-insert-describe-button (soap-xs-complex-type-base type))) + (insert "\nElements: ") + (dolist (element (soap-xs-complex-type-elements type)) + (insert "\n\t") + (soap-insert-describe-button element))) + (array + (insert "an array of ") + (soap-insert-describe-button (soap-xs-complex-type-base type)))) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + + +(defun soap-inspect-message (message) + "Insert information about MESSAGE into the current buffer." + (insert "Message name: " (soap-element-fq-name message) "\n") + (insert "Parts:\n") + (dolist (part (soap-message-parts message)) + (insert "\t" (symbol-name (car part)) + " type: ") + (soap-insert-describe-button (cdr part)) + (insert "\n"))) + +(defun soap-inspect-operation (operation) + "Insert information about OPERATION into the current buffer." + (insert "Operation name: " (soap-element-fq-name operation) "\n") + (let ((input (soap-operation-input operation))) + (insert "\tInput: " (symbol-name (car input)) " (" ) + (soap-insert-describe-button (cdr input)) + (insert ")\n")) + (let ((output (soap-operation-output operation))) + (insert "\tOutput: " (symbol-name (car output)) " (") + (soap-insert-describe-button (cdr output)) + (insert ")\n")) + + (insert "\n\nSample invocation:\n") + (let ((sample-message-value + (soap-sample-value (cdr (soap-operation-input operation)))) + (funcall (list 'soap-invoke '*WSDL* "SomeService" + (soap-element-name operation)))) + (let ((sample-invocation + (append funcall (mapcar 'cdr sample-message-value)))) + (pp sample-invocation (current-buffer))))) + +(defun soap-inspect-port-type (port-type) + "Insert information about PORT-TYPE into the current buffer." + (insert "Port-type name: " (soap-element-fq-name port-type) "\n") + (insert "Operations:\n") + (cl-loop for o being the hash-values of + (soap-namespace-elements (soap-port-type-operations port-type)) + do (progn + (insert "\t") + (soap-insert-describe-button (car o))))) + +(defun soap-inspect-binding (binding) + "Insert information about BINDING into the current buffer." + (insert "Binding: " (soap-element-fq-name binding) "\n") + (insert "\n") + (insert "Bound operations:\n") + (let* ((ophash (soap-binding-operations binding)) + (operations (cl-loop for o being the hash-keys of ophash + collect o)) + op-name-width) + + (setq operations (sort operations 'string<)) + + (setq op-name-width (cl-loop for o in operations maximizing (length o))) + + (dolist (op operations) + (let* ((bound-op (gethash op ophash)) + (soap-action (soap-bound-operation-soap-action bound-op)) + (use (soap-bound-operation-use bound-op))) + (unless soap-action + (setq soap-action "")) + (insert "\t") + (soap-insert-describe-button (soap-bound-operation-operation bound-op)) + (when (or use (not (equal soap-action ""))) + (insert (make-string (- op-name-width (length op)) ?\s)) + (insert " (") + (insert soap-action) + (when use + (insert " " (symbol-name use))) + (insert ")")) + (insert "\n"))))) + +(defun soap-inspect-port (port) + "Insert information about PORT into the current buffer." + (insert "Port name: " (soap-element-name port) "\n" + "Service URL: " (soap-port-service-url port) "\n" + "Binding: ") + (soap-insert-describe-button (soap-port-binding port))) + +(defun soap-inspect-wsdl (wsdl) + "Insert information about WSDL into the current buffer." + (insert "WSDL Origin: " (soap-wsdl-origin wsdl) "\n") + (insert "Ports:") + (dolist (p (soap-wsdl-ports wsdl)) + (insert "\n--------------------\n") + ;; (soap-insert-describe-button p) + (soap-inspect-port p)) + (insert "\n--------------------\nNamespace alias table:\n") + (dolist (a (soap-wsdl-alias-table wsdl)) + (insert "\t" (car a) " => " (cdr a) "\n"))) + +(progn + ;; Install the soap-inspect methods for our types + + (put (soap-type-of (make-soap-xs-basic-type)) 'soap-inspect + 'soap-inspect-xs-basic-type) + + (put (soap-type-of (make-soap-xs-element)) 'soap-inspect + 'soap-inspect-xs-element) + + (put (soap-type-of (make-soap-xs-simple-type)) 'soap-inspect + 'soap-inspect-xs-simple-type) + + (put (soap-type-of (make-soap-xs-complex-type)) 'soap-inspect + 'soap-inspect-xs-complex-type) + + (put (soap-type-of (make-soap-xs-attribute)) 'soap-inspect + 'soap-inspect-xs-attribute) + + (put (soap-type-of (make-soap-xs-attribute-group)) 'soap-inspect + 'soap-inspect-xs-attribute-group) + + (put (soap-type-of (make-soap-message)) 'soap-inspect + 'soap-inspect-message) + (put (soap-type-of (make-soap-operation)) 'soap-inspect + 'soap-inspect-operation) + + (put (soap-type-of (make-soap-port-type)) 'soap-inspect + 'soap-inspect-port-type) + + (put (soap-type-of (make-soap-binding)) 'soap-inspect + 'soap-inspect-binding) + + (put (soap-type-of (make-soap-port)) 'soap-inspect + 'soap-inspect-port) + + (put (soap-type-of (soap-make-wsdl "origin")) 'soap-inspect + 'soap-inspect-wsdl)) + +(provide 'soap-inspect) +;;; soap-inspect.el ends here diff --git a/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-autoloads.el b/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-autoloads.el new file mode 100644 index 00000000..d6e2f3ce --- /dev/null +++ b/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-autoloads.el @@ -0,0 +1,50 @@ +;;; url-http-ntlm-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "url-http-ntlm" "url-http-ntlm.el" (0 0 0 0)) +;;; Generated autoloads from url-http-ntlm.el + +(autoload 'url-ntlm-auth "url-http-ntlm" "\ +Return an NTLM HTTP authorization header. +Get the contents of the Authorization header for a HTTP response +using NTLM authentication, to access URL. Because NTLM is a +two-step process, this function expects to be called twice, first +to generate the NTLM type 1 message (request), then to respond to +the server's type 2 message (challenge) with a suitable response. + +url-get-authentication' calls `url-ntlm-auth' once when checking +what authentication schemes are supported (PROMPT and ARGS are +nil), and then twice for every stage of the handshake: the first +time PROMPT is nil, the second, t; ARGS contains the server +response's \"WWW-Authenticate\" header, munged by +`url-parse-args'. + +If PROMPT is not t then this function just returns nil. This is +to avoid calculating responses twice. + +OVERWRITE and REALM are ignored. + +ARGS is expected to contain the WWW-Authentication header from +the server's last response. These are used by +`url-http-get-stage' to determine what stage we are at. + +\(fn URL &optional PROMPT OVERWRITE REALM ARGS)" nil nil) + +(url-register-auth-scheme "ntlm" nil 8) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "url-http-ntlm" '("url-http-ntlm--"))) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; url-http-ntlm-autoloads.el ends here diff --git a/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-pkg.el b/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-pkg.el new file mode 100644 index 00000000..f90ca99d --- /dev/null +++ b/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm-pkg.el @@ -0,0 +1,2 @@ +;;; -*- no-byte-compile: t -*- +(define-package "url-http-ntlm" "2.0.4" "NTLM authentication for the url library" '((cl-lib "0.5") (ntlm "2.1.0")) :url "http://elpa.gnu.org/packages/url-http-ntlm.html" :keywords '("comm" "data" "processes" "hypermedia")) diff --git a/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm.el b/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm.el new file mode 100644 index 00000000..cbc152fb --- /dev/null +++ b/.local/elpa/url-http-ntlm-2.0.4/url-http-ntlm.el @@ -0,0 +1,618 @@ +;;; url-http-ntlm.el --- NTLM authentication for the url library + +;; Copyright (C) 2008, 2016 Free Software Foundation, Inc. + +;; Author: Tom Schutzer-Weissmann +;; Maintainer: Thomas Fitzsimmons +;; Version: 2.0.4 +;; Keywords: comm, data, processes, hypermedia +;; Homepage: https://code.google.com/p/url-http-ntlm/ +;; Package-Requires: ((cl-lib "0.5") (ntlm "2.1.0")) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: +;; +;; This package provides a NTLM handler for the URL package. +;; +;; Installation: +;; +;; M-x package-install RET url-http-ntlm RET +;; +;; Acknowledgements: +;; +;; Taro Kawagishi wrote ntlm.el and md4.el, +;; which are parts of FLIM (Faithful Library about Internet Message). +;; +;; http://stuff.mit.edu/afs/sipb/contrib/emacs/packages/flim-1.14.7/ntlm.el +;; http://stuff.mit.edu/afs/sipb/contrib/emacs/packages/flim-1.14.7/md4.el + +;;; Code: +(require 'url-auth) +(require 'url-http) +(require 'url-util) +(require 'mail-parse) +(require 'cl-lib) +(require 'ntlm) + +;; Remove authorization after redirect. +(when (and (boundp 'emacs-major-version) + (< emacs-major-version 25)) + (defvar url-http-ntlm--parsing-headers nil) + (defadvice url-http-parse-headers (around clear-authorization activate) + (let ((url-http-ntlm--parsing-headers t)) + ad-do-it)) + (defadvice url-http-handle-authentication (around clear-authorization + activate) + (let ((url-http-ntlm--parsing-headers nil)) + ad-do-it)) + (defadvice url-retrieve-internal (before clear-authorization activate) + (when (and url-http-ntlm--parsing-headers + (eq url-request-extra-headers url-http-extra-headers)) + ;; This retrieval is presumably in response to a redirect. + ;; Do not automatically include an authorization header in the + ;; redirect. If needed it will be regenerated by the relevant + ;; auth scheme when the new request happens. + (setq url-http-extra-headers + (cl-remove "Authorization" + url-http-extra-headers :key #'car :test #'equal)) + (setq url-request-extra-headers url-http-extra-headers)))) + + +;;; Private variables. +(defvar url-http-ntlm--auth-storage nil + "Authentication storage. +An alist that maps a server name to a pair of \( \). + +The hashes are built using `ntlm-get-password-hashes'.") + +(defvar url-http-ntlm--last-args nil + "The last `url-http-ntlm--get-stage' arguments and result. +This is used to detect multiple calls.") +(make-variable-buffer-local 'url-http-ntlm--last-args) + +(defvar url-http-ntlm--loop-timer-counter nil + "A hash table used to detect NTLM negotiation errors. +Keys are urls, entries are (START-TIME . COUNTER).") + +(defvar url-http-ntlm--default-users nil + "An alist that stores one default username per server.") + + +;;; Private functions. +(defun url-http-ntlm--detect-loop (url) + "Detect potential infinite loop when NTLM fails on URL." + (when (not url-http-ntlm--loop-timer-counter) + (setq url-http-ntlm--loop-timer-counter (make-hash-table :test 'equal))) + (let* ((url-string (url-recreate-url url)) + (last-entry (gethash url-string url-http-ntlm--loop-timer-counter)) + (start-time (car last-entry)) + (counter (cdr last-entry))) + (if last-entry + (progn + (if (< (- (float-time) start-time) 10.0) + (if (< counter 20) + ;; Still within time window, so increment count. + (puthash url-string (cons start-time (1+ counter)) + url-http-ntlm--loop-timer-counter) + ;; Error detected, so remove entry and clear. + (url-http-ntlm--authorization url-string :clear) + (remhash url-string url-http-ntlm--loop-timer-counter) + (error + (format (concat "Access rate to %s is too high," + " indicating an NTLM failure;" + " to debug, re-run with url-debug set to 1") + url-string))) + ;; Timeout expired, so reset counter. + (puthash url-string (cons (float-time) 0) + url-http-ntlm--loop-timer-counter))) + ;; New access, so initialize counter to 0. + (puthash url-string (cons (float-time) 0) + url-http-ntlm--loop-timer-counter)))) + +(defun url-http-ntlm--ensure-user (url) + "Return URL with its user slot set. +If URL's user slot is nil, set it to the last user that made a +request to the host in URL's server slot." + (let ((new-url url)) + (if (url-user new-url) + new-url + (setf (url-user new-url) + (cdr (assoc (url-host new-url) url-http-ntlm--default-users))) + new-url))) + +(defun url-http-ntlm--ensure-keepalive () + "Report an error if `url-http-attempt-keepalives' is not set." + (cl-assert url-http-attempt-keepalives + nil + (concat "NTLM authentication won't work unless" + " `url-http-attempt-keepalives' is set!"))) + +(defun url-http-ntlm--clean-headers () + "Remove Authorization element from `url-http-extra-headers' alist." + (cl-declare (special url-http-extra-headers)) + (setq url-http-extra-headers + (url-http-ntlm--rmssoc "Authorization" url-http-extra-headers))) + +(defun url-http-ntlm--get-stage (args) + "Determine what stage of the NTLM handshake we are at. +ARGS comes from `url-ntlm-auth''s caller, +`url-get-authentication'. Its meaning depends on the current +implementation -- this function is well and truly coupled." + (cl-declare (special url-http-extra-headers)) + (let* ((response-rxp "^NTLM TlRMTVNTUAADAAA") + (challenge-rxp "^TLRMTVNTUAACAAA") + (auth-header (assoc "Authorization" url-http-extra-headers)) + (case-fold-search t) + stage) + (url-debug 'url-http-ntlm "Buffer: %s" (current-buffer)) + (url-debug 'url-http-ntlm "Arguments: %s" args) + (url-debug 'url-http-ntlm "Previous arguments: %s" url-http-ntlm--last-args) + (if (eq args (car url-http-ntlm--last-args)) + ;; multiple calls, return the same argument we returned last time + (progn + (url-debug 'url-http-ntlm "Returning previous result: %s" + (cdr url-http-ntlm--last-args)) + (cdr url-http-ntlm--last-args)) + (let ((stage + (cond ((and auth-header (string-match response-rxp + (cdr auth-header))) + :error) + ((and (= (length args) 2) + (cl-destructuring-bind (challenge ntlm) args + (and (string-equal "ntlm" (car ntlm)) + (string-match challenge-rxp + (car challenge))))) + :response) + (t + :request)))) + (url-http-ntlm--clean-headers) + (setq url-http-ntlm--last-args (cons args stage)) + stage)))) + +(defun url-http-ntlm--authorization (url &optional clear realm) + "Get or clear NTLM authentication details for URL. +If CLEAR is non-nil, clear any saved credentials for server. +Otherwise, return the credentials, prompting the user if +necessary. REALM appears in the prompt. + +If URL contains a username and a password, they are used and +stored credentials are not affected." + (let* ((href (if (stringp url) + (url-generic-parse-url url) + url)) + (type (url-type href)) + (user (url-user href)) + (server (url-host href)) + (port (url-portspec href)) + (pass (url-password href)) + (stored (assoc (list type user server port) + url-http-ntlm--auth-storage)) + (both (and user pass))) + (if clear + ;; clear + (unless both + (setq url-http-ntlm--default-users + (url-http-ntlm--rmssoc server url-http-ntlm--default-users)) + (setq url-http-ntlm--auth-storage + (url-http-ntlm--rmssoc '(type user* server port) + url-http-ntlm--auth-storage)) + nil) + ;; get + (if (or both + (and stored user (not (equal user (cl-second (car stored))))) + (not stored)) + (let* ((user* (or user + (url-do-auth-source-search server type :user) + (read-string (url-auth-user-prompt url realm) + (or user (user-real-login-name))))) + (pass* (if both + pass + (or (url-do-auth-source-search server type :secret) + (read-passwd (format "Password [for %s]: " + (url-recreate-url url)))))) + (key (list type user* server port)) + (entry `(,key . (,(ntlm-get-password-hashes pass*))))) + (unless both + (setq url-http-ntlm--default-users + (cons + `(,server . ,user*) + (url-http-ntlm--rmssoc server + url-http-ntlm--default-users))) + (setq url-http-ntlm--auth-storage + (cons entry + (url-http-ntlm--rmssoc + key + url-http-ntlm--auth-storage)))) + entry) + stored)))) + +(defun url-http-ntlm--get-challenge () + "Return the NTLM Type-2 message in the WWW-Authenticate header. +Return nil if the NTLM Type-2 message is not present." + (save-restriction + (mail-narrow-to-head) + (let ((www-authenticate (mail-fetch-field "www-authenticate"))) + (when (string-match "NTLM\\s-+\\(\\S-+\\)" + www-authenticate) + (base64-decode-string (match-string 1 www-authenticate)))))) + +(defun url-http-ntlm--rmssoc (key alist) + "Remove all elements whose `car' match KEY from ALIST." + (cl-remove key alist :key 'car :test 'equal)) + +(defun url-http-ntlm--string (data) + "Return DATA encoded as an NTLM string." + (concat "NTLM " (base64-encode-string data :nobreak))) + + +;;; Public function called by `url-get-authentication'. +;;;###autoload +(defun url-ntlm-auth (url &optional prompt overwrite realm args) + "Return an NTLM HTTP authorization header. +Get the contents of the Authorization header for a HTTP response +using NTLM authentication, to access URL. Because NTLM is a +two-step process, this function expects to be called twice, first +to generate the NTLM type 1 message (request), then to respond to +the server's type 2 message (challenge) with a suitable response. + +url-get-authentication' calls `url-ntlm-auth' once when checking +what authentication schemes are supported (PROMPT and ARGS are +nil), and then twice for every stage of the handshake: the first +time PROMPT is nil, the second, t; ARGS contains the server +response's \"WWW-Authenticate\" header, munged by +`url-parse-args'. + +If PROMPT is not t then this function just returns nil. This is +to avoid calculating responses twice. + +OVERWRITE and REALM are ignored. + +ARGS is expected to contain the WWW-Authentication header from +the server's last response. These are used by +`url-http-get-stage' to determine what stage we are at." + (when (eq prompt t) + (url-http-ntlm--ensure-keepalive) + (let* ((user-url (url-http-ntlm--ensure-user url)) + (stage (url-http-ntlm--get-stage args))) + (url-debug 'url-http-ntlm "Stage: %s" stage) + (cl-case stage + ;; NTLM Type 1 message: the request + (:request + (url-http-ntlm--detect-loop user-url) + (cl-destructuring-bind (&optional key hash) + (url-http-ntlm--authorization user-url nil realm) + (when (cl-third key) + (url-http-ntlm--string + ;; Match Mozilla behavior by omitting user and domain + ;; from Type 1 message. + (ntlm-build-auth-request nil))))) + ;; NTLM Type 3 message: the response + (:response + (url-http-ntlm--detect-loop user-url) + (let ((challenge (url-http-ntlm--get-challenge))) + (cl-destructuring-bind (key hash) + (url-http-ntlm--authorization user-url nil realm) + (url-http-ntlm--string + (ntlm-build-auth-response challenge + (cl-second key) + hash))))) + (:error + (url-http-ntlm--authorization user-url :clear)))))) + + +;;; Register `url-ntlm-auth' HTTP authentication method. +;;;###autoload +(url-register-auth-scheme "ntlm" nil 8) + +;;;; ChangeLog: + +;; 2017-08-14 Thomas Fitzsimmons +;; +;; url-http-ntlm: Bump version to 2.0.4 +;; +;; * packages/url-http-ntlm/url-http-ntlm.el: Bump version to 2.0.4. +;; +;; 2017-08-14 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Omit user and domain in Type 1 message +;; +;; * packages/url-http-ntlm/url-http-ntlm.el (url-ntlm-auth): Omit user and +;; domain in Type 1 message. +;; +;; 2016-10-05 Thomas Fitzsimmons +;; +;; url-http-ntlm: Bump version to 2.0.3 +;; +;; * packages/url-http-ntlm/url-http-ntlm.el: Bump version to 2.0.3. +;; +;; 2016-10-05 Thomas Fitzsimmons +;; +;; url-http-ntlm: Bump ntlm required version to 2.1.0 +;; +;; 2016-10-05 Thomas Fitzsimmons +;; +;; url-http-ntlm: Avoid calculating responses twice +;; +;; * packages/url-http-ntlm/url-http-ntlm.el +;; (url-http-ntlm--get-stage): Update docstring. +;; (url-ntlm-auth): Return immediately if prompt is not t. Update +;; docstring. +;; +;; 2016-07-11 Paul Eggert +;; +;; Fix some quoting problems in doc strings +;; +;; Most of these are minor issues involving, e.g., quoting `like this' +;; instead of 'like this'. A few involve escaping ` and ' with a preceding +;; \= when the characters should not be turned into curved single quotes. +;; +;; 2016-02-21 Thomas Fitzsimmons +;; +;; url-http-ntlm: Bump version to 2.0.2 +;; +;; * packages/url-http-ntlm/url-http-ntlm.el: Bump version to 2.0.2. +;; +;; 2016-02-21 Stefan Monnier +;; +;; Remove url-http-ntlm-parse-header-NN.MM.el files +;; +;; * packages/url-http-ntlm/url-http-ntlm.el: Add advice around +;; url-http-parse-headers, url-http-handle-authentication and +;; url-retrieve-internal to clear HTTP Authorization header. +;; * packages/url-http-ntlm/url-http-ntlm-parse-headers-24.1.el, +;; packages/url-http-ntlm/url-http-ntlm-parse-headers-24.2.el, +;; packages/url-http-ntlm/url-http-ntlm-parse-headers-24.3.el, +;; packages/url-http-ntlm/url-http-ntlm-parse-headers-24.4.el, +;; packages/url-http-ntlm/url-http-ntlm-parse-headers-24.5.el: Remove +;; files. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Bump version to 2.0.1 +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Update copyright years +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Bump version to 2.0.0 +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Add cl-lib to Package-Requires +;; +;; * url-http-ntlm.el: Add cl-lib to Package-Requires. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Add `url-debug' debugging messages +;; +;; * url-http-ntlm.el: Require url-util. +;; (url-http-ntlm--get-stage, url-ntlm-auth): Add debugging messages. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Shorten first line of some docstrings +;; +;; * url-http-ntlm.el (url-http-ntlm--last-args) +;; (url-http-ntlm--default-users, url-http-ntlm--get-challenge): Shorten +;; first line of documentation string. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Require ntlm 2.0.0 +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Change spelling of authorization function +;; +;; * url-http-ntlm.el (url-http-ntlm--detect-loop): Update call to +;; url-http-ntlm--authorization. +;; (url-http-ntlm--authorization): Rename from +;; url-http-ntlm--authorisation. +;; (url-ntlm-auth): Update call to url-http-ntlm--authorization. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Add home page header +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Add auth-source support +;; +;; * url-http-ntlm.el (url-http-ntlm--authorisation): Try to read user and +;; password using auth-source library. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Autoload url-ntlm-auth and its registration +;; +;; * url-http-ntlm.el Autoload call to url-register-auth-scheme. +;; (url-ntlm-auth): Autoload function. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Declare url-http-extra-headers special +;; +;; * url-http-ntlm.el (url-http-ntlm--clean-headers): Declare +;; url-http-extra-headers special. +;; (url-http-ntlm--get-stage): Likewise. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Remove limit of one username and password per server +;; +;; * url-http-ntlm.el: Remove comment about only supporting one username +;; and password. Do not make url-http-ntlm--last-args a buffer-local +;; variable. +;; (url-http-ntlm--auth-storage): Change docstring to not mention one user +;; and password limitation. +;; (url-http-ntlm--default-users): New variable. +;; (url-http-ntlm--ensure-user): New function. +;; (url-http-ntlm--get-stage): Take a url argument. Store a key in +;; url-http-ntlm--last-args. +;; (url-http-ntlm--authorisation): Take a realm argument. Use a key when +;; accessing url-http-ntlm--last-args. +;; (url-ntlm-auth): Ensure the received URL has its user slot set before +;; processing it. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Prevent infinite loops +;; +;; * url-http-ntlm.el (url-http-ntlm--loop-timer-counter): New variable. +;; (url-http-ntlm--detect-loop): New function. +;; (url-ntlm-auth): Call url-http-ntlm--detect-loop before handling a +;; request or response. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Override url-http-parse-headers redirect handling +;; +;; * url-http-ntlm.el: Require versioned url-http-ntlm-parse-headers +;; feature when emacs-major-version is less than 25. +;; * url-http-ntlm-parse-headers-24.1.el, +;; url-http-ntlm-parse-headers-24.2.el, +;; url-http-ntlm-parse-headers-24.3.el, +;; url-http-ntlm-parse-headers-24.4.el, +;; url-http-ntlm-parse-headers-24.5.el: New files. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Port to cl-lib +;; +;; * url-http-ntlm.el: Require cl-lib. +;; (url-http-ntlm--ensure-keepalive): Use cl-assert. +;; (url-http-ntlm--get-stage): Use cl-destructuring-bind. +;; (url-http-ntlm--authorisation): Use cl-second. +;; (url-http-ntlm--rmssoc): Use cl-remove. +;; (url-ntlm-auth): Use cl-case and cl-destructuring-bind. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Add comment headings +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Use double dash naming convention for private symbols +;; +;; * url-http-ntlm.el (url-http-ntlm--auth-storage): Rename from +;; url-http-ntlm-auth-storage. +;; (url-http-ntlm-last-args): Rename from url-http-ntlm-last-args. +;; (url-http-ntlm--ensure-keepalive): Rename from +;; url-http-ntlm-ensure-keepalive. +;; (url-http-ntlm--clean-headers): Rename from url-http-ntlm-clean-headers. +;; Update private function calls. +;; (url-http-ntlm--get-stage): Rename from url-http-ntlm-get-stage. Update +;; private function calls and variable references. +;; (url-http-ntlm--authorisation): Rename from url-http-ntlm-authorisation. +;; Update private function calls and variable references. +;; (url-http-ntlm--get-challenge): Rename from url-http-ntlm-get-challenge. +;; (url-http-ntlm--rmssoc): Rename from url-http-ntlm-rmssoc. +;; (url-http-ntlm--string): Rename from url-http-ntlm-string. +;; (url-ntlm-auth): Update private function calls and variable references. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el (url-http-ntlm-last-args): Group defvar with others +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el (url-ntlm-auth): Move defun near end of file +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Use url-http-ntlm namespace consistently +;; +;; * url-http-ntlm.el (url-ntlm-auth): Call url-http-ntlm-ensure-keepalive +;; and url-http-ntlm-get-stage. +;; (url-http-ntlm-ensure-keepalive): Rename from url-ntlm-ensure-keepalive. +;; (url-http-ntlm-clean-headers): Rename from url-ntlm-clean-headers. +;; (url-http-ntlm-last-args): Rename from url-ntlm-last-args. +;; (url-http-ntlm-get-stage): Rename from url-ntlm-get-stage. +;; (url-http-ntlm-get-stage): Reference url-http-ntlm-last-args. Call +;; url-http-ntlm-clean-headers. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Update author's email address +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Update installation instructions +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Add maintainer header +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Update copyright owner and years +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Reindent whole file +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Remove blank comment lines +;; +;; * url-http-ntlm.el (url-ntlm-auth, url-ntlm-get-stage): Remove blank +;; comment lines. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Fix checkdoc errors +;; +;; * url-http-ntlm.el (url-http-ntlm-auth-storage, url-ntlm-auth) +;; (url-ntlm-ensure-keepalive, url-ntlm-clean-headers) +;; (url-ntlm-get-stage, url-http-ntlm-authorisation) +;; (url-http-ntlm-get-challenge, url-http-ntlm-rmssoc) +;; (url-http-ntlm-string): Fix checkdoc errors. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Wrap lines at column 80 +;; +;; * url-http-ntlm.el (url-ntlm-ensure-keepalive, url-ntlm-last-args) +;; (url-ntlm-get-stage, url-http-ntlm-authorisation): Wrap lines at column +;; 80. +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm.el: Adjust blank lines +;; +;; 2016-02-17 Thomas Fitzsimmons +;; +;; url-http-ntlm: Remove trailing whitespace +;; +;; * url-http-ntlm.el (url-http-ntlm-authorisation): Remove trailing +;; whitespace. +;; +;; 2016-02-17 Tom Schutzer-Weissmann +;; +;; url-http-ntlm: New package +;; +;; * url-http-ntlm.el: Import from +;; https://url-http-ntlm.googlecode.com/svn/trunk/url-http-ntlm.el, +;; revision r2. +;; + + +(provide 'url-http-ntlm) + +;;; url-http-ntlm.el ends here diff --git a/excorporate/diary-excorporate-today b/excorporate/diary-excorporate-today new file mode 100644 index 00000000..e69de29b diff --git a/excorporate/diary-excorporate-transient b/excorporate/diary-excorporate-transient new file mode 100644 index 00000000..e69de29b