see ChangeLog

ChangeLog

@@ -1,3 +1,30 @@
+2003-05-15  root  <root@gills.dancysoft.com>
+
+	* aliases.cl:  Make sure that only one thread reparses the aliases
+	file.   Removed a bunch of stuff that became redundant with the
+	new recips code.
+
+	* emailaddr.cl:  Added some extra utility functions (for use in
+	recips.cl, mainly).
+
+	* input.cl:  send-from-smtp:  Accept emailaddr or recip struct
+	type recips.   use new get-good-recips-from-string function in
+	grab-recips-from-headers.  
+
+	* load.cl:  Load recips.cl before aliases.cl.
+
+	* maild.cl:  Added -bv mode for testing address parsing.
+	Simplified command line recipient processing by using new
+	get-good-recips-from-string function.
+
+	* queue.cl:  queue-finalize:  Accept emailaddr or recip type
+	recips.
+
+	* recips.cl:  Added 'orig' slot to recip struct for recording the
+	string that was originally parsed.    get-recipient-disposition
+	accepts emailaddr or recip struct arg now.   Improved address list
+	parsing.  
+
 2003-05-14  Ahmon Dancy  <dancy@dancy>
 
 	* queue.cl:  In queue-finalize, call expand-addresses w/ the queue

TODO

@@ -1,6 +1,4 @@
-:include: files are allowed to have full header-style email addresses
-(comments, display names).. parse-email-addr handles these right.. so
-if I'm not adding any additional restrictions, it should be fine.
+Fix parse-email-addr so it doesn't use parse-email-addr-list.
 
 Sort queue items by id in queue-process-all
 

aliases.cl

@@ -1,36 +1,28 @@
 (in-package :user)
 
 (defstruct aliases-info
-  mtime
-  aliases)
+  (mtime 0)
+  aliases
+  (lock (mp:make-process-lock))) ;; so only one thread will reparse
 
 (defparameter *aliases* nil)
 
-(defstruct alias-rhs
-  type ;; :prog, :file, :error, :include.  nil means normal
-  addr ;; parsed
-  file ;; for :file, :prog, and :include aliases
-  prog-user ;; for :prog aliases
-  errmsg ;; for :error aliases
-  expanded-from ;; string
-  escaped) ;; prefixed by a backslash?
-
-(defstruct alias-exp
-  rhs
-  owner)
-
-
 (defun update-aliases-info ()
-  (if (null *aliases*)
-      (setf *aliases* (make-aliases-info :mtime 0)))
-  (let ((mtime (file-write-date *aliasesfile*)))
-    (if* (> mtime (aliases-info-mtime *aliases*))
-       then
-	    (verify-root-only-file *aliasesfile*)
-	    (if *debug* (maild-log "Reparsing aliases"))
-	    (setf (aliases-info-aliases *aliases*)
-	      (parse-aliases-file))
-	    (setf (aliases-info-mtime *aliases*) mtime))))
+  ;; Make sure only one thread creates the aliases-info
+  (without-interrupts 
+    (if (null *aliases*) (setf *aliases* (make-aliases-info))))
+
+  ;; Make sure only one thread reparses the aliases.
+  (mp:with-process-lock ((aliases-info-lock *aliases*) 
+			 :whostate "Waiting for aliases lock")
+    (let ((mtime (file-write-date *aliasesfile*)))
+      (if* (> mtime (aliases-info-mtime *aliases*))
+	 then
+	      (verify-root-only-file *aliasesfile*)
+	      (if *debug* (maild-log "Reparsing aliases"))
+	      (setf (aliases-info-aliases *aliases*)
+		(parse-aliases-file))
+	      (setf (aliases-info-mtime *aliases*) mtime)))))
 
 (defun parse-aliases-file ()
   (let ((ht (make-hash-table :test #'equalp)))
@@ -51,79 +43,24 @@
 	(aliases-get-next-word #\: line 0 len :delim-required t)
       (if (null lhs)
 	  (error "Invalid aliases line: ~A" line))
-      (values lhs (parse-alias-right-hand-side lhs line pos len)))))
-
-(defmacro include-alias-p (string)
-  `(prefix-of-p ":include:" ,string))
-
-(defmacro error-alias-p (string)
-  `(prefix-of-p ":error:" ,string))
+      (values lhs (parse-alias-right-hand-side lhs line pos)))))
 
