master 8dc85d1db4: Enable Better Alignment of EUDC Inline Expansion With RFC5322

[Thomas Fitzsimmons]

branch: master
commit 8dc85d1db4564f0d9df847b7884c920a0f8d7fe9
Author: Alexander Adolf <alexander.adolf@condition-alpha.com>
Commit: Thomas Fitzsimmons <fitzsim@fitzsim.org>

    Enable Better Alignment of EUDC Inline Expansion With RFC5322
    
    The format of EUDC inline expansion results is formatted according to
    the variable eudc-inline-expansion-format, which previously defaulted
    to '("%s %s <%s>" firstname name email).
    
    Since email address specifications need to comply with RFC 5322 in
    order to be useful in messages, there was little headroom for users to
    change this format anyway. Plus, if an EUDC back-end returned an empty
    first and last name, the result was the email address in angle
    brackets. Whilst this was standard with RFC 822, it is marked as
    obsolete syntax by its successor RFC 5322. Also, the first and last
    name part was never enclosed in double quotes, potentially producing
    invalid address specifications, which may be rejected by a receiving
    MTA.
    
    This commit updates the variable eudc-inline-expansion-format, so that
    it can, in addition to the current ("format" attributes) list, now
    alternatively be set to nil, or a formatting function. In both cases
    the resulting email address is formatted using the new function
    eudc-rfc5322-make-address, whose results fully comply with RFC 5322.
    
    If the value is nil (the new default value), eudc-rfc5322-make-address
    will be called to produce any of the default formats
    
                                   ADDRESS
                               FIRST <ADDRESS>
                                LAST <ADDRESS>
                             FIRST LAST <ADDRESS>
    
    depending on whether a first and/or last name are returned by the
    query, or not.
    
    If the value is a formatting function, that will be called to allow
    the user to supply content for the phrase and comment parts of the
    address (cf. RFC 5322). Thus one can produce any of the formats:
    
                                   ADDRESS
                               PHRASE <ADDRESS>
                              ADDRESS (COMMENT)
                          PHRASE <ADDRESS> (COMMENT)
    
    This can for example be used to get "last, first <address>" instead of
    the default "first last <address>".
    
    In any case when using nil, or the formatting function, the phrase
    part of the result will be enclosed in double quotes if needed, and
    the comment part will be omitted if it contains characters not allowed
    by RFC 5322.
    
    When eudc-inline-expansion-format remains set to a list as previously,
    the old behaviour is fully retained.
---
 doc/misc/eudc.texi    |  73 +++++++++++++++++++++--
 etc/NEWS              |  20 +++++++
 lisp/net/eudc-vars.el |  64 ++++++++++++++------
 lisp/net/eudc.el      | 161 ++++++++++++++++++++++++++++++++++++++++++--------
 4 files changed, 270 insertions(+), 48 deletions(-)

diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi
index 3b24dfb919..f61ce7012e 100644
--- a/doc/misc/eudc.texi
+++ b/doc/misc/eudc.texi
@@ -795,12 +795,73 @@ against the @code{cn} attribute of LDAP servers:
 @end defvar
 
 @defvar eudc-inline-expansion-format
