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