From 673026e59ce120808f3bca133c3c43a34a134d23 Mon Sep 17 00:00:00 2001 From: Thomas Fitzsimmons Date: Sun, 21 Feb 2016 19:43:52 -0500 Subject: [PATCH] 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. --- packages/excorporate/README | 20 + packages/excorporate/excorporate-calendar.el | 46 + packages/excorporate/excorporate-calfw.el.txt | 128 +++ packages/excorporate/excorporate-org.el | 141 ++++ packages/excorporate/excorporate.el | 786 ++++++++++++++++++ 5 files changed, 1121 insertions(+) create mode 100644 packages/excorporate/README create mode 100644 packages/excorporate/excorporate-calendar.el create mode 100644 packages/excorporate/excorporate-calfw.el.txt create mode 100644 packages/excorporate/excorporate-org.el create mode 100644 packages/excorporate/excorporate.el diff --git a/packages/excorporate/README b/packages/excorporate/README new file mode 100644 index 000000000..7389a880b --- /dev/null +++ b/packages/excorporate/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/packages/excorporate/excorporate-calendar.el b/packages/excorporate/excorporate-calendar.el new file mode 100644 index 000000000..506ac7241 --- /dev/null +++ b/packages/excorporate/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/packages/excorporate/excorporate-calfw.el.txt b/packages/excorporate/excorporate-calfw.el.txt new file mode 100644 index 000000000..ad31ae971 --- /dev/null +++ b/packages/excorporate/excorporate-calfw.el.txt @@ -0,0 +1,128 @@ +;;; 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: + +(require 'calfw) +(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) + (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) + (declare (special cfw:component)) + (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) + (declare (special cfw:component)) + (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/packages/excorporate/excorporate-org.el b/packages/excorporate/excorporate-org.el new file mode 100644 index 000000000..8613f8e9c --- /dev/null +++ b/packages/excorporate/excorporate-org.el @@ -0,0 +1,141 @@ +;;; 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) + (org-mode) + (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)) + (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/packages/excorporate/excorporate.el b/packages/excorporate/excorporate.el new file mode 100644 index 000000000..80f3c33bd --- /dev/null +++ b/packages/excorporate/excorporate.el @@ -0,0 +1,786 @@ +;;; excorporate.el --- Exchange integration -*- lexical-binding: t -*- + +;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + +;; Author: Thomas Fitzsimmons +;; Maintainer: Thomas Fitzsimmons +;; Created: 2014-09-19 +;; Version: 0.7.0 +;; Keywords: calendar +;; Homepage: https://www.fitzsim.org/blog/ +;; Package-Requires: ((emacs "24.1") (fsm "0.2") (soap-client "3.0.2") (url-http-ntlm "2.0.2")) + +;; 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. + +;;; Code: + +;; Implementation-visible functions and variables. + +;; Add NTLM authorization scheme. +(require 'url-http-ntlm) +(require 'soap-client) +(require 'fsm) +(require 'excorporate-calendar) + +(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))) + (url-retrieve (concat service-url "?wsdl") + (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" + service-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." + (catch 'found + (dolist (attribute + (soap-xs-type-attributes + (soap-xs-element-type + (soap-wsdl-get + '("http://schemas.microsoft.com/exchange/services/2006/types" + . "RequestServerVersion") + wsdl 'soap-xs-element-p)))) + (when (equal (soap-xs-attribute-name attribute) "Version") + (throw 'found (soap-xs-attribute-default attribute)))) + (warn "Excorporate: Failed to determine server version") + 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-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 '())) + (dolist (calendar-item (exco-extract-value '(ResponseMessages + FindItemResponseMessage + RootFolder + Items) + response)) + (let* ((subject (cdr (assoc 'Subject calendar-item))) + (start (cdr (assoc 'Start calendar-item))) + (start-internal (apply #'encode-time + (soap-decode-date-time + start 'dateTime))) + (end (cdr (assoc 'End calendar-item))) + (end-internal (apply #'encode-time + (soap-decode-date-time + end 'dateTime))) + (location (cdr (assoc 'Location calendar-item))) + (to-invitees (cdr (assoc 'DisplayTo calendar-item))) + (main-invitees (mapcar 'org-trim (split-string to-invitees ";"))) + (cc-invitees (cdr (assoc 'DisplayCc calendar-item))) + (optional-invitees (when cc-invitees + (mapcar 'org-trim + (split-string cc-invitees ";"))))) + (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. + ((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 ((server-major-version + (string-to-number + (substring (exco-server-version identifier) 8 12)))) + (cond + ((<= server-major-version 2007) + '(nil nil nil nil)) + ((< server-major-version 2013) + '(nil nil nil nil nil)) + (t + '(nil nil nil nil nil nil))))) + callback))) + +(defun exco-connection-iterate (initialize-function + per-connection-function + per-connection-callback + finalize-function) + "Iterate Excorporate connections. +Call INITIALIZE-FUNCTION once before iterating. +Call PER-CONNECTION-FUNCTION for each connection. +Pass PER-CONNECTION-CALLBACK to PER-CONNECTION-FUNCTION. +Call FINALIZE-FUNCTION after all operations have responded." + (exco--ensure-connection) + (funcall initialize-function) + (let ((responses 0) + (connection-count (length exco--connection-identifiers))) + (dolist (identifier exco--connection-identifiers) + (funcall per-connection-function identifier + (lambda (&rest arguments) + (setq responses (1+ responses)) + (apply per-connection-callback arguments) + (when (equal responses connection-count) + (funcall finalize-function))))))) + +;; 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 -- 2.39.2