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

   1 ;;; gnus-icalendar.el --- reply to iCalendar meeting requests
   2
   3 ;; Copyright (C) 2013  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 'mm-decode)
  39 (require 'gnus-sum)
  40
  41 (eval-when-compile (require 'cl))
  42
  43 (defun gnus-icalendar-find-if (pred seq)
  44   (catch 'found
  45     (while seq
  46       (when (funcall pred (car seq))
  47         (throw 'found (car seq)))
  48       (pop seq))))
  49
  50 ;;;
  51 ;;; ical-event
  52 ;;;
  53
  54 (defclass gnus-icalendar-event ()
  55   ((organizer :initarg :organizer
  56               :accessor gnus-icalendar-event:organizer
  57               :initform ""
  58               :type (or null string))
  59    (summary :initarg :summary
  60             :accessor gnus-icalendar-event:summary
  61             :initform ""
  62             :type (or null string))
  63    (description :initarg :description
  64                 :accessor gnus-icalendar-event:description
  65                 :initform ""
  66                 :type (or null string))
  67    (location :initarg :location
  68              :accessor gnus-icalendar-event:location
  69              :initform ""
  70              :type (or null string))
  71    (start :initarg :start
  72           :accessor gnus-icalendar-event:start
  73           :initform ""
  74           :type (or null string))
  75    (end :initarg :end
  76         :accessor gnus-icalendar-event:end
  77         :initform ""
  78         :type (or null string))
  79    (recur :initarg :recur
  80           :accessor gnus-icalendar-event:recur
  81           :initform ""
  82           :type (or null string))
  83    (uid :initarg :uid
  84         :accessor gnus-icalendar-event:uid
  85         :type string)
  86    (method :initarg :method
  87            :accessor gnus-icalendar-event:method
  88            :initform "PUBLISH"
  89            :type (or null string))
  90    (rsvp :initarg :rsvp
  91          :accessor gnus-icalendar-event:rsvp
  92          :initform nil
  93          :type (or null boolean)))
  94   "generic iCalendar Event class")
  95
  96 (defclass gnus-icalendar-event-request (gnus-icalendar-event)
  97   nil
  98   "iCalendar class for REQUEST events")
  99
 100 (defclass gnus-icalendar-event-cancel (gnus-icalendar-event)
 101   nil
 102   "iCalendar class for CANCEL events")
 103
 104 (defclass gnus-icalendar-event-reply (gnus-icalendar-event)
 105   nil
 106   "iCalendar class for REPLY events")
 107
 108 (defmethod gnus-icalendar-event:recurring-p ((event gnus-icalendar-event))
 109   "Return t if EVENT is recurring."
 110   (not (null (gnus-icalendar-event:recur event))))
 111
 112 (defmethod gnus-icalendar-event:recurring-freq ((event gnus-icalendar-event))
 113   "Return recurring frequency of EVENT."
 114   (let ((rrule (gnus-icalendar-event:recur event)))
 115     (string-match "FREQ=\\([[:alpha:]]+\\)" rrule)
 116     (match-string 1 rrule)))
 117
 118 (defmethod gnus-icalendar-event:recurring-interval ((event gnus-icalendar-event))
 119   "Return recurring interval of EVENT."
 120   (let ((rrule (gnus-icalendar-event:recur event))
 121         (default-interval 1))
 122
 123     (string-match "INTERVAL=\\([[:digit:]]+\\)" rrule)
 124     (or (match-string 1 rrule)
 125         default-interval)))
 126
 127 (defmethod gnus-icalendar-event:start-time ((event gnus-icalendar-event))
 128   "Return time value of the EVENT start date."
 129   (date-to-time (gnus-icalendar-event:start event)))
 130
 131 (defmethod gnus-icalendar-event:end-time ((event gnus-icalendar-event))
 132   "Return time value of the EVENT end date."
 133   (date-to-time (gnus-icalendar-event:end event)))
 134
 135
 136 (defun gnus-icalendar-event--decode-datefield (ical field zone-map &optional date-style)
 137   (let* ((calendar-date-style (or date-style 'european))
 138          (date (icalendar--get-event-property ical field))
 139          (date-zone (icalendar--find-time-zone
 140                      (icalendar--get-event-property-attributes
 141                       ical field)
 142                      zone-map))
 143          (date-decoded (icalendar--decode-isodatetime date nil date-zone)))
 144
 145     (concat (icalendar--datetime-to-iso-date date-decoded "-")
 146             " "
 147             (icalendar--datetime-to-colontime date-decoded))))
 148
 149 (defun gnus-icalendar-event--find-attendee (ical name-or-email)
 150   (let* ((event (car (icalendar--all-events ical)))
 151          (event-props (caddr event)))
 152     (labels ((attendee-name (att) (plist-get (cadr att) 'CN))
 153                  (attendee-email (att)
 154                    (replace-regexp-in-string "^.*MAILTO:" "" (caddr att)))
 155                  (attendee-prop-matches-p (prop)
 156                    (and (eq (car prop) 'ATTENDEE)
 157                         (or (member (attendee-name prop) name-or-email)
 158                             (let ((att-email (attendee-email prop)))
 159                               (gnus-icalendar-find-if (lambda (email)
 160                                                         (string-match email att-email))
 161                                                       name-or-email))))))
 162
 163       (gnus-icalendar-find-if #'attendee-prop-matches-p event-props))))
 164
 165
 166 (defun gnus-icalendar-event-from-ical (ical &optional attendee-name-or-email)
 167   (let* ((event (car (icalendar--all-events ical)))
 168          (zone-map (icalendar--convert-all-timezones ical))
 169          (organizer (replace-regexp-in-string
 170                      "^.*MAILTO:" ""
 171                      (or (icalendar--get-event-property event 'ORGANIZER) "")))
 172          (prop-map '((summary . SUMMARY)
 173                      (description . DESCRIPTION)
 174                      (location . LOCATION)
 175                      (recur . RRULE)
 176                      (uid . UID)))
 177          (method (caddr (assoc 'METHOD (caddr (car (nreverse ical))))))
 178          (attendee (when attendee-name-or-email
 179                      (gnus-icalendar-event--find-attendee ical attendee-name-or-email)))
 180          (args (list :method method
 181                      :organizer organizer
 182                      :start (gnus-icalendar-event--decode-datefield event 'DTSTART zone-map)
 183                      :end (gnus-icalendar-event--decode-datefield event 'DTEND zone-map)
 184                      :rsvp (string= (plist-get (cadr attendee) 'RSVP)
 185                                     "TRUE")))
 186          (event-class (pcase method
 187                         ("REQUEST" 'gnus-icalendar-event-request)
 188                         ("CANCEL" 'gnus-icalendar-event-cancel)
 189                         ("REPLY" 'gnus-icalendar-event-reply)
 190                         (_ 'gnus-icalendar-event))))
 191
 192     (labels ((map-property (prop)
 193                    (let ((value (icalendar--get-event-property event prop)))
 194                      (when value
 195                        ;; ugly, but cannot get
 196                        ;;replace-regexp-in-string work with "\\" as
 197                        ;;REP, plus we should also handle "\\;"
 198                        (replace-regexp-in-string
 199                         "\\\\," ","
 200                         (replace-regexp-in-string
 201                          "\\\\n" "\n" (substring-no-properties value))))))
 202                  (accumulate-args (mapping)
 203                    (destructuring-bind (slot . ical-property) mapping
 204                      (setq args (append (list
 205                                          (intern (concat ":" (symbol-name slot)))
 206                                          (map-property ical-property))
 207                                         args)))))
 208
 209       (mapc #'accumulate-args prop-map)
 210       (apply 'make-instance event-class args))))
 211
 212 (defun gnus-icalendar-event-from-buffer (buf &optional attendee-name-or-email)
 213   "Parse RFC5545 iCalendar in buffer BUF and return an event object.
 214
 215 Return a gnus-icalendar-event object representing the first event
 216 contained in the invitation. Return nil for calendars without an event entry.
 217
 218 ATTENDEE-NAME-OR-EMAIL is a list of strings that will be matched
 219 against the event's attendee names and emails. Invitation rsvp
 220 status will be retrieved from the first matching attendee record."
 221   (let ((ical (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
 222                 (goto-char (point-min))
 223                 (icalendar--read-element nil nil))))
 224
 225     (when ical
 226       (gnus-icalendar-event-from-ical ical attendee-name-or-email))))
 227
 228 ;;;
 229 ;;; gnus-icalendar-event-reply
 230 ;;;
 231
 232 (defun gnus-icalendar-event--build-reply-event-body (ical-request status identities)
 233   (let ((summary-status (capitalize (symbol-name status)))
 234         (attendee-status (upcase (symbol-name status)))
 235         reply-event-lines)
 236     (labels ((update-summary (line)
 237                    (if (string-match "^[^:]+:" line)
 238                        (replace-match (format "\\&%s: " summary-status) t nil line)
 239                      line))
 240                  (update-dtstamp ()
 241                    (format-time-string "DTSTAMP:%Y%m%dT%H%M%SZ" nil t))
 242                  (attendee-matches-identity (line)
 243                    (gnus-icalendar-find-if (lambda (name) (string-match-p name line))
 244                                            identities))
 245                  (update-attendee-status (line)
 246                    (when (and (attendee-matches-identity line)
 247                               (string-match "\\(PARTSTAT=\\)[^;]+" line))
 248                      (replace-match (format "\\1%s" attendee-status) t nil line)))
 249                  (process-event-line (line)
 250                    (when (string-match "^\\([^;:]+\\)" line)
 251                      (let* ((key (match-string 0 line))
 252                             ;; NOTE: not all of the below fields are mandatory,
 253                             ;; but they are often present in other clients'
 254                             ;; replies. Can be helpful for debugging, too.
 255                             (new-line (pcase key
 256                                         ("ATTENDEE" (update-attendee-status line))
 257                                         ("SUMMARY" (update-summary line))
 258                                         ("DTSTAMP" (update-dtstamp))
 259                                         ((or "ORGANIZER" "DTSTART" "DTEND"
 260                                              "LOCATION" "DURATION" "SEQUENCE"
 261                                              "RECURRENCE-ID" "UID") line)
 262                                         (_ nil))))
 263                        (when new-line
 264                          (push new-line reply-event-lines))))))
 265
 266       (mapc #'process-event-line (split-string ical-request "\n"))
 267
 268       (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x))
 269                           reply-event-lines)
 270         (error "Could not find an event attendee matching given identity"))
 271
 272       (mapconcat #'identity `("BEGIN:VEVENT"
 273                               ,@(nreverse reply-event-lines)
 274                               "END:VEVENT")
 275                  "\n"))))
 276
 277 (defun gnus-icalendar-event-reply-from-buffer (buf status identities)
 278   "Build a calendar event reply for request contained in BUF.
 279 The reply will have STATUS (`accepted', `tentative' or  `declined').
 280 The reply will be composed for attendees matching any entry
 281 on the IDENTITIES list."
 282   (flet ((extract-block (blockname)
 283                (save-excursion
 284                  (let ((block-start-re (format "^BEGIN:%s" blockname))
 285                        (block-end-re (format "^END:%s" blockname))
 286                        start)
 287                    (when (re-search-forward block-start-re nil t)
 288                      (setq start (line-beginning-position))
 289                      (re-search-forward block-end-re)
 290                      (buffer-substring-no-properties start (line-end-position)))))))
 291
 292     (let (zone event)
 293       (with-current-buffer (icalendar--get-unfolded-buffer (get-buffer buf))
 294         (goto-char (point-min))
 295         (setq zone (extract-block "VTIMEZONE")
 296               event (extract-block "VEVENT")))
 297
 298       (when event
 299         (let ((contents (list "BEGIN:VCALENDAR"
 300                               "METHOD:REPLY"
 301                               "PRODID:Gnus"
 302                               "VERSION:2.0"
 303                               zone
 304                               (gnus-icalendar-event--build-reply-event-body event status identities)
 305                               "END:VCALENDAR")))
 306
 307           (mapconcat #'identity (delq nil contents) "\n"))))))
 308
 309 ;;;
 310 ;;; gnus-icalendar-org
 311 ;;;
 312 ;;; TODO: this is an optional feature, and it's only available with org-mode
 313 ;;; 7+, so will need to properly handle emacsen with no/outdated org-mode
 314
 315 (require 'org)
 316 (require 'org-capture)
 317
 318 (defgroup gnus-icalendar-org nil
 319   "Settings for Calendar Event gnus/org integration."
 320   :group 'gnus-icalendar
 321   :prefix "gnus-icalendar-org-")
 322
 323 (defcustom gnus-icalendar-org-capture-file nil
 324   "Target Org file for storing captured calendar events."
 325   :type 'file
 326   :group 'gnus-icalendar-org)
 327
 328 (defcustom gnus-icalendar-org-capture-headline nil
 329   "Target outline in `gnus-icalendar-org-capture-file' for storing captured events."
 330   :type '(repeat string)
 331   :group 'gnus-icalendar-org)
 332
 333 (defcustom gnus-icalendar-org-template-name "used by gnus-icalendar-org"
 334   "Org-mode template name."
 335   :type '(string)
 336   :group 'gnus-icalendar-org)
 337
 338 (defcustom gnus-icalendar-org-template-key "#"
 339   "Org-mode template hotkey."
 340   :type '(string)
 341   :group 'gnus-icalendar-org)
 342
 343 (defvar gnus-icalendar-org-enabled-p nil)
 344
 345
 346 (defmethod gnus-icalendar-event:org-repeat ((event gnus-icalendar-event))
 347   "Return `org-mode' timestamp repeater string for recurring EVENT.
 348 Return nil for non-recurring EVENT."
 349   (when (gnus-icalendar-event:recurring-p event)
 350     (let* ((freq-map '(("HOURLY" . "h")
 351                        ("DAILY" . "d")
 352                        ("WEEKLY" . "w")
 353                        ("MONTHLY" . "m")
 354                        ("YEARLY" . "y")))
 355            (org-freq (cdr (assoc (gnus-icalendar-event:recurring-freq event) freq-map))))
 356
 357       (when org-freq
 358         (format "+%s%s" (gnus-icalendar-event:recurring-interval event) org-freq)))))
 359
 360 (defmethod gnus-icalendar-event:org-timestamp ((event gnus-icalendar-event))
 361   "Build `org-mode' timestamp from EVENT start/end dates and recurrence info."
 362   (let* ((start (gnus-icalendar-event:start-time event))
 363          (end (gnus-icalendar-event:end-time event))
 364          (start-date (format-time-string "%Y-%m-%d %a" start t))
 365          (start-time (format-time-string "%H:%M" start t))
 366          (end-date (format-time-string "%Y-%m-%d %a" end t))
 367          (end-time (format-time-string "%H:%M" end t))
 368          (org-repeat (gnus-icalendar-event:org-repeat event))
 369          (repeat (if org-repeat (concat " " org-repeat) "")))
 370
 371     (if (equal start-date end-date)
 372         (format "<%s %s-%s%s>" start-date start-time end-time repeat)
 373       (format "<%s %s>--<%s %s>" start-date start-time end-date end-time))))
 374
 375 ;; TODO: make the template customizable
 376 (defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
 377   "Return string with new `org-mode' entry describing EVENT."
 378   (with-temp-buffer
 379     (org-mode)
 380     (with-slots (organizer summary description location
 381                            recur uid) event
 382       (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
 383                       "Not replied yet"))
 384              (props `(("ICAL_EVENT" . "t")
 385                       ("ID" . ,uid)
 386                       ("DT" . ,(gnus-icalendar-event:org-timestamp event))
 387                       ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
 388                       ("LOCATION" . ,(gnus-icalendar-event:location event))
 389                       ("RRULE" . ,(gnus-icalendar-event:recur event))
 390                       ("REPLY" . ,reply))))
 391
 392         (insert (format "* %s (%s)\n\n" summary location))
 393         (mapc (lambda (prop)
 394                 (org-entry-put (point) (car prop) (cdr prop)))
 395               props))
 396
 397       (when description
 398         (save-restriction
 399           (narrow-to-region (point) (point))
 400           (insert description)
 401           (indent-region (point-min) (point-max) 2)
 402           (fill-region (point-min) (point-max))))
 403
 404       (buffer-string))))
 405
 406 (defun gnus-icalendar--deactivate-org-timestamp (ts)
 407   (replace-regexp-in-string "[<>]"
 408                             (lambda (m) (pcase m ("<" "[") (">" "]")))
 409                             ts))
 410
 411 (defun gnus-icalendar-find-org-event-file (event &optional org-file)
 412   "Return the name of the file containing EVENT org entry.
 413 Return nil when not found.
 414
 415 All org agenda files are searched for the EVENT entry.  When
 416 the optional ORG-FILE argument is specified, only that one file
 417 is searched."
 418   (let ((uid (gnus-icalendar-event:uid event))
 419         (files (or org-file (org-agenda-files t 'ifmode))))
 420     (flet
 421         ((find-event-in (file)
 422            (org-check-agenda-file file)
 423            (with-current-buffer (find-file-noselect file)
 424              (let ((event-pos (org-find-entry-with-id uid)))
 425                (when (and event-pos
 426                           (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos)))
 427                                    "t"))
 428                  (throw 'found file))))))
 429
 430       (gnus-icalendar-find-if #'find-event-in files))))
 431
 432
 433 (defun gnus-icalendar--show-org-event (event &optional org-file)
 434   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 435     (when file
 436       (switch-to-buffer (find-file file))
 437       (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
 438       (org-show-entry))))
 439
 440
 441 (defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
 442   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 443     (when file
 444       (with-current-buffer (find-file-noselect file)
 445         (with-slots (uid summary description organizer location recur) event
 446           (let ((event-pos (org-find-entry-with-id uid)))
 447             (when event-pos
 448               (goto-char event-pos)
 449
 450               ;; update the headline, keep todo, priority and tags, if any
 451               (save-excursion
 452                 (let* ((priority (org-entry-get (point) "PRIORITY"))
 453                        (headline (delq nil (list
 454                                             (org-entry-get (point) "TODO")
 455                                             (when priority (format "[#%s]" priority))
 456                                             (format "%s (%s)" summary location)
 457                                             (org-entry-get (point) "TAGS")))))
 458
 459                   (re-search-forward "^\\*+ " (line-end-position))
 460                   (delete-region (point) (line-end-position))
 461                   (insert (mapconcat #'identity headline " "))))
 462
 463               ;; update props and description
 464               (let ((entry-end (org-entry-end-position))
 465                     (entry-outline-level (org-outline-level)))
 466
 467                 ;; delete body of the entry, leave org drawers intact
 468                 (save-restriction
 469                   (org-narrow-to-element)
 470                   (goto-char entry-end)
 471                   (re-search-backward "^[\t ]*:END:")
 472                   (forward-line)
 473                   (delete-region (point) entry-end))
 474
 475                 ;; put new event description in the entry body
 476                 (when description
 477                   (save-restriction
 478                     (narrow-to-region (point) (point))
 479                     (insert "\n" (replace-regexp-in-string "[\n]+$" "\n" description) "\n")
 480                     (indent-region (point-min) (point-max) (1+ entry-outline-level))
 481                     (fill-region (point-min) (point-max))))
 482
 483                 ;; update entry properties
 484                 (org-entry-put event-pos "DT" (gnus-icalendar-event:org-timestamp event))
 485                 (org-entry-put event-pos "ORGANIZER" organizer)
 486                 (org-entry-put event-pos "LOCATION" location)
 487                 (org-entry-put event-pos "RRULE" recur)
 488                 (when reply-status (org-entry-put event-pos "REPLY"
 489                                                   (capitalize (symbol-name reply-status))))
 490                 (save-buffer)))))))))
 491
 492
 493 (defun gnus-icalendar--cancel-org-event (event &optional org-file)
 494   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 495     (when file
 496       (with-current-buffer (find-file-noselect file)
 497         (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 498           (when event-pos
 499             (let ((ts (org-entry-get event-pos "DT")))
 500               (when ts
 501                 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
 502                 (save-buffer)))))))))
 503
 504
 505 (defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
 506   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 507     (when file
 508       (save-excursion
 509         (with-current-buffer (find-file-noselect file)
 510           (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 511             (org-entry-get event-pos "REPLY")))))))
 512
 513
 514 (defun gnus-icalendar-insinuate-org-templates ()
 515   (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
 516                       org-capture-templates)
 517     (setq org-capture-templates
 518           (append `((,gnus-icalendar-org-template-key
 519                      ,gnus-icalendar-org-template-name
 520                      entry
 521                      (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
 522                      "%i"
 523                      :immediate-finish t))
 524                   org-capture-templates))
 525
 526     ;; hide the template from interactive template selection list
 527     ;; (org-capture)
 528     ;; NOTE: doesn't work when capturing from string
 529     ;; (when (boundp 'org-capture-templates-contexts)
 530     ;;   (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
 531     ;;         org-capture-templates-contexts))
 532     ))
 533
 534 (defun gnus-icalendar:org-event-save (event reply-status)
 535   (with-temp-buffer
 536     (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
 537                         gnus-icalendar-org-template-key)))
 538
 539 (defun gnus-icalendar-show-org-agenda (event)
 540   (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
 541                                     (gnus-icalendar-event:start-time event)))
 542          (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
 543                                   (cadr time-delta))
 544                                86400))))
 545
 546     (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
 547
 548 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
 549   (if (gnus-icalendar-find-org-event-file event)
 550       (gnus-icalendar--update-org-event event reply-status)
 551     (gnus-icalendar:org-event-save event reply-status)))
 552
 553 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel))
 554   (when (gnus-icalendar-find-org-event-file event)
 555     (gnus-icalendar--cancel-org-event event)))
 556
 557 (defun gnus-icalendar-org-setup ()
 558   (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
 559       (progn
 560         (gnus-icalendar-insinuate-org-templates)
 561         (setq gnus-icalendar-org-enabled-p t))
 562     (message "Cannot enable Calendar->Org: missing capture file, headline")))
 563
 564 ;;;
 565 ;;; gnus-icalendar
 566 ;;;
 567
 568 (defgroup gnus-icalendar nil
 569   "Settings for inline display of iCalendar invitations."
 570   :group 'gnus-article
 571   :prefix "gnus-icalendar-")
 572
 573 (defcustom gnus-icalendar-reply-bufname "*CAL*"
 574   "Buffer used for building iCalendar invitation reply."
 575   :type '(string)
 576   :group 'gnus-icalendar)
 577
 578 (make-variable-buffer-local
 579  (defvar gnus-icalendar-reply-status nil))
 580
 581 (make-variable-buffer-local
 582  (defvar gnus-icalendar-event nil))
 583
 584 (make-variable-buffer-local
 585  (defvar gnus-icalendar-handle nil))
 586
 587 (defvar gnus-icalendar-identities
 588   (apply #'append
 589          (mapcar (lambda (x) (if (listp x) x (list x)))
 590                  (list user-full-name (regexp-quote user-mail-address)
 591                        ; NOTE: this one can be a list
 592                        gnus-ignored-from-addresses))))
 593
 594 ;; TODO: make the template customizable
 595 (defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
 596   "Format an overview of EVENT details."
 597   (flet ((format-header (x)
 598             (format "%-12s%s"
 599                     (propertize (concat (car x) ":") 'face 'bold)
 600                     (cadr x))))
 601
 602     (with-slots (organizer summary description location recur uid method rsvp) event
 603       (let ((headers `(("Summary" ,summary)
 604                       ("Location" ,location)
 605                       ("Time" ,(gnus-icalendar-event:org-timestamp event))
 606                       ("Organizer" ,organizer)
 607                       ("Method" ,method))))
 608
 609        (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
 610          (setq headers (append headers
 611                                `(("Status" ,(or reply-status "Not replied yet"))))))
 612
 613        (concat
 614         (mapconcat #'format-header headers "\n")
 615         "\n\n"
 616         description)))))
 617
 618 (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
 619   "Execute BODY in buffer containing the decoded contents of HANDLE."
 620   (let ((charset (make-symbol "charset")))
 621     `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
 622        (with-temp-buffer
 623          (mm-insert-part ,handle)
 624          (when (string= ,charset "utf-8")
 625            (mm-decode-coding-region (point-min) (point-max) 'utf-8))
 626
 627          ,@body))))
 628
 629
 630 (defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
 631   (gnus-icalendar-with-decoded-handle handle
 632                        (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
 633
 634 (defun gnus-icalendar-insert-button (text callback data)
 635   ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
 636   ;; of button.
 637   (let ((start (point)))
 638     (gnus-add-text-properties
 639      start
 640      (progn
 641        (insert "[ " text " ]")
 642        (point))
 643      `(gnus-callback
 644        ,callback
 645        keymap ,gnus-mime-button-map
 646        face ,gnus-article-button-face
 647        gnus-data ,data))
 648     (widget-convert-button 'link start (point)
 649                            :action 'gnus-widget-press-button
 650                            :button-keymap gnus-widget-button-keymap)))
 651
 652 (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
 653   (let ((message-signature nil))
 654     (with-current-buffer gnus-summary-buffer
 655       (gnus-summary-reply)
 656       (message-goto-body)
 657       (mml-insert-multipart "alternative")
 658       (mml-insert-empty-tag 'part 'type "text/plain")
 659       (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
 660       (message-goto-subject)
 661       (delete-region (line-beginning-position) (line-end-position))
 662       (insert "Subject: " subject)
 663       (message-send-and-exit))))
 664
 665 (defun gnus-icalendar-reply (data)
 666   (let* ((handle (car data))
 667          (status (cadr data))
 668          (event (caddr data))
 669          (reply (gnus-icalendar-with-decoded-handle handle
 670                   (gnus-icalendar-event-reply-from-buffer
 671                    (current-buffer) status gnus-icalendar-identities))))
 672
 673     (when reply
 674       (flet ((fold-icalendar-buffer ()
 675                (goto-char (point-min))
 676                (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
 677                  (replace-match "\\1\n \\2")
 678                  (goto-char (line-beginning-position)))))
 679         (let ((subject (concat (capitalize (symbol-name status))
 680                                ": " (gnus-icalendar-event:summary event))))
 681
 682           (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
 683             (delete-region (point-min) (point-max))
 684             (insert reply)
 685             (fold-icalendar-buffer)
 686             (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
 687
 688           ;; Back in article buffer
 689           (setq-local gnus-icalendar-reply-status status)
 690           (when gnus-icalendar-org-enabled-p
 691             (gnus-icalendar--update-org-event event status)
 692             ;; refresh article buffer to update the reply status
 693             (with-current-buffer gnus-summary-buffer
 694               (gnus-summary-show-article))))))))
 695
 696 (defun gnus-icalendar-sync-event-to-org (event)
 697   (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
 698
 699 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event))
 700   (when (gnus-icalendar-event:rsvp event)
 701     `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
 702       ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
 703       ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
 704
 705 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply))
 706   "No buttons for REPLY events."
 707   nil)
 708
 709 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
 710   (or (when gnus-icalendar-org-enabled-p
 711         (gnus-icalendar--get-org-event-reply-status event))
 712       "Not replied yet"))
 713
 714 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
 715   "No reply status for REPLY events."
 716   nil)
 717
 718
 719 (defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
 720   (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
 721          (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
 722
 723     (delq nil (list
 724                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 725                (when (gnus-icalendar-event-request-p event)
 726                  `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
 727                (when org-entry-exists-p
 728                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 729
 730 (defun gnus-icalendar-mm-inline (handle)
 731   (let ((event (gnus-icalendar-event-from-handle handle gnus-icalendar-identities)))
 732
 733     (setq gnus-icalendar-reply-status nil)
 734
 735     (when event
 736       (flet ((insert-button-group (buttons)
 737                 (when buttons
 738                   (mapc (lambda (x)
 739                           (apply 'gnus-icalendar-insert-button x)
 740                           (insert "    "))
 741                         buttons)
 742                   (insert "\n\n"))))
 743
 744         (insert-button-group (gnus-icalendar-event:inline-reply-buttons event))
 745
 746         (when gnus-icalendar-org-enabled-p
 747           (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
 748
 749         (setq gnus-icalendar-event event
 750               gnus-icalendar-handle handle)
 751
 752         (insert (gnus-icalendar-event->gnus-calendar
 753                  event
 754                  (gnus-icalendar-event:inline-reply-status event)))))))
 755
 756 (defun gnus-icalendar-save-part (handle)
 757   (let (event)
 758     (when (and (equal (car (mm-handle-type handle)) "text/calendar")
 759                (setq event (gnus-icalendar-event-from-handle handle gnus-icalendar-identities)))
 760
 761       (gnus-icalendar-event:sync-to-org event))))
 762
 763
 764 (defun gnus-icalendar-save-event ()
 765   "Save the Calendar event in the text/calendar part under point."
 766   (interactive)
 767   (gnus-article-check-buffer)
 768   (let ((data (get-text-property (point) 'gnus-data)))
 769     (when data
 770       (gnus-icalendar-save-part data))))
 771
 772 (defun gnus-icalendar-reply-accept ()
 773   "Accept invitation in the current article."
 774   (interactive)
 775   (with-current-buffer gnus-article-buffer
 776     (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
 777     (setq-local gnus-icalendar-reply-status 'accepted)))
 778
 779 (defun gnus-icalendar-reply-tentative ()
 780   "Send tentative response to invitation in the current article."
 781   (interactive)
 782   (with-current-buffer gnus-article-buffer
 783     (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
 784     (setq-local gnus-icalendar-reply-status 'tentative)))
 785
 786 (defun gnus-icalendar-reply-decline ()
 787   "Decline invitation in the current article."
 788   (interactive)
 789   (with-current-buffer gnus-article-buffer
 790     (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
 791     (setq-local gnus-icalendar-reply-status 'declined)))
 792
 793 (defun gnus-icalendar-event-export ()
 794   "Export calendar event to `org-mode', or update existing agenda entry."
 795   (interactive)
 796   (with-current-buffer gnus-article-buffer
 797     (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
 798   ;; refresh article buffer in case the reply had been sent before initial org
 799   ;; export
 800   (with-current-buffer gnus-summary-buffer
 801     (gnus-summary-show-article)))
 802
 803 (defun gnus-icalendar-event-show ()
 804   "Display `org-mode' agenda entry related to the calendar event."
 805   (interactive)
 806   (gnus-icalendar--show-org-event
 807    (with-current-buffer gnus-article-buffer
 808      gnus-icalendar-event)))
 809
 810 (defun gnus-icalendar-event-check-agenda ()
 811   "Display `org-mode' agenda for days between event start and end dates."
 812   (interactive)
 813   (gnus-icalendar-show-org-agenda
 814    (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
 815
 816 (defun gnus-icalendar-setup ()
 817   (add-to-list 'mm-inlined-types "text/calendar")
 818   (add-to-list 'mm-automatic-display "text/calendar")
 819   (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
 820
 821   (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
 822     "a" gnus-icalendar-reply-accept
 823     "t" gnus-icalendar-reply-tentative
 824     "d" gnus-icalendar-reply-decline
 825     "c" gnus-icalendar-event-check-agenda
 826     "e" gnus-icalendar-event-export
 827     "s" gnus-icalendar-event-show)
 828
 829   (require 'gnus-art)
 830   (add-to-list 'gnus-mime-action-alist
 831                (cons "save calendar event" 'gnus-icalendar-save-event)
 832                t))
 833
 834
 835 (provide 'gnus-icalendar)
 836 ;;; gnus-icalendar.el ends here