-This variable lets you control exactly what is inserted into the buffer
-upon an inline expansion request.  It is a list whose first element is a
-string passed to @code{format}.  Remaining elements are symbols
-corresponding to directory attribute names.  The corresponding attribute
-values are passed as additional arguments to @code{format}.  Default is
-@code{("%s %s <%s>" firstname name email)}.
+This variable lets you control exactly what is inserted into the
+buffer upon an inline expansion request. It can be set to @code{nil},
+to a function, or to a list.  Default is @code{nil}.
+
+When the value is a list, the first element is a string passed to
+@code{format}.  Remaining elements are symbols corresponding to
+directory attribute names.  The corresponding attribute values are
+passed as additional arguments to @code{format}.
+
+When the value is @code{nil}, the expansion result will be formatted
+according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC
+5322}.  The @var{phrase} part will be formatted as ``firstname name'',
+quoting the result if necessary.  No @var{comment} part will be added
+in this case.  This will produce any of the default formats
+@center @var{address}
+@center @var{first} @code{<}@var{address}@code{>}
+@center @var{last} @code{<}@var{address}@code{>
+@center @var{first} @var{last} @code{<}@var{address}@code{>}
+depending on whether a first and/or last name are returned by the
+query, or not.
+
+When the value is a function, the expansion result will be formatted
+according to @url{https://datatracker.ietf.org/doc/html/rfc5322, RFC
+5322}, and the referenced function is called to format the
+@var{phrase}, and @var{comment} parts, respectively.  The formatted
+@var{phrase} part will be quoted if necessary.  Thus one can produce
+any of the formats:
+@center @var{address}
+@center @var{phrase} @code{<}@var{address}@code{>}
+@center @var{address} @code{(}@var{comment}@code{)}
+@center @var{phrase} @code{<}@var{address}@code{>} 
@code{(}@var{comment}@code{)}
+
+Email address specifications, as are generated by inline expansion,
+need to comply with RFC 5322 in order to be useful in email
+messages. When an invalid address specification is present in an email
+message header, the message is likely to be rejected by a receiving
+MTA.  It is hence recommended to switch old configurations, which use
+a list value, to the new @code{nil}, or function value type since it
+ensures that the inserted address specifications will be in line with
+@url{https://datatracker.ietf.org/doc/html/rfc5322, RFC 5322}.  At
+minimum, and to achieve the same semantics as with the old list
+default value, this variable should now be set to @code{nil}:
+@lisp
+(customize-set-variable 'eudc-inline-expansion-format nil)
+@end lisp
+
+A function value can for example be used to get @emph{``last, first
+<address>''} instead of the default @emph{``first last <address>''}:
+@lisp
+(defun my-phrase-last-comma-first (search-res-alist)
+  (let* (phrase
+        (my-attrs (eudc-translate-attribute-list '(firstname name)))
+        (first-name (cdr (assq (nth 0 my-attrs) search-res-alist)))
+        (last-name (cdr (assq (nth 1 my-attrs) search-res-alist)))
+         (comment nil))
+    (setq phrase (concat last-name ", " first-name))
+    (cons phrase comment)))
+
+(customize-set-variable 'eudc-inline-expansion-format
+                        #'my-phrase-last-comma-first)
+@end lisp
+To set the @var{comment} part, too, instead of @code{nil} as in this
+example, also provide a string as the @code{cdr} of the @code{cons}
+being returned.  Do not include any double quotes in the @var{phrase}
+part, as they are added automatically if needed.  Neither include
+parentheses in the @var{comment} part as they, too, are added
+automatically.
 @end defvar
 
 @defvar eudc-multiple-match-handling-method
diff --git a/etc/NEWS b/etc/NEWS
index abee5fcb99..94f6674a18 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -695,6 +695,26 @@ from all servers instead of just the matches from the 
first server to
 return any.  This is useful for example, if one wants to search LDAP
 for a name that happens to match a contact in one's BBDB.
 
++++
+*** New behaviour and default for option 'eudc-inline-expansion-format'
+EUDC inline expansion result formatting defaulted to
+
+                 '("%s %s <%s>" firstname name email)
+
+Since email address specifications need to comply with RFC 5322 in
+order to be useful in messages, there was a risk to produce syntax
+which was standard with RFC 822, but is marked as obsolete syntax by
+its successor RFC 5322.  Also, the first and last name part was never
+enclosed in double quotes, potentially producing invalid address
+specifications, which may be rejected by a receiving MTA.  Thus, this
+variable can now additionally be set to nil (the new default), or a
+function.  In both cases, the formatted result will be in compliance
+with RFC 5322.  When set to nil, a default format very similar to the
+old default will be produced.  When set to a function, that function
+is called, and the returned values are used to populate the phrase and
+comment parts (see RFC 5322 for definitions). In both cases, the
+phrase part will be automatically quoted if necessary.
+
 ** eww/shr
 
 +++
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 997b9e30fd..d58fab896e 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -191,25 +191,51 @@ must be set in a protocol/server-local fashion, see 
`eudc-server-set' and
   :type  'boolean
   :version "25.1")
 
-(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email)
-  "A list specifying the format of the expansion of inline queries.
-This variable controls what `eudc-expand-inline' actually inserts in
-the buffer.  First element is a string passed to `format'.  Remaining
-elements are symbols indicating attribute names; the corresponding values
-are passed as additional arguments to `format'."
-  :type  '(list
-          (string :tag "Format String")
-          (repeat :inline t
-                  :tag "Attributes"
-                  (choice
-                   :tag "Attribute"
-                   (const :menu-tag "First Name" :tag "First Name" firstname)
-                   (const :menu-tag "Surname" :tag "Surname" name)
-                   (const :menu-tag "Email Address" :tag "Email Address" email)
-                   (const :menu-tag "Phone" :tag "Phone" phone)
-                   (symbol :menu-tag "Other")
-                   (symbol :tag "Attribute name"))))
-  :version "25.1")
+(defcustom eudc-inline-expansion-format nil
+  "Specify the format of the expansion of inline queries.
+This variable controls what `eudc-expand-inline' actually inserts
+in the buffer. It is either a list, or a function.
+
+When set to a list, the expansion result will be formatted
+according to the first element of the list, a string, which is
+passed as the first argument to `format'.  The remaining elements
+of the list are symbols indicating attribute names; the
+corresponding values are passed as additional arguments to
+`format'.
+
+When set to nil, the expansion result will be formatted using
+`eudc-rfc5322-make-address', and the PHRASE part will be
+formatted according to \"firstname name\", quoting the result if
+necessary.  No COMMENT will be added in this case.
+
+When set to a function, the expansion result will be formatted
+using `eudc-rfc5322-make-address', and the referenced function is
+used to format the PHRASE, and COMMENT parts, respectively.  It
+receives a single argument, which is an alist of
+protocol-specific attributes describing the recipient.  To access
+the alist elements using generic EUDC attribute names, such as
+for example name, or email, use `eudc-translate-attribute-list'.
+The function should return a list, which should contain two
+elements.  If the first element is a string, it will be used as
+the PHRASE part, quoting it if necessary. If the second element
+is a string, it will be used as the COMMENT part, unless it
+contains characters not allowed in the COMMENT part by RFC 5322,
+in which case the COMMENT part will be omitted."
+  :type '(choice (const :tag "RFC 5322 formatted \"first last <address>\"" nil)
+                 (function :tag "RFC 5322 phrase/comment formatting function")
+                 (list :tag "Format string (deprecated)"
+                      (string :tag "Format String")
+                      (repeat :inline t
+                              :tag "Attributes"
+                              (choice
+                               :tag "Attribute"
+                               (const :menu-tag "First Name" :tag "First Name" 
firstname)
+                               (const :menu-tag "Surname" :tag "Surname" name)
+                               (const :menu-tag "Email Address" :tag "Email 
Address" email)
+                               (const :menu-tag "Phone" :tag "Phone" phone)
+                               (symbol :menu-tag "Other")
+                               (symbol :tag "Attribute name")))))
+  :version "29.1")
 
 (defcustom eudc-inline-expansion-servers 'server-then-hotlist
   "Which servers to contact for the expansion of inline queries.
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 7bbf54ee6c..6ce89ce5be 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -162,6 +162,75 @@ Value is the new string."
                    newtext)))
     (concat rtn-str (substring str start))))
 
