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