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
77917e13
Commit
77917e13
authored
Sep 08, 2010
by
Jan Idzikowski
Browse files
Add write-rfc8822-message, to write a rfc8822 compatible mail to the
given stream. Change x-mailer header setting.
parent
94e99ed2
Changes
5
Hide whitespace changes
Inline
Side-by-side
CHANGELOG
View file @
77917e13
Version 20100908.2
2010.09.08
Add write-rfc8822-message, to write a rfc8822 compatible mail.
Change x-mailer header setting.
Change cl-smtp.lisp, cl-smtp.asd, package.lisp, CHANGELOG, README
Version 20100908.1
2010.09.08
Add keyword envelope-sender to send-email, if envelope-sender not set then
...
...
README
View file @
77917e13
...
...
@@ -78,6 +78,21 @@ Returns rfc2231 encode string
keywords:
- external-format : symbol, default :utf-8
------------------------------------------------
(cl-smtp:write-rfc8822-message stream from to subject message
:cc cc :reply-to reply-to
:extra-headers extra-headers
:html-message html-message
:display-name display-name
:attachments attachments
:buffer-size buffer-size
:external-format external-format)
Writes a rfc8822 compatible email to the stream.
For arguments see the cl-smtp:send-email documentation.
------------------------------------------------
CLASS
cl-smtp:attachment
...
...
cl-smtp.asd
View file @
77917e13
...
...
@@ -17,7 +17,7 @@
;;; Description: cl-smtp ASDF system definition file
(
asdf:defsystem
:cl-smtp
:version
"20100908.
1
"
:version
"20100908.
2
"
:perform
(
load-op
:after
(
op
webpage
)
(
pushnew
:cl-smtp
cl:*features*
))
:depends-on
(
:usocket
...
...
cl-smtp.lisp
View file @
77917e13
...
...
@@ -18,7 +18,7 @@
(
in-package
:cl-smtp
)
(
defparameter
*x-mailer*
(
format
nil
"(~A ~A)"
(
defparameter
*x-mailer*
(
format
nil
"
cl-smtp
(~A ~A)"
(
lisp-implementation-type
)
(
lisp-implementation-version
)))
...
...
@@ -207,70 +207,14 @@
:ssl
ssl
:local-hostname
local-hostname
:external-format
external-format
)
(
let*
((
boundary
(
make-random-boundary
))
(
html-boundary
(
if
(
and
attachments
html-message
)
(
make-random-boundary
)
boundary
))
(
content-type
(
format
nil
"text/plain; charset=~S"
(
string-upcase
(
symbol-name
external-format
)))))
(
send-mail-headers
stream
:from
from
:to
to
:cc
cc
: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
(
format
nil
"text/html; charset=~S"
(
string-upcase
(
symbol-name
external-format
)))
: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
external-format
))
(
send-end-marker
stream
boundary
)))))
(
write-rfc8822-message
stream
from
to
subject
message
:cc
cc
:reply-to
reply-to
:extra-headers
extra-headers
:html-message
html-message
:display-name
display-name
:attachments
attachments
:buffer-size
buffer-size
:external-format
external-format
)))
(
define-condition
no-supported-authentication-method
(
smtp-error
)
((
features
:initarg
:features
:reader
features
))
...
...
@@ -407,7 +351,6 @@
"Finish sending an email to the SMTP server connected to on STREAM.
The server is expected to be inside of the DATA SMTP command. The
connection is then terminated by sending a QUIT command."
;;(fresh-line stream)
(
write-to-smtp
stream
""
)
(
smtp-command
stream
"."
250
)
(
smtp-command
stream
"QUIT"
221
))
...
...
@@ -432,7 +375,7 @@
(
write-to-smtp
stream
(
format
nil
"Subject: ~A"
(
rfc2045-q-encode-string
subject
:external-format
external-format
)))
(
write-to-smtp
stream
(
format
nil
"X-Mailer:
cl-smtp
~A"
(
write-to-smtp
stream
(
format
nil
"X-Mailer: ~A"
(
rfc2045-q-encode-string
*x-mailer*
:external-format
external-format
)))
(
when
reply-to
...
...
@@ -455,6 +398,76 @@
:multipart-type
"alternative"
))
(
t
nil
)))
(
defun
write-rfc8822-message
(
stream
from
to
subject
message
&key
cc
reply-to
extra-headers
html-message
display-name
attachments
buffer-size
(
external-format
:utf-8
))
(
let*
((
boundary
(
make-random-boundary
))
(
html-boundary
(
if
(
and
attachments
html-message
)
(
make-random-boundary
)
boundary
))
(
content-type
(
format
nil
"text/plain; charset=~S"
(
string-upcase
(
symbol-name
external-format
)))))
(
send-mail-headers
stream
:from
from
:to
to
:cc
cc
: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
)
(
write-blank-line
stream
))
;;----------- 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
(
format
nil
"text/html; charset=~S"
(
string-upcase
(
symbol-name
external-format
)))
: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
external-format
))
(
send-end-marker
stream
boundary
))))
(
defun
write-to-smtp
(
stream
command
)
(
print-debug
(
format
nil
"to server: ~A"
command
))
(
write-sequence
command
stream
)
...
...
package.lisp
View file @
77917e13
...
...
@@ -33,7 +33,8 @@
"ATTACHMENT-DATA-PATHNAME"
"ATTACHMENT-MIME-TYPE"
"RFC2045-Q-ENCODE-STRING"
"RFC2231-ENCODE-STRING"
))
"RFC2231-ENCODE-STRING"
"WRITE-RFC8822-MESSAGE"
))
(
in-package
:cl-smtp
)
...
...
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