smtp.cl

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