cgit.sxemacs.org Git - gnus/blob - lisp/gnus-icalendar.el

   1 ;;; gnus-icalendar.el --- reply to iCalendar meeting requests
   2
   3 ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Jan Tatarik <Jan.Tatarik@gmail.com>
   6 ;; Keywords: mail, icalendar, org
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;; To install:
  24 ;; (require 'gnus-icalendar)
  25 ;; (gnus-icalendar-setup)
  26
  27 ;; to enable optional iCalendar->Org sync functionality
  28 ;; NOTE: both the capture file and the headline(s) inside must already exist
  29 ;; (setq gnus-icalendar-org-capture-file "~/org/notes.org")
  30 ;; (setq gnus-icalendar-org-capture-headline '("Calendar"))
  31 ;; (gnus-icalendar-org-setup)
  32
  33
  34 ;;; Code:
  35
  36 (require 'icalendar)
  37 (require 'eieio)
  38 (require 'gmm-utils)
  39 (require 'mm-decode)
  40 (require 'gnus-sum)
  41 (require 'gnus-art)
  42
  43 (eval-when-compile (require 'cl))
  44
  45 (defun gnus-icalendar-find-if (pred seq)
  46   (catch 'found
  47     (while seq
  48       (when (funcall pred (car seq))
  49         (throw 'found (car seq)))
  50       (pop seq))))
  51
  52 ;;;
  53 ;;; ical-event
  54 ;;;
  55
  56 (defclass gnus-icalendar-event ()
  57   ((organizer :initarg :organizer
  58               :accessor gnus-icalendar-event:organizer
  59               :initform ""
  60               :type (or null string))
  61    (summary :initarg :summary
  62             :accessor gnus-icalendar-event:summary
  63             :initform ""
  64             :type (or null string))
  65    (description :initarg :description
  66                 :accessor gnus-icalendar-event:description
  67                 :initform ""
  68                 :type (or null string))
  69    (location :initarg :location
  70              :accessor gnus-icalendar-event:location
  71              :initform ""
  72              :type (or null string))
  73    (start-time :initarg :start-time
  74           :accessor gnus-icalendar-event:start-time
  75           :initform ""
  76           :type (or null t))
  77    (end-time :initarg :end-time
  78         :accessor gnus-icalendar-event:end-time
  79         :initform ""
  80         :type (or null t))
  81    (recur :initarg :recur
  82           :accessor gnus-icalendar-event:recur
  83           :initform ""
  84           :type (or null string))
  85    (uid :initarg :uid
  86         :accessor gnus-icalendar-event:uid
  87         :type string)
  88    (method :initarg :method
  89            :accessor gnus-icalendar-event:method
  90            :initform "PUBLISH"
  91            :type (or null string))
  92    (rsvp :initarg :rsvp
  93          :accessor gnus-icalendar-event:rsvp
  94          :initform nil
  95          :type (or null boolean))
  96    (participation-type :initarg :participation-type
  97          :accessor gnus-icalendar-event:participation-type
  98          :initform 'non-participant
  99          :type (or null t))
 100    (req-participants :initarg :req-participants
 101          :accessor gnus-icalendar-event:req-participants
 102          :initform nil
 103          :type (or null t))
 104    (opt-participants :initarg :opt-participants
 105          :accessor gnus-icalendar-event:opt-participants
 106          :initform nil
 107          :type (or null t)))
 108   "generic iCalendar Event class")
 109
 110 (defclass gnus-icalendar-event-request (gnus-icalendar-event)
 111   nil
 112   "iCalendar class for REQUEST events")
 113
 114 (defclass gnus-icalendar-event-cancel (gnus-icalendar-event)
 115   nil
 116   "iCalendar class for CANCEL events")
 117
 118 (defclass gnus-icalendar-event-reply (gnus-icalendar-event)
 119   nil
 120   "iCalendar class for REPLY events")
 121
 122 (defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event))
 123   "Return t if EVENT is recurring."
 124   (not (null (gnus-icalendar-event:recur event))))
 125
 126 (defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event))
 127   "Return recurring frequency of EVENT."
 128   (let ((rrule (gnus-icalendar-event:recur event)))
 129     (string-match "FREQ=\\([[:alpha:]]+\\)" rrule)
 130     (match-string 1 rrule)))
 131
 132 (defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
 133   "Return recurring interval of EVENT."
 134   (let ((rrule (gnus-icalendar-event:recur event))
 135         (default-interval 1))
 136
 137     (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
 138     (or (match-string 1 rrule)
 139         default-interval)))
 140
 141 (defmethod gnus-icalendar-event:start ((event gnus-icalendar-event))
 142   (format-time-string "%Y-%m-%d %H:%M" (gnus-icalendar-event:start-time event)))
 143
 144 (defun gnus-icalendar-event--decode-datefield (event field zone-map)
 145   (let* ((dtdate (icalendar--get-event-property event field))
 146          (dtdate-zone (icalendar--find-time-zone
 147                        (icalendar--get-event-property-attributes
 148                         event field) zone-map))
 149          (dtdate-dec (icalendar--decode-isodatetime dtdate nil dtdate-zone)))
 150     (apply 'encode-time dtdate-dec)))
 151
 152 (defun gnus-icalendar-event--find-attendee (ical name-or-email)
 153   (let* ((event (car (icalendar--all-events ical)))
 154          (event-props (caddr event)))
 155     (gmm-labels ((attendee-name (att) (plist-get (cadr att) 'CN))
 156                  (attendee-email (att)
 157                    (replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
 158                  (attendee-prop-matches-p (prop)
 159                    (and (eq (car prop) 'ATTENDEE)
 160                         (or (member (attendee-name prop) name-or-email)
 161                             (let ((att-email (attendee-email prop)))
 162                               (gnus-icalendar-find-if (lambda (email)
 163                                                         (string-match email att-email))
 164                                                       name-or-email))))))
 165
 166       (gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
 167
 168 (defun gnus-icalendar-event--get-attendee-names (ical)
 169   (let* ((event (car (icalendar--all-events ical)))
 170          (attendee-props (gnus-remove-if-not
 171                           (lambda (p) (eq (car p) 'ATTENDEE))
 172                           (caddr event))))
 173
 174     (gmm-labels ((attendee-role (prop) (plist-get (cadr prop) 'ROLE))
 175                  (attendee-name (prop)
 176                                 (or (plist-get (cadr prop) 'CN)
 177                                     (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop))))
 178                  (attendees-by-type (type)
 179                    (gnus-remove-if-not
 180                     (lambda (p) (string= (attendee-role p) type))
 181                     attendee-props))
 182                  (attendee-names-by-type (type)
 183                     (mapcar #'attendee-name (attendees-by-type type))))
 184
 185       (list
 186        (attendee-names-by-type "REQ-PARTICIPANT")
 187        (attendee-names-by-type "OPT-PARTICIPANT")))))
 188
 189 (defun gnus-icalendar-event-from-ical (ical &optional attendee-name-or-email)
 190   (let* ((event (car (icalendar--all-events ical)))
 191          (organizer (replace-regexp-in-string
 192                      "^.*MAILTO:" ""
 193                      (or (icalendar--get-event-property event 'ORGANIZER) "")))
 194          (prop-map '((summary . SUMMARY)
 195                      (description . DESCRIPTION)
 196                      (location . LOCATION)
 197                      (recur . RRULE)
 198                      (uid . UID)))
 199          (method (caddr (assoc 'METHOD (caddr (car (nreverse ical))))))
 200          (attendee (when attendee-name-or-email
 201                      (gnus-icalendar-event--find-attendee ical attendee-name-or-email)))
 202          (attendee-names (gnus-icalendar-event--get-attendee-names ical))
 203          (role (plist-get (cadr attendee) 'ROLE))
 204          (participation-type (pcase role
 205                               ("REQ-PARTICIPANT" 'required)
 206                               ("OPT-PARTICIPANT" 'optional)
 207                               (_                 'non-participant)))
 208          (zone-map (icalendar--convert-all-timezones ical))
 209          (args (list :method method
 210                      :organizer organizer
 211                      :start-time (gnus-icalendar-event--decode-datefield event 'DTSTART zone-map)
 212                      :end-time (gnus-icalendar-event--decode-datefield event 'DTEND zone-map)
 213                      :rsvp (string= (plist-get (cadr attendee) 'RSVP) "TRUE")
 214                      :participation-type participation-type
 215                      :req-participants (car attendee-names)
 216                      :opt-participants (cadr attendee-names)))
 217          (event-class (cond
 218                        ((string= method "REQUEST") 'gnus-icalendar-event-request)
 219                        ((string= method "CANCEL") 'gnus-icalendar-event-cancel)
 220                        ((string= method "REPLY") 'gnus-icalendar-event-reply)
 221                        (t 'gnus-icalendar-event))))
 222
 223     (gmm-labels ((map-property (prop)
 224                    (let ((value (icalendar--get-event-property event prop)))
 225                      (when value
 226                        ;; ugly, but cannot get
 227                        ;;replace-regexp-in-string work with "\\" as
 228                        ;;REP, plus we should also handle "\\;"
 229                        (replace-regexp-in-string
 230                         "\\\\," ","
 231                         (replace-regexp-in-string
 232                          "\\\\n" "\n" (substring-no-properties value))))))
 233                  (accumulate-args (mapping)
 234                    (destructuring-bind (slot . ical-property) mapping
 235                      (setq args (append (list
 236                                          (intern (concat ":" (symbol-name slot)))
 237                                          (map-property ical-property))
 238                                         args)))))
 239
 240       (mapc #'accumulate-args prop-map)
 241       (apply 'make-instance event-class args))))
 242
 243 (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
 244   "Parse RFC5545 iCalendar in buffer BUF and return an event object.
 245
 246 Return a gnus-icalendar-event object representing the first event