emacs/lisp/net/eudcb-macos-contacts.el

;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend  -*- lexical-binding: t; -*-

;; Copyright (C) 2020-2022 Free Software Foundation, Inc.

;; Author: Alexander Adolf

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:
;;    This library provides an interface to the macOS Contacts app as
;;    an EUDC data source.  It uses AppleScript to interface with the
;;    Contacts app on localhost, so no 3rd party tools are needed.

;;; Usage:
;;    To load the library, first `require' it:
;;
;;      (require 'eudcb-macos-contacts)
;;
;;    In the simplest case then just use:
;;
;;      (eudc-macos-contacts-set-server "localhost")
;;
;;    When using `eudc-server-hotlist', instead use:
;;
;;      (add-to-list 'eudc-server-hotlist '("localhost" . macos-contacts))

;;; Code:

(require 'eudc)
(require 'executable)

;;{{{      Internal cooking

(defvar eudc-macos-contacts-attributes-translation-alist
  '((name      . last_name)
    (firstname . first_name)
    (email     . email)
    (phone     . phone)
    (title     . job_title)
    (o         . organization)
    (ou        . department))
  "See `eudc-protocol-attributes-translation-alist'.")

(defconst eudc-macos-contacts--unsearchable-attributes
  '(email phone)
  "See `eudc-macos-contacts-search-helper'.")

;; hook ourselves into the EUDC framework
(eudc-protocol-set 'eudc-query-function
                   'eudc-macos-contacts-query-internal
                   'macos-contacts)
(eudc-protocol-set 'eudc-list-attributes-function
                   nil
                   'macos-contacts)
(eudc-protocol-set 'eudc-protocol-attributes-translation-alist
                   'eudc-macos-contacts-attributes-translation-alist
                   'macos-contacts)
(eudc-protocol-set 'eudc-protocol-has-default-query-attributes
                   nil
                   'macos-contacts)

(defun eudc-macos-contacts-search-helper (query)
  "Helper function to query the Contacts app via AppleScript.
Searches for all persons matching QUERY.  QUERY is a list of cons
cells (ATTR . VALUE) where ATTRs should be valid macOS Contacts
attribute names with space characters replaced by `_' characters.
Thus, to for instance search for the \"first name\" attribute in
the Contacts app, the corresponding ATTR would be the symbol
`first_name'.

Note that due to the way the Contacts app exposes its data via
AppleScript, the attributes listed in
`eudc-macos-contacts--unsearchable-attributes' can not be searched
efficiently.  If and when one of these attributes appears in
QUERY, it is thus skipped, and the query is composed from the
other attributes in the QUERY."
  (let ((crit-idx 0)
        (query-str (string)))
    ;; assemble a query string for use in an AppleScript "whose"
    ;; filter clause; generally, this has the form
    ;; (ATTR1 contains "VALUE1") and (ATTR2 contains "VALUE2") and ...
    (dolist (criterion query)
      (let ((attr (string-replace "_" " " (symbol-name (car criterion))))
            (term (cdr criterion)))
        ;; defend against unusable attribute names as they cause
        ;; AppleScript to emit an error message, which in turn will
        ;; cause elisp errors during results parsing in
        ;; `eudc-macos-contacts-query-internal'
        (if (or (not (rassq (car criterion)
                            eudc-macos-contacts-attributes-translation-alist))
                (memq (car criterion)
                      eudc-macos-contacts--unsearchable-attributes))
            (message (concat "[eudc] Warning in macOS Contacts backend: "
                             "can not search in attribute "
                             (format "\"%s\"; skipping it."  attr)))
          (progn
            (when (> crit-idx 0)
              (setq query-str (concat query-str " and ")))
            (setq query-str (concat query-str
                                    (format "(%s contains \"%s\")" attr term)))
            (setq crit-idx (1+ crit-idx))))))
    ;; if a useful query string could be assembled, insert it into the
    ;; AppleScript template, and run the resulting script; results are
    ;; captured in the current buffer
    (if (not (string= query-str ""))
        (if (executable-find "osascript")
            (call-process "osascript" nil t nil
                          "-e"
                          (format "
on joinLines(theText)
        if (theText is missing value) or (theText is \"\") then
                return \"\"
        else
                set thePars to paragraphs of theText
                set result to {}
                repeat with para in thePars
                        set result to result & {para & space}
                end repeat
                return text 1 thru -2 of (result as text)
        end if
end joinLines

on run
        set results to {}
        tell application \"Address Book\"
                set pList to every person whose %s
                repeat with pers in pList
                        set pText to ¬
                                first name of pers & \":\" & ¬
                                last name of pers & \":\"
                        if (job title of pers is not missing value) then ¬
                                set pText to pText ¬
                                        & my joinLines(job title of pers)
                        set pText to pText & \":\"
                        if (department of pers is not missing value) then ¬
                                set pText to pText ¬
                                        & my joinLines(department of pers)
                        set pText to pText & \":\"
                        if (organization of pers is not missing value) then ¬
                                set pText to pText ¬
                                        & my joinLines(organization of pers)
                        set pText to pText & \":\"
                        if (count emails of pers) > 0 then
                                repeat with emailAddr in emails of pers
                                        set pText to pText & value ¬
                                                of emailAddr & \",\"
                                end repeat
                                set pText to text 1 thru -2 of pText
                        end if
                        set pText to pText & \":\"
                        if (count phones of pers) > 0 then
                                repeat with phoneNmbr in phones of pers
                                        set pText to pText & value ¬
                                                of phoneNmbr & \",\"
                                end repeat
                                set pText to text 1 thru -2 of pText
                        end if
                        set results to results & {pText & \"\n\"}
                end repeat
                get results as text
        end tell
end run
" query-str))
          (message (concat "[eudc] Error in macOS Contacts backend: "
                           "`osascript' executable not found. "
                           "Is this is a macOS 10.0 or later system?"))))))

(defun eudc-macos-contacts-query-internal (query &optional _return-attrs)
  "Query macOS Contacts with QUERY.
QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid
macOS Contacts attribute names.
RETURN-ATTRS is a list of attributes to return, defaulting to
`eudc-default-return-attributes'."
  (let ((macos-contacts-buffer (get-buffer-create " *macOS Contacts*"))
        result)
    (with-current-buffer macos-contacts-buffer
      (erase-buffer)
      (eudc-macos-contacts-search-helper query)
      (delete-duplicate-lines (point-min) (point-max))
      (goto-char (point-min))
      (while (not (eobp))
        (if (not (equal (line-beginning-position) (line-end-position)))
            (let ((keys '(first_name last_name job_title department
                          organization email phone))
                  record)
              (dolist (field (split-string (buffer-substring
                                            (point) (line-end-position))
                                           ":"))
                (let ((key (pop keys)))
                  (unless (string= "" field)
                    (pcase key
                      ((or 'email 'phone) (dolist (x (split-string field ","))
                                            (push (cons key x) record)))
                      (_ (push (cons key field) record))))))
              (unless (length= record 0)
                (push (nreverse record) result))))
        (forward-line))
      result)))

;;}}}

;;{{{      High-level interfaces (interactive functions)

(defun eudc-macos-contacts-set-server (dummy)
  "Set the EUDC server to macOS Contacts app.
The server in DUMMY is not actually used, since this backend
always and implicitly connects to an instance of the Contacts app
running on the local host."
  (interactive)
  (eudc-set-server dummy 'macos-contacts)
  (message "[eudc] macOS Contacts app server selected"))

;;}}}

(eudc-register-protocol 'macos-contacts)

(provide 'eudcb-macos-contacts)

;;; eudcb-macos-contacts.el ends here