-(defun file-alias-p (string)
-  (and (> (length string) 0)
-       (char= (schar string 0) #\/)))
-
-(defun program-alias-p (string)
-  (and (> (length string) 0)
-       (char= (schar string 0) #\|)))
-
-(defun escaped-alias-p (string)
-  (and (> (length string) 0)
-       (char= (schar string 0) #\\)))
-
-(defun parse-alias-right-hand-side (lhs line pos len)
-  (let (expansion ali have-error-type)
-    (loop
-      (multiple-value-bind (word newpos)
-	  (aliases-get-next-word #\, line pos len)
-	(if (null word)
-	    (return))
-	(setf ali (make-alias-rhs :expanded-from lhs))
-
-	;; See what we're dealing with:
-	(cond
-	 ((include-alias-p word)
-	  (setf (alias-rhs-type ali) :include)
-	  (setf (alias-rhs-file ali) (subseq word #.(length ":include:"))))
-	 ((error-alias-p word)
-	  (setf have-error-type t)
-	  (setf (alias-rhs-type ali) :error)
-	  (setf (alias-rhs-errmsg ali) (subseq word #.(length ":error:")))
-	  (if (string= (alias-rhs-errmsg ali) "")
-	      (setf (alias-rhs-errmsg ali) nil)))
-	 ((file-alias-p word)
-	  (setf (alias-rhs-type ali) :file)
-	  (setf (alias-rhs-file ali) word))
-	 ((program-alias-p word)
-	  (setf (alias-rhs-type ali) :prog)
-	  (multiple-value-bind (found whole prog-user prog)
-	      (match-regexp "^|(\\([^)]+\\))\\(.*\\)" word)
-	    (declare (ignore whole))
-	    (if* found
-	       then
-		    (setf (alias-rhs-file ali) prog)
-		    (setf (alias-rhs-prog-user ali) prog-user)
-	       else
-		    (setf (alias-rhs-file ali) (subseq word 1)))))
-	 (t 
-	  ;; Wasn't one of the special types.  It must be a regular
-	  ;; (possibly escaped) email address.  Parse it and complain
-	  ;; if it isn't proper.
-	  (when (escaped-alias-p word)
-	    (setf (alias-rhs-escaped ali) t)
-	    (setf word (subseq word 1)))
-	  (let ((parsed (parse-email-addr word)))
-	    (if (null parsed)
-		(error "Invalid email address ~S in aliases file" word))
-	    (setf (alias-rhs-addr ali) parsed))))
-	(push ali expansion)
-	(setf pos newpos)))
-    (if (null expansion)
+(defun parse-alias-right-hand-side (lhs line pos)
+  (let ((recips (parse-recip-list line :pos pos)))
+    (if (null recips)
 	(error "Alias ~A has blank expansion" lhs))
-    (if (and have-error-type (> (length expansion) 1))
-	(error "Error in alias ~A: :error: must be the only thing on the right hand side" lhs))
-    expansion))
-
+    (if (and (>= (count-if #'error-recip-p recips) 1)
+	     (> (length recips) 1))
+	(error "Problem with alias ~A:  :error: expansions must be alone" lhs))
+    (when (find-if #'bad-recip-p recips)
+      (format *error-output* "Problem with alias ~A:~%" lhs)
+      (dolist (recip recips)
+	(if (bad-recip-p recip)
+	    (format *error-output* " ~A... ~A~%" 
+		    (recip-orig recip)
+		    (recip-errmsg recip))))
+      (error "Aborting..."))
+    recips))
 
 (defun aliases-get-next-word (delim line pos len &key delim-required)
   (block nil
@@ -204,7 +141,7 @@
 	       (char/= (schar line 0) #\#))
 	  (return line)))))
 
-;; :include: files should be treated as a big multi-line left hand side.
+;; :include: files should be treated as a big multi-line right hand side.
 ;; This function returns a bigass string.
 (defun aliases-get-include-file (filename)
   (verify-security filename)
@@ -220,13 +157,13 @@
 
 (defun aliases-parse-include-file (filename)
   (let ((line (aliases-get-include-file filename)))
-    (parse-alias-right-hand-side filename line 0 (length line))))
+    (parse-alias-right-hand-side filename line 0)))
 
 ;;; end parsing stuff... 
 
 ;;; begin expansion stuff...
 
-;; returns a list of alias-exp structs.
+;; returns a list of recip structs
 ;; may include duplicates.
 (defun expand-alias (alias-orig)
   ;;; XXX - may want to move this out for performance reasons
@@ -240,6 +177,7 @@
 
 ;; tries long match (w/ full domain) first.. 
 ;; then short match (just user part)
+;; this behavior may go away.
 (defun expand-alias-inner (alias ht seen owner)
   (block nil
     (if (not (local-domain-p alias))
@@ -255,7 +193,7 @@
 	  (if members
 	      (alias-expand-member-list alias members ht seen owner)))))))
 
-;; 'members' is a list of alias-rhs structs.
+;; 'members' is a list of recip structs
 (defun alias-expand-member-list (lhs members ht seen owner &key in-include)
   (let (res type ownerstring ownerparsed)
     (setf ownerstring (concatenate 'string "owner-" (emailaddr-orig lhs)))
@@ -264,7 +202,7 @@
 	(setf owner ownerparsed))
 
     (dolist (member members)
-      (setf type (alias-rhs-type member))
+      (setf type (recip-type member))
       (cond
        ;; sanity checks first
        ((and in-include (eq type :prog))
@@ -277,7 +215,7 @@
 	(when in-include
 	  (error "While processing :include: file ~A: :include: is not allowed within an :include: file"
 		 in-include))
-	(let* ((includefile (alias-rhs-file member))
+	(let* ((includefile (recip-file member))
 	       (newmembers (aliases-parse-include-file includefile)))
 	  ;; recurse
 	  (setf res 
@@ -287,15 +225,21 @@
 	     res))))
        ;; definite terminals
        ((or (member type '(:prog :file :error))
-	    (alias-rhs-escaped member)
-	    (not (local-domain-p (alias-rhs-addr member)))
-	    (equalp (emailaddr-user (alias-rhs-addr member))
+	    (recip-escaped member)
+	    (not (local-domain-p (recip-addr member)))
+	    (equalp (emailaddr-user (recip-addr member))
 		    (emailaddr-user lhs)))
-	(push (make-alias-exp :rhs member :owner owner) res))
+	(push (aliases-set-recip-owner member owner) res))
        (t
-	(let ((exp (expand-alias-inner (alias-rhs-addr member) ht seen owner)))
+	(let ((exp (expand-alias-inner (recip-addr member) ht seen owner)))
 	  (if (null exp)
-	      (push (make-alias-exp :rhs member :owner owner) res)
+	      (push (aliases-set-recip-owner member owner) res)
 	    (setf res (append exp res)))))))
     res))
 
+(defun aliases-set-recip-owner (recip owner)
+  (when owner
+    (setf recip (copy-recip recip))
+    (setf (recip-owner recip) owner))
+  recip)
+

emailaddr.cl

@@ -26,6 +26,21 @@
 ;; Front ends to the complex stuff below.
 ;; This is intended to be used for envelope addresses.
 
+(defun sep-tokens-by-comma (tokens)
+  (let (res)
+    (while tokens
+	   (let (tmp)
+	     ;; skip any leading whitespace
+	     (if (whitespace-token-p (first tokens))
+		 (pop tokens))
+	     (while (and tokens (not (comma-token-p (first tokens))))
+		    (push (pop tokens) tmp))
+	     (if tmp ;; don't add blank entries
+		 (push (nreverse tmp) res)))
+	   ;; we're at a comma or done w/ tokens.
+	   (pop tokens)) 
+    (nreverse res)))
+
 ;; returns values:
 ;;   list of accepted, parsed addresses.
 ;;   list of ("rejected-address" "reason")
@@ -51,10 +66,7 @@
 	    (push (list string "User address required") 
 		  bads))
 	   (t
-	    (push (make-emailaddr :user (addrspec-user addr)
-				  :domain (addrspec-domain addr)
-				  :orig (printable-from-addrspec addr))
-		  goods))))
+	    (push (addrspec-to-emailaddr addr) goods))))
 	(setf cruft 
 	  (with-output-to-string (s) (print-token-list remainder s)))
 	(if (match-regexp "^\\b*$" cruft)
@@ -80,6 +92,13 @@
      (t
       (error "Unexpected mailbox subtype: ~S" thing)))))
 
+(defun addrspec-to-emailaddr (addr)
+  (make-emailaddr :user (addrspec-user addr)
+		  :domain (addrspec-domain addr)
+		  :orig (printable-from-addrspec addr)))
+
+(defun mailbox-to-emailaddr (mailbox)
+  (addrspec-to-emailaddr (mailbox-to-addrspec mailbox)))
 
 (defun parse-email-addr (string &key (pos 0) (max (length string))
 				     allow-null)
@@ -648,3 +667,25 @@
        (write-char (second token) stream))
       (t
        (error "token ~S not handled yet." token)))))
+
+;; unquotes quoted strings
+(defun tokens-to-string (tokens &key strip-trailing-white)
+  (let ((string
+	 (with-output-to-string (s)
+	   (dolist (token tokens)
+	     (case (first token)
+	       ((:comment :whitespace :atom)
+		(write-string (second token) s))
+	       (:special
+		(write-char (second token) s))
+	       (:quoted-string
+		(write-string 
+		 (subseq (second token) 1 (1- (length (second token))))
+		 s))
+	       (t
+		(error "token ~S not handled by tokens-to-string yet." 
+		       token)))))))
+    (if strip-trailing-white
+	(replace-regexp string "\\b+$" "")
+      string)))
+

input.cl

@@ -49,6 +49,7 @@
      (pwent-name pwent))))
 
 
+;; 'recips' is a (possibly empty) list of recip structs
 (defun send-from-stdin (recips &key (dot t) gecos from verbose grab-recips)
   (multiple-value-bind (fromaddr gecos authwarn realuser)
       (compute-sender-info from gecos)
@@ -64,6 +65,9 @@
 	      (setf recips 
 		(append recips (grab-recips-from-headers headers))))
 
+	  (if (null recips)
+	   (error "No recipient addresses found in header"))
+
 	  (if authwarn
 	      (setf headers 
 		(append headers 
@@ -99,22 +103,13 @@
 
 ;; Works right even if there are multiple To:, Cc: or Bcc: headers
 (defun grab-recips-from-headers (headers)
-  (let (recips pos)
+  (let (good-recips pos)
     (dolist (header headers)
       (setf pos (recip-header-p header))
       (when pos
-	(multiple-value-bind (accepted rejected cruft)
-	    (parse-email-addr-list header :pos pos)
-	  (if accepted
-	      (setf recips (nconc recips accepted)))
-	  (if rejected
-	      (dolist (rej rejected)
-		(format t "~A...~A~%" (first rej) (second rej))))
-	  (if (string/= cruft "")
-	      (format t "Unrecognized data: ~A~%" cruft)))))
-    recips))
-
-
+	(setf good-recips
+	  (nconc good-recips (get-good-recips-from-string header :pos pos)))))
+    good-recips))
 
 (defun read-message-stream (s bodystream &key smtp dot)
   (let ((res (multiple-value-list