path: root/third_party/lisp/mime4cl/address.lisp

;;;  address.lisp --- e-mail address parser

;;;  Copyright (C) 2007, 2008, 2009 by Walter C. Pelissero
;;;  Copyright (C) 2022-2023 The TVL Authors

;;;  Author: Walter C. Pelissero <walter@pelissero.de>
;;;  Project: mime4cl

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
;;; as published by the Free Software Foundation; either version 2.1
;;; of the License, or (at your option) any later version.
;;; This library 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
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA

;;;  Although not MIME specific, this parser is often useful together
;;;  with the MIME primitives.  It should be able to parse the address
;;;  syntax described in RFC2822 excluding the obsolete syntax (see
;;;  RFC822).  Have a look at the test suite to get an idea of what
;;;  kind of addresses it can parse.

(in-package :mime4cl)

(defstruct (mailbox (:conc-name mbx-))
  description
  user
  host
  domain)

(defstruct (mailbox-group (:conc-name mbxg-))
  name
  mailboxes)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun write-mailbox-domain-name (addr &optional (stream *standard-output*))
  (when (eq :internet (mbx-domain addr))
    (write-char #\[ stream))
  (write-string (mbx-host addr) stream)
  (when (eq :internet (mbx-domain addr))
    (write-char #\] stream))
  (when (stringp (mbx-domain addr))
    (write-char #\. stream)
    (write-string (mbx-domain addr) stream)))

(defun write-mailbox-address (addr &optional (stream *standard-output*))
  (write-string (mbx-user addr) stream)
  (when (mbx-host addr)
    (write-char #\@ stream)
    (write-mailbox-domain-name addr stream)))

(defmethod mbx-domain-name ((MBX mailbox))
  "Return the complete domain name string of MBX, in the form
\"host.domain\"."
  (with-output-to-string (out)
    (write-mailbox-domain-name mbx out)))

(defmethod mbx-address ((mbx mailbox))
  "Return the e-mail address string of MBX, in the form
\"user@host.domain\"."
  (with-output-to-string (out)
    (write-mailbox-address mbx out)))

(defun write-mailbox (addr &optional (stream *standard-output*))
  (awhen (mbx-description addr)
    (write it :stream stream :readably t)
    (write-string " <" stream))
  (write-mailbox-address addr stream)
  (awhen (mbx-description addr)
    (write-char #\> stream)))

(defun write-mailbox-group (grp &optional (stream *standard-output*))
  (write-string (mbxg-name grp) stream)
  (write-string ": " stream)
  (loop
     for mailboxes on (mbxg-mailboxes grp)
     for mailbox = (car mailboxes)
     do (write-mailbox mailbox stream)
     unless (endp (cdr mailboxes))
     do (write-string ", " stream))
  (write-char #\; stream))

(defmethod print-object ((mbx mailbox) stream)
  (if (or *print-readably* *print-escape*)
      (call-next-method)
      (write-mailbox mbx stream)))

(defmethod print-object ((grp mailbox-group) stream)
  (if (or *print-readably* *print-escape*)
      (call-next-method)
      (write-mailbox-group grp stream)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun parser-make-mailbox (description address-list)
  (make-mailbox :description description
                :user (car address-list)
                :host (cadr address-list)
                :domain (when (cddr address-list)
                          (string-concat (cddr address-list) "."))))


(defun populate-grammar ()
  (defrule address-list
      := (+ address ","))

  (defrule address
      := mailbox
      := group)

  (defrule mailbox
      := display-name? angle-addr comment?
      :reduce (parser-make-mailbox (or display-name comment) angle-addr)
      := addr-spec comment?
      :reduce (parser-make-mailbox comment addr-spec))

  (defrule angle-addr
      := "<" addr-spec ">")

  (defrule group
      := display-name ":" mailbox-list ";"
      :reduce (make-mailbox-group :name display-name :mailboxes mailbox-list))

  (defrule display-name
      := phrase
      :reduce (string-concat phrase " "))

  (defrule phrase
      := word+)

  (defrule word
      := atext
      := string)

  (defrule mailbox-list
      := (+ mailbox ","))

  (defrule addr-spec
      := local-part "@" domain :reduce (cons local-part domain))

  (defrule local-part
      := dot-atom :reduce (string-concat dot-atom ".")
      := string)

  (defrule domain
      := dot-atom
      := domain-literal :reduce (list domain-literal :internet))

  ;; actually, according to the RFC, dot-atoms don't allow spaces in
  ;; between but these rules do
  (defrule dot-atom
      := (+ atom "."))

  (defrule atom
      := atext+
      :reduce (apply #'concatenate 'string atext)))

(deflazy define-grammar
  (let ((*package* #.*package*)
        (*compile-print* (when npg::*debug* t)))
    (reset-grammar)
    (format t "~&creating e-mail address grammar...~%")
    (populate-grammar)
    (let ((grammar (npg:generate-grammar #'string=)))
      (reset-grammar)
      (npg:print-grammar-figures grammar)
      grammar)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The lexical analyser

(defstruct cursor
  stream
  (position 0))

(defun read-delimited-string (stream end-char &key nesting-start-char (escape-char #\\))
  (labels ((collect ()
             (with-output-to-string (out)
               (loop
                  for c = (read-char stream nil)
                  while (and c (not (char= c end-char)))
                  do (cond ((char= c escape-char)
                            (awhen (read-char stream nil)
                              (write-char it out)))
                           ((and nesting-start-char
                                 (char= c nesting-start-char))
                            (write-char nesting-start-char out)
                            (write-string (collect) out)
                            (write-char end-char out))
                           (t (write-char c out)))))))
    (collect)))


(defun read-string (cursor)
  (make-token :type 'string
              :value (read-delimited-string (cursor-stream cursor) #\")
              :position (incf (cursor-position cursor))))

(defun read-domain-literal (cursor)
  (make-token :type 'domain-literal
              :value (read-delimited-string (cursor-stream cursor) #\])
              :position (incf (cursor-position cursor))))

(defun read-comment (cursor)
  (make-token :type 'comment
              :value (read-delimited-string (cursor-stream cursor) #\) :nesting-start-char #\()
              :position (incf (cursor-position cursor))))

(declaim (inline atom-component-p))
(defun atom-component-p (c)
  (declare (type character c))
  (not (find c " ()\"[]@.<>:;,")))

(defun read-atext (first-character cursor)
  (let ((string (with-output-to-string (out)
                  (write-char first-character out)
                  (loop
                    for c = (read-char (cursor-stream cursor) nil)
                    while (and c (atom-component-p c))
                    do (write-char c out)
                    finally (when c
                              (unread-char c (cursor-stream cursor)))))))
    (make-token :type 'atext
                :value string
                :position (incf (cursor-position cursor)))))

(defmethod read-next-tokens ((cursor cursor))
  (flet ((make-keyword (c)
           (make-token :type 'keyword
                       :value (string c)
                       :position (incf (cursor-position cursor)))))
    (let ((in (cursor-stream cursor)))
      (loop
         for c = (read-char in nil)
         while c
         unless (whitespace-p c)
         return (list
                 (cond ((char= #\( c)
                        (read-comment cursor))
                       ((char= #\" c)
                        (read-string cursor))
                       ((char= #\[ c)
                        (read-domain-literal cursor))
                       ((find c "@.<>:;,")
                        (make-keyword c))
                       (t
                        ;; anything else is considered a text atom even
                        ;; though it's just a single character
                        (read-atext c cursor))))))))

(defun analyse-string (string)
  "Return the list of tokens produced by a lexical analysis of
STRING.  These are the tokens that would be seen by the parser."
  (with-input-from-string (stream string)
    (let ((cursor (make-cursor :stream stream)))
      (loop
         for tokens = (read-next-tokens cursor)
         until (endp tokens)
         append tokens))))

(defun mailboxes-only (list-of-mailboxes-and-groups)
  "Return a flat list of MAILBOX-ADDRESSes from
LIST-OF-MAILBOXES-AND-GROUPS, which is the kind of list returned
by PARSE-ADDRESSES.  This turns out to be useful when your
program is not interested in mailbox groups and expects the user
addresses only."
  (mapcan #'(lambda (mbx)
              (if (typep mbx 'mailbox-group)
                  (mbxg-mailboxes mbx)
                  (list mbx)))
          list-of-mailboxes-and-groups))

(defun parse-addresses (string &key no-groups)
  "Parse STRING and return a list of MAILBOX-ADDRESSes or
MAILBOX-GROUPs.  If STRING is unparsable return NIL.  If
NO-GROUPS is true, return a flat list of mailboxes throwing away
the group containers, if any."
  (let ((grammar (force define-grammar)))
    (with-input-from-string (stream string)
      (let* ((cursor (make-cursor :stream stream))
             (mailboxes (ignore-errors  ; ignore parsing errors
                         (parse grammar 'address-list cursor))))
        (if no-groups
            (mailboxes-only mailboxes)
            mailboxes)))))

(defun debug-addresses (string)
  "More or less like PARSE-ADDRESSES, but don't ignore parsing errors."
  (let ((grammar (force define-grammar)))
    (with-input-from-string (stream string)
      (let ((cursor (make-cursor :stream stream)))
        (parse grammar 'address-list cursor)))))