+
+(defconst eudc-rfc5322-atext-token "[:alpha:][:digit:]!#$%&'*+/=?^_`{|}~-"
+  "Printable US-ASCII characters not including specials.  Used for atoms.")
+
+(defconst eudc-rfc5322-wsp-token " \t"
+  "Non-folding white space.")
+
+(defconst eudc-rfc5322-fwsp-token
+  (concat eudc-rfc5322-wsp-token "\n")
+  "Folding white space.")
+
+(defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027"
+  "Printable US-ASCII characters not including '(', ')', or '\\'.")
+
+(defun eudc-rfc5322-quote-phrase (string)
+  "Quote STRING if it needs quoting as a phrase in a header."
+  (if (string-match
+       (concat "[^" eudc-rfc5322-wsp-token eudc-rfc5322-atext-token "]")
+       string)
+      (concat "\"" string "\"")
+    string))
+
+(defun eudc-rfc5322-valid-comment-p (string)
+  "Check if STRING can be used as comment in a header."
+  (if (string-match
+       (concat "[^" eudc-rfc5322-cctext-token eudc-rfc5322-fwsp-token "]")
+       string)
+      nil
+    t))
+
+(defun eudc-rfc5322-make-address (address &optional firstname name comment)
+  "Create a valid address specification according to RFC5322.
+RFC5322 address specifications are used in message header fields
+to indicate senders and recipients of messages.  They generally
+have one of the forms:
+
+ADDRESS
+ADDRESS (COMMENT)
+PHRASE <ADDRESS>
+PHRASE <ADDRESS> (COMMENT)
+
+The arguments FIRSTNAME and NAME are combined to form PHRASE.
+PHRASE is enclosed in double quotes if necessary.
+
+COMMENT is omitted if it contains any symbols outside the
+permitted set `eudc-rfc5322-cctext-token'."
+  (if (and address
+           (not (string-blank-p address)))
+      (let ((result address)
+            (name-given (and name
+                             (not (string-blank-p name))))
+            (firstname-given (and firstname
+                                  (not (string-blank-p firstname))))
+            (valid-comment-given (and comment
+                                      (not (string-blank-p comment))
+                                      (eudc-rfc5322-valid-comment-p comment))))
+        (if (or name-given firstname-given)
+            (let ((phrase (string-trim (concat firstname " " name))))
+              (setq result
+                    (concat
+                     (eudc-rfc5322-quote-phrase phrase)
+                     " <" result ">"))))
+        (if valid-comment-given
+            (setq result
+                  (concat result " (" comment ")")))
+        result)
+    ;; nil or empty address, nothing to return
+    nil))
+
 ;;}}}
 
 ;;{{{ Server and Protocol Variable Routines
@@ -797,6 +866,55 @@ non-nil, collect results from all servers."
        ((eq eudc-multiple-match-handling-method 'abort)
        (error "There is more than one match for the query"))))))
 
+;;;###autoload
+(defun eudc-format-inline-expansion-result (res query-attrs)
+  "Format a query result according to `eudc-inline-expansion-format'."
+  (cond
+   ;; format string
+   ((consp eudc-inline-expansion-format)
+    (string-trim (apply #'format
+                       (car eudc-inline-expansion-format)
+                       (mapcar
+                        (lambda (field)
+                          (or (cdr (assq field res))
+                              ""))
+                        (eudc-translate-attribute-list
+                         (cdr eudc-inline-expansion-format))))))
+
+   ;; formatting function
+   ((functionp eudc-inline-expansion-format)
+    (let ((addr (cdr (assq (nth 2 query-attrs) res)))
+          (ucontent (funcall eudc-inline-expansion-format res)))
+      (if (and ucontent
+               (listp ucontent))
+          (let* ((phrase (car ucontent))
+                 (comment (cadr ucontent))
+                 (phrase-given
+                  (and phrase
+                       (stringp phrase)
+                       (not (string-blank-p phrase))))
+                 (valid-comment-given
+                  (and comment
+                       (stringp comment)
+                       (not (string-blank-p comment))
+                       (eudc-rfc5322-valid-comment-p
+                        comment))))
+            (eudc-rfc5322-make-address
+             addr nil
+             (if phrase-given phrase nil)
+             (if valid-comment-given comment nil)))
+        (progn
+          (error "Error: the function referenced by \
+`eudc-inline-expansion-format' is expected to return a list.")
+          nil))))
+
+   ;; fallback behaviour (nil function, or non-matching type)
+   (t
+    (let ((fname (cdr (assq (nth 0 query-attrs) res)))
+          (lname (cdr (assq (nth 1 query-attrs) res)))
+          (addr (cdr (assq (nth 2 query-attrs) res))))
+      (eudc-rfc5322-make-address addr fname lname)))))
+
 ;;;###autoload
 (defun eudc-query-with-words (query-words &optional try-all-servers)
   "Query the directory server, and return the matching responses.
@@ -804,7 +922,7 @@ The variable `eudc-inline-query-format' controls how to 
associate the
 individual QUERY-WORDS with directory attribute names.
 After querying the server for the given string, the expansion
 specified by `eudc-inline-expansion-format' is applied to the
-matches before returning them.inserted in the buffer at point.
+matches before returning them.
 Multiple servers can be tried with the same query until one finds a match,
 see `eudc-inline-expansion-servers'.   When TRY-ALL-SERVERS is non-nil,
 keep collecting results from subsequent servers after the first match."
@@ -848,28 +966,25 @@ keep collecting results from subsequent servers after the 
first match."
     (unwind-protect
        (cl-flet
            ((run-query
-              (query-formats)
-              (let ((response
-                     (eudc-query
-                      (eudc-format-query query-words (car query-formats))
-                      (eudc-translate-attribute-list
-                       (cdr eudc-inline-expansion-format)))))
-                (when response
-                  ;; Process response through eudc-inline-expansion-format.
-                  (dolist (r response)
-                    (let ((response-string
-                          (apply #'format
-                                  (car eudc-inline-expansion-format)
-                                  (mapcar
-                                   (lambda (field)
-                                     (or (cdr (assq field r))
-                                         ""))
-                                   (eudc-translate-attribute-list
-                                    (cdr eudc-inline-expansion-format))))))
-                      (if (> (length response-string) 0)
-                          (push response-string response-strings))))
-                  (when (not try-all-servers)
-                    (throw 'found nil))))))
+              (query-formats)
+              (let* ((query-attrs (eudc-translate-attribute-list
+                                        (if (consp 
eudc-inline-expansion-format)
+                                            (cdr eudc-inline-expansion-format)
+                                          '(firstname name email))))
+                     (response
+                      (eudc-query
+                       (eudc-format-query query-words (car query-formats))
+                       query-attrs)))
+                (when response
+                  ;; Format response.
+                  (dolist (r response)
+                    (let ((response-string
+                           (eudc-format-inline-expansion-result r 
query-attrs)))
+                      (if response-string
+                          (cl-pushnew response-string response-strings
+                                      :test #'equal))))
+                  (when (not try-all-servers)
+                    (throw 'found nil))))))
          (catch 'found
            ;; Loop on the servers.
            (dolist (server servers)