lisp/gnus/gnus-icalendar.el

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