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

   1 ;;; gnus-icalendar.el --- reply to iCalendar meeting requests
   2
   3 ;; Copyright (C) 2013-2014 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 (/ (float-time (time-subtract
 404                                         (date-to-time end-date)
 405                                         (date-to-time start-date)))
 406                                  86400))
 407          (org-repeat (gnus-icalendar-event:org-repeat event))
 408          (repeat (if org-repeat (concat " " org-repeat) ""))
 409          (time-1-day '(0 86400)))
 410
 411     ;; NOTE: special care is needed with appointments ending at midnight
 412     ;; (typically all-day events): the end time has to be changed to 23:59 to
 413     ;; prevent org agenda showing the event on one additional day
 414     (cond
 415      ;; start/end midnight
 416      ;; A 0:0 - A+1 0:0 -> A
 417      ;; A 0:0 - A+n 0:0 -> A - A+n-1
 418      ((and start-at-midnight end-at-midnight) (if (> start-end-date-diff 1)
 419                                                   (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
 420                                                     (format "<%s>--<%s>" start-date end-ts))
 421                                                 (format "<%s%s>" start-date repeat)))
 422      ;; end midnight
 423      ;; A .:. - A+1 0:0 -> A .:.-23:59
 424      ;; A .:. - A+n 0:0 -> A .:. - A_n-1
 425      (end-at-midnight (if (= start-end-date-diff 1)
 426                           (format "<%s %s-23:59%s>" start-date start-time repeat)
 427                         (let ((end-ts (format-time-string "%Y-%m-%d %a" (time-subtract end time-1-day))))
 428                           (format "<%s %s>--<%s>" start-date start-time end-ts))))
 429      ;; start midnight
 430      ;; A 0:0 - A .:. -> A 0:0-.:. (default 1)
 431      ;; A 0:0 - A+n .:. -> A - A+n .:.
 432      ((and start-at-midnight
 433            (plusp start-end-date-diff)) (format "<%s>--<%s %s>" start-date end-date end-time))
 434      ;; default
 435      ;; A .:. - A .:. -> A .:.-.:.
 436      ;; A .:. - B .:.
 437      ((zerop start-end-date-diff) (format "<%s %s-%s%s>" start-date start-time end-time repeat))
 438      (t (format "<%s %s>--<%s %s>" start-date start-time end-date end-time)))))
 439
 440 (defun gnus-icalendar--format-summary-line (summary &optional location)
 441   (if location
 442       (format "%s (%s)" summary location)
 443     (format "%s" summary)))
 444
 445
 446 (defun gnus-icalendar--format-participant-list (participants)
 447   (mapconcat #'identity participants ", "))
 448
 449 ;; TODO: make the template customizable
 450 (defmethod gnus-icalendar-event->org-entry ((event gnus-icalendar-event) reply-status)
 451   "Return string with new `org-mode' entry describing EVENT."
 452   (with-temp-buffer
 453     (org-mode)
 454     (with-slots (organizer summary description location
 455                            recur uid) event
 456       (let* ((reply (if reply-status (capitalize (symbol-name reply-status))
 457                       "Not replied yet"))
 458              (props `(("ICAL_EVENT" . "t")
 459                       ("ID" . ,uid)
 460                       ("ORGANIZER" . ,(gnus-icalendar-event:organizer event))
 461                       ("LOCATION" . ,(gnus-icalendar-event:location event))
 462                       ("PARTICIPATION_TYPE" . ,(symbol-name (gnus-icalendar-event:participation-type event)))
 463                       ("REQ_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:req-participants event)))
 464                       ("OPT_PARTICIPANTS" . ,(gnus-icalendar--format-participant-list (gnus-icalendar-event:opt-participants event)))
 465                       ("RRULE" . ,(gnus-icalendar-event:recur event))
 466                       ("REPLY" . ,reply))))
 467
 468         (insert (format "* %s\n\n"
 469                         (gnus-icalendar--format-summary-line summary location)))
 470         (mapc (lambda (prop)
 471                 (org-entry-put (point) (car prop) (cdr prop)))
 472               props))
 473
 474       (when description
 475         (save-restriction
 476           (narrow-to-region (point) (point))
 477           (insert (gnus-icalendar-event:org-timestamp event)
 478                   "\n\n"
 479                   description)
 480           (indent-region (point-min) (point-max) 2)
 481           (fill-region (point-min) (point-max))))
 482
 483       (buffer-string))))
 484
 485 (defun gnus-icalendar--deactivate-org-timestamp (ts)
 486   (replace-regexp-in-string "[<>]"
 487                             (lambda (m) (cond ((string= m "<") "[")
 488                                               ((string= m ">") "]")))
 489                             ts))
 490
 491 (defun gnus-icalendar-find-org-event-file (event &optional org-file)
 492   "Return the name of the file containing EVENT org entry.
 493 Return nil when not found.
 494
 495 All org agenda files are searched for the EVENT entry.  When
 496 the optional ORG-FILE argument is specified, only that one file
 497 is searched."
 498   (let ((uid (gnus-icalendar-event:uid event))
 499         (files (or org-file (org-agenda-files t 'ifmode))))
 500     (gmm-labels
 501         ((find-event-in (file)
 502            (org-check-agenda-file file)
 503            (with-current-buffer (find-file-noselect file)
 504              (let ((event-pos (org-find-entry-with-id uid)))
 505                (when (and event-pos
 506                           (string= (cdr (assoc "ICAL_EVENT" (org-entry-properties event-pos)))
 507                                    "t"))
 508                  (throw 'found file))))))
 509
 510       (gnus-icalendar-find-if #'find-event-in files))))
 511
 512
 513 (defun gnus-icalendar--show-org-event (event &optional org-file)
 514   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 515     (when file
 516       (switch-to-buffer (find-file file))
 517       (goto-char (org-find-entry-with-id (gnus-icalendar-event:uid event)))
 518       (org-show-entry))))
 519
 520
 521 (defun gnus-icalendar--update-org-event (event reply-status &optional org-file)
 522   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 523     (when file
 524       (with-current-buffer (find-file-noselect file)
 525         (with-slots (uid summary description organizer location recur
 526                          participation-type req-participants opt-participants) event
 527           (let ((event-pos (org-find-entry-with-id uid)))
 528             (when event-pos
 529               (goto-char event-pos)
 530
 531               ;; update the headline, keep todo, priority and tags, if any
 532               (save-excursion
 533                 (let* ((priority (org-entry-get (point) "PRIORITY"))
 534                        (headline (delq nil (list
 535                                             (org-entry-get (point) "TODO")
 536                                             (when priority (format "[#%s]" priority))
 537                                             (gnus-icalendar--format-summary-line summary location)
 538                                             (org-entry-get (point) "TAGS")))))
 539
 540                   (re-search-forward "^\\*+ " (line-end-position))
 541                   (delete-region (point) (line-end-position))
 542                   (insert (mapconcat #'identity headline " "))))
 543
 544               ;; update props and description
 545               (let ((entry-end (org-entry-end-position))
 546                     (entry-outline-level (org-outline-level)))
 547
 548                 ;; delete body of the entry, leave org drawers intact
 549                 (save-restriction
 550                   (org-narrow-to-element)
 551                   (goto-char entry-end)
 552                   (re-search-backward "^[\t ]*:END:")
 553                   (forward-line)
 554                   (delete-region (point) entry-end))
 555
 556                 ;; put new event description in the entry body
 557                 (when description
 558                   (save-restriction
 559                     (narrow-to-region (point) (point))
 560                     (insert "\n"
 561                             (gnus-icalendar-event:org-timestamp event)
 562                             "\n\n"
 563                             (replace-regexp-in-string "[\n]+$" "\n" description)
 564                             "\n")
 565                     (indent-region (point-min) (point-max) (1+ entry-outline-level))
 566                     (fill-region (point-min) (point-max))))
 567
 568                 ;; update entry properties
 569                 (gmm-labels
 570                     ((update-org-entry (position property value)
 571                                        (if (or (null value)
 572                                                (string= value ""))
 573                                            (org-entry-delete position property)
 574                                          (org-entry-put position property value))))
 575
 576                   (update-org-entry event-pos "ORGANIZER" organizer)
 577                   (update-org-entry event-pos "LOCATION" location)
 578                   (update-org-entry event-pos "PARTICIPATION_TYPE" (symbol-name participation-type))
 579                   (update-org-entry event-pos "REQ_PARTICIPANTS" (gnus-icalendar--format-participant-list req-participants))
 580                   (update-org-entry event-pos "OPT_PARTICIPANTS" (gnus-icalendar--format-participant-list opt-participants))
 581                   (update-org-entry event-pos "RRULE" recur)
 582                   (update-org-entry event-pos "REPLY"
 583                                     (if reply-status (capitalize (symbol-name reply-status))
 584                                       "Not replied yet")))
 585                 (save-buffer)))))))))
 586
 587
 588 (defun gnus-icalendar--cancel-org-event (event &optional org-file)
 589   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 590     (when file
 591       (with-current-buffer (find-file-noselect file)
 592         (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 593           (when event-pos
 594             (let ((ts (org-entry-get event-pos "DT")))
 595               (when ts
 596                 (org-entry-put event-pos "DT" (gnus-icalendar--deactivate-org-timestamp ts))
 597                 (save-buffer)))))))))
 598
 599
 600 (defun gnus-icalendar--get-org-event-reply-status (event &optional org-file)
 601   (let ((file (gnus-icalendar-find-org-event-file event org-file)))
 602     (when file
 603       (save-excursion
 604         (with-current-buffer (find-file-noselect file)
 605           (let ((event-pos (org-find-entry-with-id (gnus-icalendar-event:uid event))))
 606             (org-entry-get event-pos "REPLY")))))))
 607
 608
 609 (defun gnus-icalendar-insinuate-org-templates ()
 610   (unless (gnus-icalendar-find-if (lambda (x) (string= (cadr x) gnus-icalendar-org-template-name))
 611                       org-capture-templates)
 612     (setq org-capture-templates
 613           (append `((,gnus-icalendar-org-template-key
 614                      ,gnus-icalendar-org-template-name
 615                      entry
 616                      (file+olp ,gnus-icalendar-org-capture-file ,@gnus-icalendar-org-capture-headline)
 617                      "%i"
 618                      :immediate-finish t))
 619                   org-capture-templates))
 620
 621     ;; hide the template from interactive template selection list
 622     ;; (org-capture)
 623     ;; NOTE: doesn't work when capturing from string
 624     ;; (when (boundp 'org-capture-templates-contexts)
 625     ;;   (push `(,gnus-icalendar-org-template-key "" ((in-mode . "gnus-article-mode")))
 626     ;;         org-capture-templates-contexts))
 627     ))
 628
 629 (defun gnus-icalendar:org-event-save (event reply-status)
 630   (with-temp-buffer
 631     (org-capture-string (gnus-icalendar-event->org-entry event reply-status)
 632                         gnus-icalendar-org-template-key)))
 633
 634 (defun gnus-icalendar-show-org-agenda (event)
 635   (let* ((time-delta (time-subtract (gnus-icalendar-event:end-time event)
 636                                     (gnus-icalendar-event:start-time event)))
 637          (duration-days (1+ (/ (+ (* (car time-delta) (expt 2 16))
 638                                   (cadr time-delta))
 639                                86400))))
 640
 641     (org-agenda-list nil (gnus-icalendar-event:start event) duration-days)))
 642
 643 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-request) reply-status)
 644   (if (gnus-icalendar-find-org-event-file event)
 645       (gnus-icalendar--update-org-event event reply-status)
 646     (gnus-icalendar:org-event-save event reply-status)))
 647
 648 (defmethod gnus-icalendar-event:sync-to-org ((event gnus-icalendar-event-cancel) reply-status)
 649   (when (gnus-icalendar-find-org-event-file event)
 650     (gnus-icalendar--cancel-org-event event)))
 651
 652 (defun gnus-icalendar-org-setup ()
 653   (if (and gnus-icalendar-org-capture-file gnus-icalendar-org-capture-headline)
 654       (progn
 655         (gnus-icalendar-insinuate-org-templates)
 656         (setq gnus-icalendar-org-enabled-p t))
 657     (message "Cannot enable Calendar->Org: missing capture file, headline")))
 658
 659 ;;;
 660 ;;; gnus-icalendar
 661 ;;;
 662
 663 (defgroup gnus-icalendar nil
 664   "Settings for inline display of iCalendar invitations."
 665   :version "24.4"
 666   :group 'gnus-article
 667   :prefix "gnus-icalendar-")
 668
 669 (defcustom gnus-icalendar-reply-bufname "*CAL*"
 670   "Buffer used for building iCalendar invitation reply."
 671   :type '(string)
 672   :group 'gnus-icalendar)
 673
 674 (defcustom gnus-icalendar-additional-identities nil
 675   "We need to know your identity to make replies to calendar requests work.
 676
 677 Gnus will only offer you the Accept/Tentative/Decline buttons for
 678 calendar events if any of your identities matches at least one
 679 RSVP participant.
 680
 681 Your identity is guessed automatically from the variables
 682 `user-full-name', `user-mail-address',
 683 `gnus-ignored-from-addresses' and `message-alternative-emails'.
 684
 685 If you need even more aliases you can define them here.  It really
 686 only makes sense to define names or email addresses."
 687
 688   :type '(repeat string)
 689   :group 'gnus-icalendar)
 690
 691 (make-variable-buffer-local
 692  (defvar gnus-icalendar-reply-status nil))
 693
 694 (make-variable-buffer-local
 695  (defvar gnus-icalendar-event nil))
 696
 697 (make-variable-buffer-local
 698  (defvar gnus-icalendar-handle nil))
 699
 700 (defun gnus-icalendar-identities ()
 701   "Return list of regexp-quoted names and email addresses belonging to the user.
 702
 703 These will be used to retrieve the RSVP information from ical events."
 704   (apply #'append
 705          (mapcar (lambda (x) (if (listp x) x (list x)))
 706                  (list user-full-name (regexp-quote user-mail-address)
 707                        ; NOTE: these can be lists
 708                        gnus-ignored-from-addresses ; already regexp-quoted
 709                        message-alternative-emails  ;
 710                        (mapcar #'regexp-quote gnus-icalendar-additional-identities)))))
 711
 712 ;; TODO: make the template customizable
 713 (defmethod gnus-icalendar-event->gnus-calendar ((event gnus-icalendar-event) &optional reply-status)
 714   "Format an overview of EVENT details."
 715   (gmm-labels ((format-header (x)
 716             (format "%-12s%s"
 717                     (propertize (concat (car x) ":") 'face 'bold)
 718                     (cadr x))))
 719
 720     (with-slots (organizer summary description location recur uid
 721                            method rsvp participation-type) event
 722       (let ((headers `(("Summary" ,summary)
 723                       ("Location" ,(or location ""))
 724                       ("Time" ,(gnus-icalendar-event:org-timestamp event))
 725                       ("Organizer" ,organizer)
 726                       ("Attendance" ,(if (eq participation-type 'non-participant)
 727                                          "You are not listed as an attendee"
 728                                        (capitalize (symbol-name participation-type))))
 729                       ("Method" ,method))))
 730
 731        (when (and (not (gnus-icalendar-event-reply-p event)) rsvp)
 732          (setq headers (append headers
 733                                `(("Status" ,(or reply-status "Not replied yet"))))))
 734
 735        (concat
 736         (mapconcat #'format-header headers "\n")
 737         "\n\n"
 738         description)))))
 739
 740 (defmacro gnus-icalendar-with-decoded-handle (handle &rest body)
 741   "Execute BODY in buffer containing the decoded contents of HANDLE."
 742   (let ((charset (make-symbol "charset")))
 743     `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle)))))
 744        (with-temp-buffer
 745          (mm-insert-part ,handle)
 746          (when (string= ,charset "utf-8")
 747            (mm-decode-coding-region (point-min) (point-max) 'utf-8))
 748
 749          ,@body))))
 750
 751
 752 (defun gnus-icalendar-event-from-handle (handle &optional attendee-name-or-email)
 753   (gnus-icalendar-with-decoded-handle handle
 754                        (gnus-icalendar-event-from-buffer (current-buffer) attendee-name-or-email)))
 755
 756 (defun gnus-icalendar-insert-button (text callback data)
 757   ;; FIXME: the gnus-mime-button-map keymap does not make sense for this kind
 758   ;; of button.
 759   (let ((start (point)))
 760     (gnus-add-text-properties
 761      start
 762      (progn
 763        (insert "[ " text " ]")
 764        (point))
 765      `(gnus-callback
 766        ,callback
 767        keymap ,gnus-mime-button-map
 768        face ,gnus-article-button-face
 769        gnus-data ,data))
 770     (widget-convert-button 'link start (point)
 771                            :action 'gnus-widget-press-button
 772                            :button-keymap gnus-widget-button-keymap)))
 773
 774 (defun gnus-icalendar-send-buffer-by-mail (buffer-name subject)
 775   (let ((message-signature nil))
 776     (with-current-buffer gnus-summary-buffer
 777       (gnus-summary-reply)
 778       (message-goto-body)
 779       (mml-insert-multipart "alternative")
 780       (mml-insert-empty-tag 'part 'type "text/plain")
 781       (mml-attach-buffer buffer-name "text/calendar; method=REPLY; charset=UTF-8")
 782       (message-goto-subject)
 783       (delete-region (line-beginning-position) (line-end-position))
 784       (insert "Subject: " subject)
 785       (message-send-and-exit))))
 786
 787 (defun gnus-icalendar-reply (data)
 788   (let* ((handle (car data))
 789          (status (cadr data))
 790          (event (caddr data))
 791          (reply (gnus-icalendar-with-decoded-handle handle
 792                   (gnus-icalendar-event-reply-from-buffer
 793                    (current-buffer) status (gnus-icalendar-identities)))))
 794
 795     (when reply
 796       (gmm-labels ((fold-icalendar-buffer ()
 797                (goto-char (point-min))
 798                (while (re-search-forward "^\\(.\\{72\\}\\)\\(.+\\)$" nil t)
 799                  (replace-match "\\1\n \\2")
 800                  (goto-char (line-beginning-position)))))
 801         (let ((subject (concat (capitalize (symbol-name status))
 802                                ": " (gnus-icalendar-event:summary event))))
 803
 804           (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname)
 805             (delete-region (point-min) (point-max))
 806             (insert reply)
 807             (fold-icalendar-buffer)
 808             (gnus-icalendar-send-buffer-by-mail (buffer-name) subject))
 809
 810           ;; Back in article buffer
 811           (setq-local gnus-icalendar-reply-status status)
 812           (when gnus-icalendar-org-enabled-p
 813             (gnus-icalendar--update-org-event event status)
 814             ;; refresh article buffer to update the reply status
 815             (with-current-buffer gnus-summary-buffer
 816               (gnus-summary-show-article))))))))
 817
 818 (defun gnus-icalendar-sync-event-to-org (event)
 819   (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status))
 820
 821 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle)
 822   (when (gnus-icalendar-event:rsvp event)
 823     `(("Accept" gnus-icalendar-reply (,handle accepted ,event))
 824       ("Tentative" gnus-icalendar-reply (,handle tentative ,event))
 825       ("Decline" gnus-icalendar-reply (,handle declined ,event)))))
 826
 827 (defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event-reply) handle)
 828   "No buttons for REPLY events."
 829   nil)
 830
 831 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event))
 832   (or (when gnus-icalendar-org-enabled-p
 833         (gnus-icalendar--get-org-event-reply-status event))
 834       "Not replied yet"))
 835
 836 (defmethod gnus-icalendar-event:inline-reply-status ((event gnus-icalendar-event-reply))
 837   "No reply status for REPLY events."
 838   nil)
 839
 840
 841 (defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event))
 842   (let* ((org-entry-exists-p (gnus-icalendar-find-org-event-file event))
 843          (export-button-text (if org-entry-exists-p "Update Org Entry" "Export to Org")))
 844
 845     (delq nil (list
 846                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 847                (when (gnus-icalendar-event-request-p event)
 848                  `(,export-button-text gnus-icalendar-sync-event-to-org ,event))
 849                (when org-entry-exists-p
 850                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 851
 852
 853 (defmethod gnus-icalendar-event:inline-org-buttons ((event gnus-icalendar-event-cancel))
 854   (let ((org-entry-exists-p (gnus-icalendar-find-org-event-file event)))
 855
 856     (delq nil (list
 857                `("Show Agenda" gnus-icalendar-show-org-agenda ,event)
 858                (when org-entry-exists-p
 859                  `("Update Org Entry" gnus-icalendar-sync-event-to-org ,event))
 860                (when org-entry-exists-p
 861                  `("Show Org Entry" gnus-icalendar--show-org-event ,event))))))
 862
 863
 864 (defun gnus-icalendar-mm-inline (handle)
 865   (let ((event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
 866
 867     (setq gnus-icalendar-reply-status nil)
 868
 869     (when event
 870       (gmm-labels ((insert-button-group (buttons)
 871                 (when buttons
 872                   (mapc (lambda (x)
 873                           (apply 'gnus-icalendar-insert-button x)
 874                           (insert "    "))
 875                         buttons)
 876                   (insert "\n\n"))))
 877
 878         (insert-button-group
 879          (gnus-icalendar-event:inline-reply-buttons event handle))
 880
 881         (when gnus-icalendar-org-enabled-p
 882           (insert-button-group (gnus-icalendar-event:inline-org-buttons event)))
 883
 884         (setq gnus-icalendar-event event
 885               gnus-icalendar-handle handle)
 886
 887         (insert (gnus-icalendar-event->gnus-calendar
 888                  event
 889                  (gnus-icalendar-event:inline-reply-status event)))))))
 890
 891 (defun gnus-icalendar-save-part (handle)
 892   (let (event)
 893     (when (and (equal (car (mm-handle-type handle)) "text/calendar")
 894                (setq event (gnus-icalendar-event-from-handle handle (gnus-icalendar-identities))))
 895
 896       (gnus-icalendar-event:sync-to-org event))))
 897
 898
 899 (defun gnus-icalendar-save-event ()
 900   "Save the Calendar event in the text/calendar part under point."
 901   (interactive)
 902   (gnus-article-check-buffer)
 903   (let ((data (get-text-property (point) 'gnus-data)))
 904     (when data
 905       (gnus-icalendar-save-part data))))
 906
 907 (defun gnus-icalendar-reply-accept ()
 908   "Accept invitation in the current article."
 909   (interactive)
 910   (with-current-buffer gnus-article-buffer
 911     (gnus-icalendar-reply (list gnus-icalendar-handle 'accepted gnus-icalendar-event))
 912     (setq-local gnus-icalendar-reply-status 'accepted)))
 913
 914 (defun gnus-icalendar-reply-tentative ()
 915   "Send tentative response to invitation in the current article."
 916   (interactive)
 917   (with-current-buffer gnus-article-buffer
 918     (gnus-icalendar-reply (list gnus-icalendar-handle 'tentative gnus-icalendar-event))
 919     (setq-local gnus-icalendar-reply-status 'tentative)))
 920
 921 (defun gnus-icalendar-reply-decline ()
 922   "Decline invitation in the current article."
 923   (interactive)
 924   (with-current-buffer gnus-article-buffer
 925     (gnus-icalendar-reply (list gnus-icalendar-handle 'declined gnus-icalendar-event))
 926     (setq-local gnus-icalendar-reply-status 'declined)))
 927
 928 (defun gnus-icalendar-event-export ()
 929   "Export calendar event to `org-mode', or update existing agenda entry."
 930   (interactive)
 931   (with-current-buffer gnus-article-buffer
 932     (gnus-icalendar-sync-event-to-org gnus-icalendar-event))
 933   ;; refresh article buffer in case the reply had been sent before initial org
 934   ;; export
 935   (with-current-buffer gnus-summary-buffer
 936     (gnus-summary-show-article)))
 937
 938 (defun gnus-icalendar-event-show ()
 939   "Display `org-mode' agenda entry related to the calendar event."
 940   (interactive)
 941   (gnus-icalendar--show-org-event
 942    (with-current-buffer gnus-article-buffer
 943      gnus-icalendar-event)))
 944
 945 (defun gnus-icalendar-event-check-agenda ()
 946   "Display `org-mode' agenda for days between event start and end dates."
 947   (interactive)
 948   (gnus-icalendar-show-org-agenda
 949    (with-current-buffer gnus-article-buffer gnus-icalendar-event)))
 950
 951 (defvar gnus-mime-action-alist)         ; gnus-art
 952
 953 (defun gnus-icalendar-setup ()
 954   (add-to-list 'mm-inlined-types "text/calendar")
 955   (add-to-list 'mm-automatic-display "text/calendar")
 956   (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity))
 957
 958   (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map)
 959     "a" gnus-icalendar-reply-accept
 960     "t" gnus-icalendar-reply-tentative
 961     "d" gnus-icalendar-reply-decline
 962     "c" gnus-icalendar-event-check-agenda
 963     "e" gnus-icalendar-event-export
 964     "s" gnus-icalendar-event-show)
 965
 966   (require 'gnus-art)
 967   (add-to-list 'gnus-mime-action-alist
 968                (cons "save calendar event" 'gnus-icalendar-save-event)
 969                t))
 970
 971 (provide 'gnus-icalendar)
 972
 973 ;;; gnus-icalendar.el ends here