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