Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Adam Krupicka
cl-smtp
Commits
898bc776
Commit
898bc776
authored
Nov 11, 2007
by
Jan Idzikowski
Browse files
Add SSL support, thank Timothy Ritchey for the suggestions.
New boolean keyword argument ssl added to send-email.
parent
66a46fc1
Changes
4
Hide whitespace changes
Inline
Side-by-side
CHANGELOG
View file @
898bc776
Version 20071113.1
2007.11.13
Add SSL support, thank Timothy Ritchey for the suggestions.
New boolean keyword argument ssl added to send-email.
Change cl-smtp.lisp, cl-smtp.asd, README, CHANGELOG
Version 20071104.1
2007.11.04
Fixed bug with the file attachments to solve corrupted files when
...
...
@@ -5,7 +11,7 @@ processed with chunking turned on. (Brian Sorg)
Added automatically including mime types for attachesments
of common known extensions. (Brian Sorg)
Added Html-messages option to send-mail function. (Brian Sorg)
Change attachments.lisp, cl-smtp.asd, cl-smtp.lisp, README, CHANGLOG
Change attachments.lisp, cl-smtp.asd, cl-smtp.lisp, README, CHANG
E
LOG
Add mime-type.lisp
Version 20071018.1
...
...
README
View file @
898bc776
...
...
@@ -6,6 +6,8 @@ new with support for send attachments, thanks Brian Sorg for the implementation
with authentication support for PLAIN and LOGIN authentication method
and ssl support with cl+ssl package
used cl-base64 and usocket packages (cl-base64 isn't a requirement on ACL)
See INSTALL for prerequisites and build details.
...
...
@@ -18,7 +20,7 @@ To use cl-smtp:
(cl-smtp:send-email host from to subject message
&key (port 25) cc bcc reply-to extra-headers html-message
authentication attachments (buffer-size 256))
authentication attachments (buffer-size 256)
ssl
)
Arguments:
- host (String) : hostname or ip-adress of the smtpserver
...
...
@@ -41,7 +43,8 @@ To use cl-smtp:
- buffer-size (Number default 256): controls how much of a attachment file
is read on each loop before encoding
and transmitting the contents,
the number is interpretted in KB
the number is interpretted in KB
- ssl (Boolean) : if true than use the STARTTLS functionality to make a ssl connection
Returns nil or error with message
...
...
cl-smtp.asd
View file @
898bc776
...
...
@@ -29,10 +29,12 @@
(
print
,
str
)))
(
asdf:defsystem
:cl-smtp
:version
"200711
05
.1"
:version
"200711
13
.1"
:perform
(
load-op
:after
(
op
webpage
)
(
pushnew
:cl-smtp
cl:*features*
))
:depends-on
(
:usocket
#-
allegro
:cl-base64
)
:depends-on
(
:usocket
#-
allegro
:cl-base64
#-
allegro
:flexi-streams
#-
allegro
:cl+ssl
)
:components
((
:file
"cl-smtp"
:depends-on
(
"attachments"
))
(
:file
"attachments"
)
(
:file
"mime-types"
)))
cl-smtp.lisp
View file @
898bc776
...
...
@@ -63,8 +63,8 @@
(
defun
send-email
(
host
from
to
subject
message
&key
(
port
25
)
cc
bcc
reply-to
extra-headers
html-message
display-name
authentication
attachments
(
buffer-size
256
))
html-message
display-name
authentication
attachments
(
buffer-size
256
)
ssl
)
(
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
...
...
@@ -75,206 +75,244 @@
:attachments
(
check-arg
attachments
"attachments"
)
:buffer-size
(
if
(
numberp
buffer-size
)
buffer-size
256
)))
256
)
:ssl
ssl
))
(
defun
send-smtp
(
host
from
to
subject
message
&key
(
port
25
)
cc
bcc
reply-to
extra-headers
html-message
display-name
authentication
attachments
buffer-size
)
display-name
authentication
attachments
buffer-size
ssl
)
(
let*
((
sock
(
usocket:socket-stream
(
usocket:socket-connect
host
port
)))
(
boundary
(
make-random-boundary
))
(
html-boundary
(
if
(
and
attachments
html-message
)
(
make-random-boundary
)
boundary
)))
(
unwind-protect
(
progn
(
open-smtp-connection
sock
:authentication
authentication
)
(
send-smtp-headers
sock
:from
from
:to
to
:cc
cc
:bcc
bcc
:reply-to
reply-to
:display-name
display-name
:extra-headers
extra-headers
:subject
subject
)
(
when
(
or
attachments
html-message
)
(
send-multipart-headers
sock
:attachment-boundary
(
when
attachments
boundary
)
:html-boundary
html-boundary
))
;;----------- Send the body Message ---------------------------
;;--- Send the proper headers depending on plain-text,
;;--- multi-part or html email
(
cond
((
and
attachments
html-message
)
;; if both present, start attachment section,
;; then define alternative section,
;; then write alternative header
(
progn
(
generate-message-header
sock
:boundary
boundary
:include-blank-line?
nil
)
(
generate-multipart-header
sock
html-boundary
:multipart-type
"alternative"
)
(
write-blank-line
sock
)
(
generate-message-header
sock
:boundary
html-boundary
:content-type
*content-type*
:content-disposition
"inline"
:include-blank-line?
nil
)))
(
attachments
(
generate-message-header
sock
:boundary
boundary
:content-type
*content-type*
:content-disposition
"inline"
:include-blank-line?
nil
))
(
html-message
(
generate-message-header
sock
:boundary
html-boundary
:content-type
*content-type*
:content-disposition
"inline"
))
(
t
(
generate-message-header
sock
:content-type
*content-type*
:include-blank-line?
nil
)))
(
write-blank-line
sock
)
(
write-to-smtp
sock
message
)
(
write-blank-line
sock
)
;;---------- Send Html text if needed -------------------------
(
when
html-message
(
generate-message-header
sock
:boundary
html-boundary
:content-type
"text/html; charset=ISO-8859-1"
:content-disposition
"inline"
)
(
write-to-smtp
sock
html-message
)
(
send-end-marker
sock
html-boundary
))
;;---------- Send Attachments -----------------------------------
(
when
attachments
(
dolist
(
attachment
attachments
)
(
send-attachment
sock
attachment
boundary
buffer-size
))
(
send-end-marker
sock
boundary
))
(
write-char
#\.
sock
)
(
write-blank-line
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
))))
(
let
((
stream
(
open-smtp-connection
sock
:authentication
authentication
:ssl
ssl
)))
(
send-smtp-headers
stream
:from
from
:to
to
:cc
cc
:bcc
bcc
:reply-to
reply-to
:display-name
display-name
:extra-headers
extra-headers
:subject
subject
)
(
when
(
or
attachments
html-message
)
(
send-multipart-headers
stream
:attachment-boundary
(
when
attachments
boundary
)
:html-boundary
html-boundary
))
;;----------- Send the body Message ---------------------------
;;--- Send the proper headers depending on plain-text,
;;--- multi-part or html email
(
cond
((
and
attachments
html-message
)
;; if both present, start attachment section,
;; then define alternative section,
;; then write alternative header
(
progn
(
generate-message-header
stream
:boundary
boundary
:include-blank-line?
nil
)
(
generate-multipart-header
stream
html-boundary
:multipart-type
"alternative"
)
(
write-blank-line
stream
)
(
generate-message-header
stream
:boundary
html-boundary
:content-type
*content-type*
:content-disposition
"inline"
:include-blank-line?
nil
)))
(
attachments
(
generate-message-header
stream
:boundary
boundary
:content-type
*content-type*
:content-disposition
"inline"
:include-blank-line?
nil
))
(
html-message
(
generate-message-header
stream
:boundary
html-boundary
:content-type
*content-type*
:content-disposition
"inline"
))
(
t
(
generate-message-header
stream
:content-type
*content-type*
:include-blank-line?
nil
)))
(
write-blank-line
stream
)
(
write-to-smtp
stream
message
)
(
write-blank-line
stream
)
;;---------- Send Html text if needed -------------------------
(
when
html-message
(
generate-message-header
stream
:boundary
html-boundary
:content-type
"text/html; charset=ISO-8859-1"
:content-disposition
"inline"
)
(
write-to-smtp
stream
html-message
)
(
send-end-marker
stream
html-boundary
))
;;---------- Send Attachments -----------------------------------
(
when
attachments
(
dolist
(
attachment
attachments
)
(
send-attachment
stream
attachment
boundary
buffer-size
))
(
send-end-marker
stream
boundary
))
(
write-char
#\.
stream
)
(
write-blank-line
stream
)
(
force-output
stream
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
250
)
(
error
"Message send failed: ~A"
msgstr
)))
(
write-to-smtp
stream
"QUIT"
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
221
)
(
error
"in QUIT command:: ~A"
msgstr
))))
(
close
sock
))))
(
defun
open-smtp-connection
(
s
ock
&key
authentication
)
(
defun
open-smtp-connection
(
s
tream
&key
authentication
ssl
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
s
ock
)
(
read-from-smtp
s
tream
)
(
when
(
/=
code
220
)
(
error
"wrong response from smtp server: ~A"
msgstr
)))
(
when
ssl
(
write-to-smtp
stream
(
format
nil
"EHLO ~A"
(
usocket::get-host-name
)))
(
multiple-value-bind
(
code
msgstr
lines
)
(
read-from-smtp
stream
)
(
when
(
/=
code
250
)
(
error
"wrong response from smtp server: ~A"
msgstr
))
(
when
ssl
(
cond
((
find
"STARTTLS"
lines
:test
#'
equal
)
(
print-debug
"this server supports TLS"
)
(
write-to-smtp
stream
"STARTTLS"
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
220
)
(
error
"Unable to start TLS: ~A"
msgstr
))
(
setf
stream
#+
allegro
(
socket:make-ssl-client-stream
stream
)
#-
allegro
(
let
((
s
stream
))
(
cl+ssl:make-ssl-client-stream
(
cl+ssl:stream-fd
stream
)
:close-callback
(
lambda
()
(
close
s
)))))
#-
allegro
(
setf
stream
(
flexi-streams:make-flexi-stream
stream
:external-format
(
flexi-streams:make-external-format
:latin-1
:eol-style
:lf
)))))
(
t
(
error
"this server does not supports TLS"
))))))
(
cond
(
authentication
(
write-to-smtp
sock
(
format
nil
"EHLO ~A"
(
usocket::get-host-name
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
sock
)
(
authentication
(
write-to-smtp
stream
(
format
nil
"EHLO ~A"
(
usocket::get-host-name
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
250
)
(
error
"wrong response from smtp server: ~A"
msgstr
)))
(
cond
((
eq
(
car
authentication
)
:plain
)
(
write-to-smtp
sock
(
format
nil
"AUTH PLAIN ~A"
(
string-to-base64-string
(
format
nil
"~A~C~A~C~A"
(
cadr
authentication
)
#\null
(
cadr
authentication
)
#\null
(
caddr
authentication
)))))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
sock
)
(
when
(
/=
code
235
)
(
error
"plain authentication failed: ~A"
msgstr
))))
((
eq
(
car
authentication
)
:login
)
(
write-to-smtp
sock
"AUTH LOGIN"
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
sock
)
(
when
(
/=
code
334
)
(
error
"login authentication failed: ~A"
msgstr
)))
(
write-to-smtp
sock
(
string-to-base64-string
(
cadr
authentication
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
sock
)
(
when
(
/=
code
334
)
(
error
"login authentication send username failed: ~A"
msgstr
)))
(
write-to-smtp
sock
(
string-to-base64-string
(
caddr
authentication
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
sock
)
(
when
(
/=
code
235
)
(
error
"login authentication send password failed: ~A"
msgstr
))))
(
t
(
error
"authentication ~A is not supported in cl-smtp"
(
car
authentication
)))))
(
cond
((
eq
(
car
authentication
)
:plain
)
(
write-to-smtp
stream
(
format
nil
"AUTH PLAIN ~A"
(
string-to-base64-string
(
format
nil
"~A~C~A~C~A"
(
cadr
authentication
)
#\null
(
cadr
authentication
)
#\null
(
caddr
authentication
)))))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
235
)
(
error
"plain authentication failed: ~A"
msgstr
))))
((
eq
(
car
authentication
)
:login
)
(
write-to-smtp
stream
"AUTH LOGIN"
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
334
)
(
error
"login authentication failed: ~A"
msgstr
)))
(
write-to-smtp
stream
(
string-to-base64-string
(
cadr
authentication
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
334
)
(
error
"login authentication send username failed: ~A"
msgstr
)))
(
write-to-smtp
stream
(
string-to-base64-string
(
caddr
authentication
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
stream
)
(
when
(
/=
code
235
)
(
error
"login authentication send password failed: ~A"
msgstr
))))
(
t
(
error
"authentication ~A is not supported in cl-smtp"
(
car
authentication
)))))
(
t
(
write-to-smtp
s
ock
(
format
nil
"HELO ~A"
(
usocket::get-host-name
)))
(
write-to-smtp
s
tream
(
format
nil
"HELO ~A"
(
usocket::get-host-name
)))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
s
ock
)
(
read-from-smtp
s
tream
)
(
when
(
/=
code
250
)
(
error
"wrong response from smtp server: ~A"
msgstr
))))))
(
error
"wrong response from smtp server: ~A"
msgstr
)))))
stream
)
(
defun
send-smtp-headers
(
s
ock
(
defun
send-smtp-headers
(
s
tream
&key
from
to
cc
bcc
reply-to
extra-headers
display-name
subject
)
(
write-to-smtp
s
ock
(
write-to-smtp
s
tream
(
format
nil
"MAIL FROM:~@[~A ~]<~A>"
display-name
from
))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
s
ock
)
(
read-from-smtp
s
tream
)
(
when
(
/=
code
250
)
(
error
"in MAIL FROM command: ~A"
msgstr
)))
(
compute-rcpt-command
s
ock
to
)
(
compute-rcpt-command
s
ock
cc
)
(
compute-rcpt-command
s
ock
bcc
)
(
write-to-smtp
s
ock
"DATA"
)
(
compute-rcpt-command
s
tream
to
)
(
compute-rcpt-command
s
tream
cc
)
(
compute-rcpt-command
s
tream
bcc
)
(
write-to-smtp
s
tream
"DATA"
)
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
s
ock
)
(
read-from-smtp
s
tream
)
(
when
(
/=
code
354
)
(
error
"in DATA command: ~A"
msgstr
)))
(
write-to-smtp
s
ock
(
format
nil
"Date: ~A"
(
get-email-date-string
)))
(
write-to-smtp
s
ock
(
format
nil
"From: ~@[~A <~]~A~@[>~]"
display-name
from
display-name
))
(
write-to-smtp
s
ock
(
format
nil
"To: ~{ ~a~^,~}"
to
))
(
write-to-smtp
s
tream
(
format
nil
"Date: ~A"
(
get-email-date-string
)))
(
write-to-smtp
s
tream
(
format
nil
"From: ~@[~A <~]~A~@[>~]"
display-name
from
display-name
))
(
write-to-smtp
s
tream
(
format
nil
"To: ~{ ~a~^,~}"
to
))
(
when
cc
(
write-to-smtp
s
ock
(
format
nil
"Cc: ~{ ~a~^,~}"
cc
)))
(
write-to-smtp
s
ock
(
format
nil
"Subject: ~A"
subject
))
(
write-to-smtp
s
ock
(
format
nil
"X-Mailer: cl-smtp ~A"
*x-mailer*
))
(
write-to-smtp
s
tream
(
format
nil
"Cc: ~{ ~a~^,~}"
cc
)))
(
write-to-smtp
s
tream
(
format
nil
"Subject: ~A"
subject
))
(
write-to-smtp
s
tream
(
format
nil
"X-Mailer: cl-smtp ~A"
*x-mailer*
))
(
when
reply-to
(
write-to-smtp
s
ock
(
format
nil
"Reply-To: ~A"
reply-to
)))
(
write-to-smtp
s
tream
(
format
nil
"Reply-To: ~A"
reply-to
)))
(
when
(
and
extra-headers
(
listp
extra-headers
))
(
dolist
(
l
extra-headers
)
(
write-to-smtp
s
ock
(
write-to-smtp
s
tream
(
format
nil
"~A: ~{~a~^,~}"
(
car
l
)
(
rest
l
)))))
(
write-to-smtp
s
ock
"Mime-Version: 1.0"
))
(
write-to-smtp
s
tream
"Mime-Version: 1.0"
))
(
defun
send-multipart-headers
(
s
ock
&key
attachment-boundary
html-boundary
)
(
defun
send-multipart-headers
(
s
tream
&key
attachment-boundary
html-boundary
)
(
cond
(
attachment-boundary
(
generate-multipart-header
s
ock
attachment-boundary
(
generate-multipart-header
s
tream
attachment-boundary
:multipart-type
"mixed"
))
(
html-boundary
(
generate-multipart-header
s
ock
html-boundary
s
tream
html-boundary
:multipart-type
"alternative"
))
(
t
nil
)))
(
defun
compute-rcpt-command
(
s
ock
adresses
)
(
defun
compute-rcpt-command
(
s
tream
adresses
)
(
dolist
(
to
adresses
)
(
write-to-smtp
s
ock
(
format
nil
"RCPT TO:<~A>"
to
))
(
write-to-smtp
s
tream
(
format
nil
"RCPT TO:<~A>"
to
))
(
multiple-value-bind
(
code
msgstr
)
(
read-from-smtp
s
ock
)
(
read-from-smtp
s
tream
)
(
when
(
/=
code
250
)
(
error
"in RCPT TO command: ~A"
msgstr
)))))
(
defun
write-to-smtp
(
s
ock
command
)
(
defun
write-to-smtp
(
s
tream
command
)
(
print-debug
(
format
nil
"to server: ~A"
command
))
(
write-string
command
s
ock
)
(
write-char
#\Return
s
ock
)
(
write-char
#\NewLine
s
ock
)
(
force-output
s
ock
))
(
write-string
command
s
tream
)
(
write-char
#\Return
s
tream
)
(
write-char
#\NewLine
s
tream
)
(
force-output
s
tream
))
(
defun
write-blank-line
(
s
ock
)
(
write-char
#\Return
s
ock
)
(
write-char
#\NewLine
s
ock
)
(
force-output
s
ock
))
(
defun
write-blank-line
(
s
tream
)
(
write-char
#\Return
s
tream
)
(
write-char
#\NewLine
s
tream
)
(
force-output
s
tream
))
(
defun
read-from-smtp
(
sock
)
(
let*
((
line
(
read-line
sock
))
(
defun
read-from-smtp
(
stream
&optional
lines
)
(
let*
((
line
(
read-line
stream
))
(
response
(
string-trim
'
(
#\Return
#\NewLine
)
(
subseq
line
4
)))
(
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
s
ock
)
(
values
response-code
line
))))
(
read-from-smtp
s
tream
(
append
lines
(
list
response
))
)
(
values
response-code
line
lines
))))
(
defun
get-email-date-string
()
(
multiple-value-bind
(
sec
min
h
d
m
y
wd
)
(
get-decoded-time
)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment