smtp.lisp

   1 ;; -*- mode: common-lisp; package: net.post-office -*-
   2 ;;
   3 ;; smtp.cl
   4 ;;
   5 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
   6 ;;
   7 ;; This code is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the version 2.1 of
   9 ;; the GNU Lesser General Public License as published by
  10 ;; the Free Software Foundation, as clarified by the AllegroServe
  11 ;; prequel found in license-allegroserve.txt.
  12 ;;
  13 ;; This code 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 GNU
  16 ;; Lesser General Public License for more details.
  17 ;;
  18 ;; Version 2.1 of the GNU Lesser General Public License is in the file
  19 ;; license-lgpl.txt that was distributed with this file.
  20 ;; If it is not present, you can access it from
  21 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
  22 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
  23 ;; Suite 330, Boston, MA  02111-1307  USA
  24 ;;
  25 ;;
  26 ;; $Id: smtp.lisp,v 1.1 2002/10/09 14:26:11 kevin Exp $
  27
  28 ;; Description:
  29 ;;   send mail to an smtp server.  See rfc821 for the spec.
  30
  31 ;;- This code in this file obeys the Lisp Coding Standard found in
  32 ;;- http://www.franz.com/~jkf/coding_standards.html
  33 ;;-
  34
  35 ;;#-allegro (defvar socket:*dns-mode* :clib)
  36
  37
  38
  39 (defpackage :net.post-office
  40   (:use #:lisp #:excl
  41         #+allegro #:socket
  42         #-allegro #:acl-socket)
  43   (:export
  44    #:send-letter
  45    #:send-smtp
  46    #:test-email-address))
  47
  48 (in-package :net.post-office)
  49
  50
  51 ;; the exported functions:
  52
  53 ;; (send-letter "mail-server" "from" "to" "message"
  54 ;;              &key cc bcc subject reply-to headers)
  55 ;;
  56 ;;
  57 ;;    sends a message to the mail server (which may be a relay server
  58 ;;    or the final destination).  "from" is the address to be given
  59 ;;    as the sender.  "to" can be a string or a list of strings naming
  60 ;;    recipients.
  61 ;;    "message" is the message to be sent
  62 ;;    cc and bcc can be either be a string or a  list of strings
  63 ;;      naming recipients.  All cc's and bcc's are sent the message
  64 ;;      but the bcc's aren't included in the header created.
  65 ;;    reply-to's value is a string and in cases a Reply-To header
  66 ;;       to be created.
  67 ;;    headers is a string or list of stings. These are raw header lines
  68 ;;      added to the header build to send out.
  69 ;;
  70 ;;    This builds a header and inserts the optional cc, bcc,
  71 ;;    subject and reply-to  lines.
  72 ;;
  73 ;; (send-smtp "mail-server" "from" "to" &rest messages)
  74 ;;    this is like send-letter except that it doesn't build a header.
  75 ;;    the messages should contain a header (and if not then sendmail
  76 ;;    notices this and builds one -- other MTAs may not be that smart).
  77 ;;    The messages ia  list of strings to be concatenated together
  78 ;;    and sent as one message
  79 ;;
  80 ;;
  81 ;;  (test-email-address "user@machine.com")
  82 ;;    return t is this could be a valid email address on the machine
  83 ;;    named.  Do this by contacting the mail server and using the VRFY
  84 ;;    command from smtp.  Since some mail servers don't implement VRFY
  85 ;;    we return t if VRFY doesn't work.
  86 ;;    nil means that this address is bad (or we can't make contact with
  87 ;;    the mail server, which could of course be a transient problem).
  88 ;;
  89
  90
  91
  92
  93
  94 (defmacro response-case ((smtp-stream &optional smtp-response response-code) &rest case-clauses)
  95   ;; get a response from the smtp server and dispatch in a 'case' like
  96   ;; fashion to a clause based on the first digit of the return
  97   ;; code of the response.
  98   ;; smtp-response, if given, will be bound to string that is
  99   ;;  the actual response
 100   ;;
 101   (let ((response-class (gensym)))
 102     `(multiple-value-bind (,response-class
 103                            ,@(if* smtp-response then (list smtp-response))
 104                            ,@(if* response-code then (list response-code)))
 105          (progn (force-output ,smtp-stream)
 106                 (wait-for-response ,smtp-stream))
 107        ;;(declare (ignorable smtp-response))
 108        (case ,response-class
 109          ,@case-clauses))))
 110
 111 (defvar *smtp-debug* nil)
 112
 113
 114
 115 (defun send-letter (server from to message
 116                     &key cc bcc subject reply-to headers)
 117   ;;
 118   ;; see documentation at the head of this file
 119   ;;
 120   (let ((header (make-string-output-stream))
 121         (tos (if* (stringp to)
 122                 then (list to)
 123               elseif (consp to)
 124                 then to
 125                 else (error "to should be a string or list, not ~s" to)))
 126         (ccs
 127          (if* (null cc)
 128             then nil
 129           elseif (stringp cc)
 130             then (list cc)
 131           elseif (consp cc)
 132             then cc
 133             else (error "cc should be a string or list, not ~s" cc)))
 134         (bccs (if* (null bcc)
 135                  then nil
 136                elseif (stringp bcc)
 137                  then (list bcc)
 138                elseif (consp bcc)
 139                  then bcc
 140                  else (error "bcc should be a string or list, not ~s" bcc))))
 141     (format header "From: ~a~c~cTo: "
 142             from
 143             #\return
 144             #\linefeed)
 145     (format header "~{ ~a~^,~}~c~c" tos #\return #\linefeed)
 146     (if* ccs
 147        then (format header "Cc: ~{ ~a~^,~}~c~c" ccs #\return #\linefeed))
 148
 149     (if* subject
 150        then (format header "Subject: ~a~c~c" subject #\return #\linefeed))
 151
 152     (if* reply-to
 153        then (format header "Reply-To: ~a~c~c" reply-to #\return #\linefeed))
 154
 155     (if* headers
 156        then (if* (stringp headers)
 157                then (setq headers (list headers))
 158              elseif (consp headers)
 159                thenret
 160                else (error "Unknown headers format: ~s." headers))
 161             (dolist (h headers)
 162               (format header "~a~c~c" h #\return #\linefeed)))
 163
 164     (format header "~c~c" #\return #\linefeed)
 165
 166     (send-smtp server from (append tos ccs bccs)
 167                (get-output-stream-string header)
 168                message)))
 169
 170
 171
 172
 173
 174 (defun send-smtp (server from to &rest messages)
 175   ;; send the effective concatenation of the messages via
 176   ;; smtp to the mail server
 177   ;; Each message should be a string
 178   ;;
 179   ;; 'to' can be a single string or a list of strings.
 180   ;; each string should be in the official rfc822 format  "foo@bar.com"
 181   ;;
 182
 183   (let ((sock (connect-to-mail-server server)))
 184
 185     (unwind-protect
 186         (progn
 187
 188           (smtp-command sock "MAIL from:<~a>" from)
 189           (response-case (sock msg)
 190             (2 ;; cool
 191              nil
 192              )
 193             (t (error "Mail from command failed: ~s" msg)))
 194
 195           (let ((tos (if* (stringp to)
 196                         then (list to)
 197                       elseif (consp to)
 198                         then to
 199                         else (error "to should be a string or list, not ~s"
 200                                     to))))
 201             (dolist (to tos)
 202               (smtp-command sock "RCPT to:<~a>" to)
 203               (response-case (sock msg)
 204                 (2 ;; cool
 205                  nil
 206                  )
 207                 (t (error "rcpt to command failed: ~s" msg)))))
 208
 209           (smtp-command sock "DATA")
 210           (response-case (sock msg)
 211             (3 ;; cool
 212              nil)
 213             (t (error "Data command failed: ~s" msg)))
 214
 215
 216
 217           (let ((at-bol t)
 218                 (prev-ch nil))
 219             (dolist (message messages)
 220               (dotimes (i (length message))
 221                 (let ((ch (aref message i)))
 222                   (if* (and at-bol (eq ch #\.))
 223                      then ; to prevent . from being interpreted as eol
 224                           (write-char #\. sock))
 225                   (if* (eq ch #\newline)
 226                      then (setq at-bol t)
 227                           (if* (not (eq prev-ch #\return))
 228                              then (write-char #\return sock))
 229                      else (setq at-bol nil))
 230                   (write-char ch sock)
 231                   (setq prev-ch ch)))))
 232
 233           (write-char #\return sock) (write-char #\linefeed sock)
 234           (write-char #\. sock)
 235           (write-char #\return sock) (write-char #\linefeed sock)
 236
 237           (response-case (sock msg)
 238             (2 nil ; (format t "Message sent to ~a~%" to)
 239                )
 240
 241             (t (error "message not sent: ~s" msg)))
 242
 243           (force-output t)
 244
 245           (smtp-command sock "QUIT")
 246           (response-case (sock msg)
 247             (2 ;; cool
 248              nil)
 249             (t (error "quit failed: ~s" msg))))
 250       (close sock))))
 251
 252 (defun connect-to-mail-server (server)
 253   ;; make that initial connection to the mail server
 254   ;; returning a socket connected to it and
 255   ;; signaling an error if it can't be made.
 256   (let ((ipaddr (determine-mail-server server))
 257         (sock)
 258         (ok))
 259
 260     (if* (null ipaddr)
 261        then (error "Can't determine ip addres for mail server ~s" server))
 262
 263     (setq sock (make-socket :remote-host ipaddr
 264                                    :remote-port 25  ; smtp
 265                                    ))
 266     (unwind-protect
 267         (progn
 268           (response-case (sock msg)
 269             (2 ;; to the initial connect
 270              nil)
 271             (t (error "initial connect failed: ~s" msg)))
 272
 273           ;; now that we're connected we can compute our hostname
 274           (let ((hostname (ipaddr-to-hostname
 275                            (local-host sock))))
 276             (if* (null hostname)
 277                then (setq hostname
 278                       (format nil "[~a]" (ipaddr-to-dotted
 279                                           (local-host sock)))))
 280             (smtp-command sock "HELO ~a" hostname)
 281             (response-case (sock msg)
 282               (2 ;; ok
 283                nil)
 284               (t (error "hello greeting failed: ~s" msg))))
 285
 286           ; all is good
 287           (setq ok t))
 288
 289       ; cleanup:
 290       (if* (null ok)
 291          then (close sock :abort t)
 292               (setq sock nil)))
 293
 294     ; return:
 295     sock
 296     ))
 297
 298
 299
 300 (defun test-email-address (address)
 301   ;; test to see if we can determine if the address is valid
 302   ;; return nil if the address is bogus
 303   ;; return t if the address may or may not be bogus
 304   (if* (or (not (stringp address))
 305            (zerop (length address)))
 306      then (error "mail address should be a non-empty string: ~s" address))
 307
 308   ; split on the @ sign
 309   (let (name hostname)
 310     (let ((pos (position #\@ address)))
 311       (if* (null pos)
 312          then (setq name address
 313                     hostname "localhost")
 314        elseif (or (eql pos 0)
 315                   (eql pos (1- (length address))))
 316          then ; @ at beginning or end, bogus since we don't do route addrs
 317               (return-from test-email-address nil)
 318          else (setq name (subseq address 0 pos)
 319                     hostname (subseq address (1+ pos)))))
 320
 321     (let ((sock (ignore-errors (connect-to-mail-server hostname))))
 322       (if* (null sock) then (return-from test-email-address nil))
 323
 324       (unwind-protect
 325           (progn
 326             (smtp-command sock "VRFY ~a" name)
 327             (response-case (sock msg code)
 328               (5
 329                (if* (eq code 550)
 330                   then ; no such user
 331                        msg ; to remove unused warning
 332                        nil
 333                   else t ; otherwise we don't know
 334                        ))
 335               (t t)))
 336         (close sock :abort t)))))
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352 (defun wait-for-response (stream)
 353   ;; read the response of the smtp server.
 354   ;; collect it all in a string.
 355   ;; Return two values:
 356   ;;    response class
 357   ;;    whole string
 358   ;; The string should begin with a decimal digit, and that is converted
 359   ;; into a number which is returned as the response class.
 360   ;; If the string doesn't begin with a decimal digit then the
 361   ;; response class is -1.
 362   ;;
 363   (flet ((match-chars (string pos1 pos2 count)
 364            ;; like strncmp
 365            (dotimes (i count t)
 366              (if* (not (eq (aref string (+ pos1 i))
 367                            (aref string (+ pos2 i))))
 368                 then (return nil)))))
 369
 370     (let ((res (make-array 20 :element-type 'character
 371                            :adjustable t
 372                            :fill-pointer 0)))
 373       (if* (null (read-a-line stream res))
 374          then ; eof encountered before end of line
 375               (return-from wait-for-response (values -1 res)))
 376
 377       ;; a multi-line response begins with line containing
 378       ;; a hyphen in the 4th column:
 379       ;; xyz-  some text
 380       ;;
 381       ;;  and ends with a line containing the same reply code but no
 382       ;;  hyphen.
 383       ;; xyz  some text
 384       ;;
 385
 386       (if* (and (>= (length res) 4) (eq #\- (aref res 3)))
 387          then ;; multi line response
 388               (let ((old-length (length res))
 389                     (new-length nil))
 390                 (loop
 391                   (if* (null (read-a-line stream res))
 392                      then ; eof encountered before end of line
 393                           (return-from wait-for-response (values -1 res)))
 394                   (setq new-length (length res))
 395                   ;; see if this is the last line
 396                   (if* (and (>= (- new-length old-length) 4)
 397                             (eq (aref res (+ old-length 3)) #\space)
 398                             (match-chars res 0 old-length 3))
 399                      then (return))
 400
 401                   (setq old-length new-length))))
 402
 403       ;; complete response is in res
 404       ;; compute class and return the whole thing
 405       (let ((class (or (and (> (length res) 0)
 406                             (digit-char-p (aref res 0)))
 407                        -1)))
 408         (values class res
 409                 (if* (>= (length res) 3)
 410                    then ; compute the whole response value
 411                         (+ (* (or (digit-char-p (aref res 0)) 0) 100)
 412                            (* (or (digit-char-p (aref res 1)) 0) 10)
 413                            (or (digit-char-p (aref res 2)) 0))))))))
 414
 415 (defun smtp-command (stream &rest format-args)
 416   ;; send a command to the smtp server
 417   (let ((command (apply #'format nil format-args)))
 418     (if* *smtp-debug*
 419        then (format *smtp-debug* "to smtp command: ~s~%" command)
 420             (force-output *smtp-debug*))
 421     (write-string command stream)
 422     (write-char #\return stream)
 423     (write-char #\newline stream)
 424     (force-output stream)))
 425
 426 (defun read-a-line (stream res)
 427   ;; read from stream and put the result in the adjust able array res
 428   ;; if line ends in cr-lf, only put a newline in res.
 429   ;; If we get an eof before the line finishes, return nil,
 430   ;; else return t if all is ok
 431   (let (ch last-ch)
 432     (loop
 433       (setq ch (read-char stream nil nil))
 434       (if* (null ch)
 435          then ; premature eof
 436               (return nil))
 437
 438       (if* *smtp-debug*
 439          then (format *smtp-debug* "~c" ch)
 440               (force-output *smtp-debug*)
 441               )
 442
 443       (if* (eq last-ch #\return)
 444          then (if* (eq ch #\linefeed)
 445                  then (vector-push-extend #\newline res)
 446                       (return t)
 447                  else (vector-push-extend last-ch res))
 448        elseif (eq ch #\linefeed)
 449          then ; line ends with just lf, not cr-lf
 450               (vector-push-extend #\newline res)
 451               (return t)
 452        elseif (not (eq ch #\return))
 453          then (vector-push-extend ch res))
 454
 455       (setq last-ch ch))))
 456
 457
 458 (defun determine-mail-server (name)
 459   ;; return the ipaddress to be used to connect to the
 460   ;; the mail server.
 461   ;; name is any method for naming a machine:
 462   ;;   integer ip address
 463   ;;   string with dotted ip address
 464   ;;   string naming a machine
 465   ;; we can only do the mx lookup for the third case, the rest
 466   ;; we just return the ipaddress for what we were given
 467   ;;
 468   (let (ipaddr)
 469     (if* (integerp name)
 470        then name
 471      elseif (integerp (setq ipaddr
 472                         (dotted-to-ipaddr name :errorp nil)))
 473        then ipaddr
 474        else ; do mx lookup if acldns is being used
 475 #|
 476             (if* (or (eq *dns-mode* :acldns)
 477                      (member :acldns *dns-mode* :test #'eq))
 478                then (let ((res (dns-query name :type :mx)))
 479                       (if* (and res (consp res))
 480                          then (cadr res) ; the ip address
 481                          else (dns-query name :type :a)))
 482                else ; just do a hostname lookup
 483 |#
 484        (ignore-errors (lookup-hostname name)))))
 485 ;; )
 486
 487
 488
 489 (provide :smtp)