Commit 691402de authored by Jan Idzikowski's avatar Jan Idzikowski
Browse files

*** empty log message ***

parent 926f0c51
Version 20050729.1
2005-07-29
"CHANGE" license from LGPL to LLGPL
"ADD" key display-name for optional display name of the from email adress
(RFC 2822 3.4. Address Specification)
Added LLGPL-LICENSE
Change all files
Version 20050127.1
2005-01-27
"FIXED" add correct multiline replies in read-from-smtp (RFC 822 APPENDIX E)
"ADD" key extra-headers to send-email, send-smtp
thanks Dave Bakkash to inform me about the wrong implemantation
of read-from-smtp and the tip with the extra-headers
Change cl-smtp.asd, cl-smtp.lisp, README, CHANGELOG
Version 20050119.1
2005-01-19
Add portability file "lispworks.lisp" to work with Lispworks,
thanks Sean Ross for this file
Added lispworks.lisp
Change cl-smtp.asd, README, INSTALL, CHANGELOG
Version 20050104.1
2005-01-04
"Fixed" month "Sep" missed in get-email-date-string
Added this CHANGELOG
Version 20040812.1
2004-08-12
Initial release
CL-SMTP works in ACL, SBCL, CMUCL, OPENMCL, LISPWORKS and CLISP.
For SBCL you need sb-bsd-sockets.
CL-SMTP has a asdf system definition file.
load this file:
(asdf:operate 'asdf:load-op 'cl-smtp)
thats all.
CL-SMTP is a simple lisp smtp client.
It works in ACL, SBCL, CMUCL, OPENMCL, LISPWORKS and CLISP.
See INSTALL for prerequisites and build details.
To use cl-smtp:
(asdf:operate 'asdf:load-op 'cl-smtp)
(cl-smtp:send-email host from to subject message
&key (port 25) cc bcc reply-to extra-headers)
Arguments:
- host (String) : hostname or ip-adress of the smtpserver
- from (String) : email adress
- to (String or Cons of Strings) : email adress
- subject (String) : subject text
- message (String) : message body
keywords:
- cc (String or Cons of Strings) : email adress carbon copy
- bcc (String or Cons of Strings): email adress blind carbon copy
- reply-to (String) : email adress
- diplayname (String) : diplayname of the sender
- extra-headers (Cons) : extra headers as alist
Returns nil or error with message
For debug output set the parameter *debug* to t (default nil)
(setf cl-smtp::*debug* t)
CL-SMTP set automaticly the Date header and the X-Mailer header.
X-Mailer: cl-smtp ((lisp-implementation-type) (lisp-implementation-version))
You can change this with setting the parameter *x-mailer*
(setf cl-smtp::*x-mailer* "my x-mailer string)
If you find bugs or want to send patches for enhancements, by email to
Jan Idzikowski <ji@neumond.net>.
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: acl.lisp
;;; Description: Allegro CL Socket Interface
(in-package :cl-smtp)
(defun make-smtp-socket (host port)
(handler-case
(acl-socket:make-socket :remote-host host :remote-port port)
(serious-condition (e)
(error "could not create client socket:~A" e))))
(defun socket-stream (socket)
socket)
(defun get-host-name ()
(excl.osi:gethostname))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: cl-smtp.asd
;;; Description: cl-smtp ASDF system definition file
(defpackage :cl-smtp
(:use :cl :asdf)
(:export :send-email))
#+sbcl (require :sb-bsd-sockets)
(in-package :cl-smtp)
(asdf:defsystem :cl-smtp
:version "20050729.1"
:components
(#+sbcl(:file "sbcl")
#+allegro(:file "acl")
#+cmu(:file "cmucl")
#+clisp(:file "clisp")
#+openmcl(:file "openmcl")
#+lispworks(:file "lispworks")
(:file "cl-smtp" :depends-on #+sbcl("sbcl")
#+allegro("acl")
#+cmu("cmucl")
#+clisp("clisp")
#+openmcl("openmcl")
#+lispworks("lispworks"))))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: cl-smtp.lisp
;;; Description: main smtp client logic
(in-package :cl-smtp)
(defparameter *debug* nil)
(defparameter *x-mailer* (format nil "(~A ~A)"
(lisp-implementation-type)
(lisp-implementation-version)))
(defmacro print-debug (str)
`(when *debug*
(print ,str)))
(defun check-arg (arg name)
(cond
((stringp arg)
(list arg))
((listp arg)
arg)
(t
(error "the \"~A\" argument is not a string or cons" name))))
(defun mask-dot (str)
"replace \r\n.\r\n with \r\n..\r\n"
(let ((dotstr (format nil "~C~C.~C~C" #\Return #\NewLine
#\Return #\NewLine))
(maskdotsr (format nil "~C~C..~C~C" #\Return #\NewLine
#\Return #\NewLine))
(resultstr ""))
(labels ((mask (tempstr)
(let ((n (search dotstr tempstr)))
(cond
(n
(setf resultstr (concatenate 'string resultstr
(subseq tempstr 0 n)
maskdotsr))
(mask (subseq tempstr (+ n 5))))
(t
(setf resultstr (concatenate 'string resultstr
tempstr)))))))
(mask str))
resultstr))
(defun send-email (host from to subject message
&key (port 25) cc bcc reply-to extra-headers
display-name)
(send-smtp host from (check-arg to "to") subject (mask-dot message)
:port port :cc (check-arg cc "cc") :bcc (check-arg bcc "bcc")
:reply-to reply-to
:extra-headers extra-headers
:display-name display-name))
(defun send-smtp (host from to subject message
&key (port 25) cc bcc reply-to extra-headers
display-name)
(let ((sock (socket-stream (make-smtp-socket host port))))
(unwind-protect
(progn
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 220)
(error "wrong response from smtp server: ~A" msgstr)))
(write-to-smtp sock (format nil "HELO ~A" (get-host-name)))
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 250)
(error "wrong response from smtp server: ~A" msgstr)))
(write-to-smtp sock
(format nil "MAIL FROM:~@[~A ~]<~A>" display-name from))
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 250)
(error "in MAIL FROM command: ~A" msgstr)))
(compute-rcpt-command sock to)
(compute-rcpt-command sock cc)
(compute-rcpt-command sock bcc)
(write-to-smtp sock "DATA")
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 354)
(error "in DATA command: ~A" msgstr)))
(write-to-smtp sock (format nil "Date: ~A" (get-email-date-string)))
(write-to-smtp sock (format nil "From: ~@[~A <~]~A~@[>~]"
display-name from display-name))
(write-to-smtp sock (format nil "To: ~{ ~a~^,~}" to))
(when cc
(write-to-smtp sock (format nil "Cc: ~{ ~a~^,~}" cc)))
(write-to-smtp sock (format nil "Subject: ~A" subject))
(write-to-smtp sock (format nil "X-Mailer: cl-smtp ~A"
*x-mailer*))
(when reply-to
(write-to-smtp sock (format nil "Reply-To: ~A" reply-to)))
(when (and extra-headers
(listp extra-headers))
(dolist (l extra-headers)
(write-to-smtp sock
(format nil "~A: ~{~a~^,~}" (car l) (rest l)))))
(write-to-smtp sock "Mime-Version: 1.0")
(write-char #\Return sock)
(write-char #\NewLine sock)
(write-to-smtp sock message)
(write-char #\. sock)
(write-char #\Return sock)
(write-char #\NewLine sock)
(force-output sock)
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 250)
(error "Message send failed: ~A" msgstr)))
(write-to-smtp sock "QUIT")
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 221)
(error "in QUIT command:: ~A" msgstr))))
(close sock))))
(defun compute-rcpt-command (sock adresses)
(dolist (to adresses)
(write-to-smtp sock (format nil "RCPT TO:<~A>" to))
(multiple-value-bind (code msgstr)
(read-from-smtp sock)
(when (/= code 250)
(error "in RCPT TO command: ~A" msgstr)))))
(defun write-to-smtp (sock command)
(print-debug (format nil "to server: ~A" command))
(write-string command sock)
(write-char #\Return sock)
(write-char #\NewLine sock)
(force-output sock))
(defun read-from-smtp (sock)
(let* ((line (read-line sock))
(response-code (parse-integer line :start 0 :junk-allowed t)))
(print-debug (format nil "from server: ~A" line))
(if (= (char-code (elt line 3)) (char-code #\-))
(read-from-smtp sock)
(values response-code line))))
(defun get-email-date-string ()
(multiple-value-bind (sec min h d m y wd) (get-decoded-time)
(let* ((month (elt '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1)))
(weekday (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") wd))
(timezone (get-timezone-from-integer
(- (encode-universal-time sec min h d m y 0)
(get-universal-time)))))
(format nil "~A, ~2,'0d ~A ~d ~2,'0d:~2,'0d:~2,'0d ~D"
weekday d month y h min sec timezone))))
(defun get-timezone-from-integer (x)
(let ((min (/ x 60))
(hour (/ x 3600)))
(if (integerp hour)
(cond
((>= hour 0)
(format nil "+~2,'0d00" hour))
((< hour 0)
(format nil "-~2,'0d00" (* -1 hour))))
(multiple-value-bind (h m) (truncate min 60)
(cond
((>= hour 0)
(format nil "+~2,'0d~2,'0d" h (truncate m)))
((< hour 0)
(format nil "-~2,'0d~2,'0d" (* -1 h) (* -1 (truncate m)))))))))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: clisp.lisp
;;; Description: Clisp Socket Interface
(in-package :cl-smtp)
(defun make-smtp-socket (host port)
(handler-case
(socket:socket-connect port host :element-type 'character)
(serious-condition (e)
(error "could not create client socket:~A" e))))
(defun socket-stream (socket)
socket)
(defun get-host-name ()
(linux:gethostname 256))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: cmucl.lisp
;;; Description: CmuCL Socket Interface
(in-package :cl-smtp)
(defun make-smtp-socket (host port)
(handler-case
(ext:connect-to-inet-socket host port)
(serious-condition (e)
(error "could not create client socket:~A" e))))
(defun socket-stream (socket)
(system:make-fd-stream
socket
:input t
:output t
:buffering :none))
(defun get-host-name ()
(unix:unix-gethostname))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: lispworks.lisp
;;; Description: Lispworks Socket Interface
(in-package :cl-smtp)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "comm"))
(defun make-smtp-socket (host port)
(comm:open-tcp-stream host port))
(defun socket-stream (socket)
socket)
(defun get-host-name ()
(machine-instance))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: openmcl.lisp
;;; Description: OpenMCL Socket Interface
(in-package :cl-smtp)
(defun make-smtp-socket (host port)
(handler-case
(ccl:make-socket :remote-host host :remote-port port)
(serious-condition (e)
(error "could not create client socket:~A" e))))
(defun socket-stream (socket)
socket)
(defun get-host-name ()
(machine-instance))
;;; -*- mode: Lisp -*-
;;; This file is part of CL-SMTP, the Lisp SMTP Client
;;; Copyright (C) 2004/2005 Jan Idzikowski
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the Lisp Lesser GNU General Public License
;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
;;; 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
;;; Lisp Lesser GNU General Public License for more details.
;;; File: sbcl.lisp
;;; Description: SBCL Socket Interface
(in-package :cl-smtp)
(defun make-smtp-socket (host port)
(handler-case
(let* ((protocol (sb-bsd-sockets:get-protocol-by-name "tcp"))
(socket (make-instance 'sb-bsd-sockets:inet-socket
:type :stream
:protocol protocol)))
(sb-bsd-sockets:socket-connect
socket
(sb-bsd-sockets:host-ent-address
(sb-bsd-sockets:get-host-by-name host))
port)
socket)
(serious-condition (e)
(error "could not create client socket:~A" e))))
(defun socket-stream (socket)
(sb-bsd-sockets:socket-make-stream
socket
:input t
:output t))
(defun get-host-name ()
(sb-unix:unix-gethostname))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment