From 5f8f8287755964a64a6a14e75b1450e6a5f1510a Mon Sep 17 00:00:00 2001 From: Stelian Ionescu Date: Wed, 16 Apr 2008 00:03:20 +0200 Subject: [PATCH] Remove SMTP client. Signed-off-by: Stelian Ionescu --- net.smtp-client.asd | 20 --- protocols/smtp/attachments.lisp | 149 -------------------- protocols/smtp/client-authentication.lisp | 55 -------- protocols/smtp/client-commands.lisp | 79 ----------- protocols/smtp/client-net.lisp | 44 ------ protocols/smtp/pkgdcl.lisp | 28 ---- protocols/smtp/smtp.lisp | 157 ---------------------- 7 files changed, 532 deletions(-) delete mode 100644 net.smtp-client.asd delete mode 100644 protocols/smtp/attachments.lisp delete mode 100644 protocols/smtp/client-authentication.lisp delete mode 100644 protocols/smtp/client-commands.lisp delete mode 100644 protocols/smtp/client-net.lisp delete mode 100644 protocols/smtp/pkgdcl.lisp delete mode 100644 protocols/smtp/smtp.lisp diff --git a/net.smtp-client.asd b/net.smtp-client.asd deleted file mode 100644 index 08752741..00000000 --- a/net.smtp-client.asd +++ /dev/null @@ -1,20 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*- - -(in-package :common-lisp-user) - -(asdf:defsystem :net.smtp-client - :description "SMTP client library." - :author "Jan Idzikowski" - :maintainer "Stelian Ionescu " - :licence "LLGPL-2.1" - :depends-on (:alexandria :osicat :net.sockets :cl-base64) - :pathname (merge-pathnames (make-pathname :directory '(:relative "protocols" "smtp")) - *load-truename*) - :serial t - :components - ((:file "pkgdcl") - (:file "client-net") - (:file "client-commands") - (:file "client-authentication") - (:file "attachments") - (:file "smtp"))) diff --git a/protocols/smtp/attachments.lisp b/protocols/smtp/attachments.lisp deleted file mode 100644 index 548f974b..00000000 --- a/protocols/smtp/attachments.lisp +++ /dev/null @@ -1,149 +0,0 @@ -;;; -*- mode: Lisp -*- - -;;; This file is part of CL-SMTP, the Lisp SMTP Client - - -;;; Copyright (C) 2004/2005/2006/2007 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: attachments.lisp -;;; Description: encoding and transmitting login to include a mime attachment - -;;; -;;; Contributed by Brian Sorg -;;; -;;; Thanks to David Cooper for make-random-boundary -;;; -(in-package :net.smtp-client) - -;;; Addition to allow for sending mime attachments along with the smtp message - -;;---- Initialize array of possible boundary characters to make start of attachments -(defparameter *boundary-chars* - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789") - -(defun make-random-boundary (&optional (length 30) (boundary-chars *boundary-chars*)) - (let ((boundary (make-string length)) - (prefix "_---------_") - (chars-length (length boundary-chars))) - (dotimes (i length (concatenate 'string prefix boundary)) - (setf (aref boundary i) - (char *boundary-chars* (random chars-length)))))) - -(defun generate-multipart-header (sock boundary &key (multipart-type "mixed")) - (format-socket sock "Content-type: multipart/~a;~%~tBoundary=\"~a\"" - multipart-type boundary)) - -(defun generate-message-header (sock - &key boundary ;; uniques string of character -- see make-random-boundary - content-type ;; "text/plain; charset=ISO-8859-1" - content-disposition ;; inline attachment - content-transfer-encoding ;; 7 bit or 8 bit - (include-blank-line? t)) - (when boundary - (format-socket sock "--~a" boundary)) - (when content-type - (format-socket sock "Content-type: ~a" content-type)) - (when content-disposition - (format-socket sock "Content-Disposition: ~A" - content-disposition)) - (when content-transfer-encoding - (format-socket sock "Content-Transfer-Encoding: ~A" - content-transfer-encoding)) - (when include-blank-line? (write-blank-line sock))) - -(defun send-attachment-header (sock boundary name) - (generate-message-header - sock - :boundary boundary - :content-type (format nil "~a;~%~tname=\"~a\"" (lookup-mime-type name) name) - :content-transfer-encoding "base64" - :content-disposition (format nil "attachment; filename=\"~a\"" name))) - -(defun send-end-marker (sock boundary) - ;; Note the -- at beginning and end of boundary is required - (format-socket sock "~%--~a--~%" boundary)) - -(defun send-attachment (sock attachment boundary buffer-size) - (when (probe-file attachment) - (let ((name (file-namestring attachment))) - (send-attachment-header sock boundary name) - (base64-encode-file attachment sock :buffer-size buffer-size)))) - -(defun base64-encode-file (file-in sock &key - (buffer-size 256) ;; in KB - (wrap-at-column 70)) - "Encodes the file contents given by `FILE-IN', which can be of any form -appropriate to with-open-file, and write the base-64 encoded version to `SOCK', -which is a socket. -`BUFFER-SIZE', given in KB, controls how much of the file is processed and -written to the socket at one time. A `BUFFER-SIZE' of 0, processes the file all -at once, regardless of its size. One will have to weigh the speed vs, memory -consuption risks when chosing which way is best. -`WRAP-AT-COLUMN' controls where the encode string is divided for line breaks." - (when (probe-file file-in) - ;;-- open filein --------- - (with-open-file (strm-in file-in - :element-type '(unsigned-byte 8)) - (let* (( ;; convert buffer size given to bytes - ;; or compute bytes based on file - max-buffer-size - (if (zerop buffer-size) - (file-length strm-in) - ;; Ensures 64 bit encoding is properly - ;; divided so that filler - ;; characters are not required between chunks - (* 24 (truncate (/ (* buffer-size 1024) 24))))) - (column-count 0) - (eof? nil) - (buffer (make-array max-buffer-size - :element-type '(unsigned-byte 8)))) - (loop - (let* (( ;; read a portion of the file into the buffer arrary and - ;; returns the index where it stopped - byte-count (dotimes (i max-buffer-size max-buffer-size) - (let ((bchar (read-byte strm-in nil 'EOF))) - (if (eql bchar 'EOF) - (progn - (setq eof? t) - (return i)) - (setf (aref buffer i) bchar)))))) - (if (zerop buffer-size) - ;; send file all at once to socket. - (cl-base64:usb8-array-to-base64-stream - buffer sock :columns wrap-at-column) - ;; otherwise process file in chunks. - ;; The extra encoded-string, - ;; and its subseq functions are brute force methods - ;; to properly handle the wrap-at-column feature - ;; between buffers. - ;; Not the most efficient way, - ;; but it works and uses existing functions - ;; in the cl-base64 package. - (let* (( ;; drops off extra elements that were not filled in in reading, this is important for lisp systems that default a value into - ;; the array when it is created. -- ie Lispworks, SBCL - trimmed-buffer (if eof? - (subseq buffer 0 byte-count) - buffer)) - (encoded-string - (cl-base64:usb8-array-to-base64-string - trimmed-buffer))) - (loop for ch across encoded-string - do (progn - (write-char ch sock) - (incf column-count) - (when (= column-count wrap-at-column) - (setq column-count 0) - (write-char #\Newline sock)))))) - (force-output sock) - (when (or (zerop buffer-size) - eof?) - (return)))))))) diff --git a/protocols/smtp/client-authentication.lisp b/protocols/smtp/client-authentication.lisp deleted file mode 100644 index cc76bf99..00000000 --- a/protocols/smtp/client-authentication.lisp +++ /dev/null @@ -1,55 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*- -;;; -;;; client-authentication.lisp --- SMTP authentication. -;;; -;;; Copyright (C) 2007-2008, Stelian Ionescu -;;; -;;; This code is free software; you can redistribute it and/or -;;; modify it under the terms of the version 2.1 of -;;; the GNU Lesser General Public License as published by -;;; the Free Software Foundation, as clarified by the -;;; preamble found here: -;;; http://opensource.franz.com/preamble.html -;;; -;;; This program 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 -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General -;;; Public License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;;; Boston, MA 02110-1301, USA - -(in-package :net.smtp-client) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *smtp-authenticators* (make-hash-table :test #'eq))) - -(defun invoke-authentication (name args) - (check-type args cons) - (let ((auth-fun (gethash name *smtp-authenticators*))) - (if auth-fun - (funcall auth-fun args) - (error "Unknown authentication method: ~A" name)))) - -(defmacro defauthentication (name (socket args) &body body) - `(setf (gethash ,name *smtp-authenticators*) - #'(lambda (,socket ,args) - ,@body))) - -(defauthentication :plain (sock args) - (format-socket sock "AUTH PLAIN ~A" - (string-to-base64-string - (format nil "~A~C~A~C~A" (first args) - #\Null (first args) #\Null - (second args)))) - (read-smtp-return-code sock 235 "Plain authentication failed")) - -(defauthentication :login (sock args) - (write-to-smtp sock "AUTH LOGIN") - (read-smtp-return-code sock 334 "Login authentication start failed") - (write-to-smtp sock (string-to-base64-string (first args))) - (read-smtp-return-code sock 334 "Login authentication username send failed") - (write-to-smtp sock (string-to-base64-string (second args))) - (read-smtp-return-code sock 235 "Login authentication password send failed")) diff --git a/protocols/smtp/client-commands.lisp b/protocols/smtp/client-commands.lisp deleted file mode 100644 index 39409a5e..00000000 --- a/protocols/smtp/client-commands.lisp +++ /dev/null @@ -1,79 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*- -;;; -;;; client-commands.lisp --- SMTP commands. -;;; -;;; Copyright (C) 2007-2008, Stelian Ionescu -;;; -;;; This code is free software; you can redistribute it and/or -;;; modify it under the terms of the version 2.1 of -;;; the GNU Lesser General Public License as published by -;;; the Free Software Foundation, as clarified by the -;;; preamble found here: -;;; http://opensource.franz.com/preamble.html -;;; -;;; This program 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 -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General -;;; Public License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;;; Boston, MA 02110-1301, USA - -(in-package :net.smtp-client) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *smtp-client-commands* (make-hash-table :test #'eq)) - - (defun make-smtp-cmd-name (name) - (format-symbol t "~A-~A-~A" '#:smtp name '#:cmd))) - -(defun read-smtp-return-code (sock expected-code error-msg) - (multiple-value-bind (code msg) - (read-from-smtp sock) - (when (/= code expected-code) - (error "~A: ~A" error-msg msg)))) - -(defmacro define-smtp-command (name (sock &rest args) &body body) - (let ((cmd-name (make-smtp-cmd-name name))) - `(progn - (defun ,cmd-name (,sock ,@args) - ,@body) - (setf (gethash ,name *smtp-client-commands*) - ',cmd-name)))) - -(defmacro invoke-smtp-command (name sock &rest args) - (let ((cmd-sym (gethash name *smtp-client-commands*))) - (if cmd-sym - `(,cmd-sym ,sock ,@args) - (error "Unknown SMTP command: ~A" name)))) - -;;; -;;; SMTP Commands -;;; - -(define-smtp-command :mail-from (sock from) - (format-socket sock "MAIL FROM: <~A>" from) - (read-smtp-return-code sock 250 "in MAIL FROM command")) - -(define-smtp-command :rcpt-to (sock addresses) - (dolist (to addresses) - (format-socket sock "RCPT TO: <~A>" to) - (read-smtp-return-code sock 250 "in RCPT TO command"))) - -(define-smtp-command :data (sock) - (format-socket sock "DATA") - (read-smtp-return-code sock 354 "in DATA command")) - -(define-smtp-command :quit (sock) - (format-socket sock "QUIT") - (read-smtp-return-code sock 221 "in QUIT command")) - -(define-smtp-command :ehlo (sock host-name) - (format-socket sock "EHLO ~A" host-name) - (read-smtp-return-code sock 250 "in EHLO command")) - -(define-smtp-command :helo (sock host-name) - (format-socket sock "HELO ~A" host-name) - (read-smtp-return-code sock 250 "in HELO command")) diff --git a/protocols/smtp/client-net.lisp b/protocols/smtp/client-net.lisp deleted file mode 100644 index 3c9c5325..00000000 --- a/protocols/smtp/client-net.lisp +++ /dev/null @@ -1,44 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*- -;;; -;;; client-net.lisp --- Miscellaneous socket routines. -;;; -;;; Copyright (C) 2007-2008, Stelian Ionescu -;;; -;;; This code is free software; you can redistribute it and/or -;;; modify it under the terms of the version 2.1 of -;;; the GNU Lesser General Public License as published by -;;; the Free Software Foundation, as clarified by the -;;; preamble found here: -;;; http://opensource.franz.com/preamble.html -;;; -;;; This program 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 -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General -;;; Public License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;;; Boston, MA 02110-1301, USA - -(in-package :net.smtp-client) - -(defun make-smtp-socket (host port) - (make-socket :family :internet :type :stream :connect :active - :remote-host host :remote-port port - :external-format '(:iso-8859-1 :eol-style :crlf))) - -(defun write-to-smtp (socket command) - (write-line command socket) - (finish-output socket)) - -(defun format-socket (socket cmdstr &rest args) - (write-to-smtp socket (apply #'format nil cmdstr args)) - (finish-output socket)) - -(defun read-from-smtp (sock) - (let* ((line (read-line sock)) - (response-code (parse-integer line :start 0 :junk-allowed t))) - (if (= (char-code (elt line 3)) (char-code #\-)) - (read-from-smtp sock) - (values response-code line)))) diff --git a/protocols/smtp/pkgdcl.lisp b/protocols/smtp/pkgdcl.lisp deleted file mode 100644 index 79857b3e..00000000 --- a/protocols/smtp/pkgdcl.lisp +++ /dev/null @@ -1,28 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*- -;;; -;;; pkgdcl.lisp --- Package definition. -;;; -;;; Copyright (C) 2007-2008, Stelian Ionescu -;;; -;;; This code is free software; you can redistribute it and/or -;;; modify it under the terms of the version 2.1 of -;;; the GNU Lesser General Public License as published by -;;; the Free Software Foundation, as clarified by the -;;; preamble found here: -;;; http://opensource.franz.com/preamble.html -;;; -;;; This program 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 -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General -;;; Public License along with this library; if not, write to the -;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, -;;; Boston, MA 02110-1301, USA - -(in-package :common-lisp-user) - -(defpackage :net.smtp-client - (:use #:common-lisp :alexandria :net.sockets :cl-base64) - (:export #:send-email)) diff --git a/protocols/smtp/smtp.lisp b/protocols/smtp/smtp.lisp deleted file mode 100644 index 227cbb17..00000000 --- a/protocols/smtp/smtp.lisp +++ /dev/null @@ -1,157 +0,0 @@ -;;; -*- 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 :net.smtp-client) - -(defvar *x-mailer* - (format nil "(~A ~A)" - (lisp-implementation-type) - (lisp-implementation-version))) - -;;; -;;; Protocol handling -;;; - -(defun check-arg (arg name) - (cond - ((or (stringp arg) - (pathnamep 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" #\NewLine #\NewLine)) - (maskdotsr (format nil "~C..~C" #\NewLine #\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 3)))) - (t - (setf resultstr (concatenate 'string resultstr - tempstr))))))) - (mask str)) - resultstr)) - -(defun string-to-base64-string (str) - (string-to-base64-string str)) - -(defun send-email (host from to subject message - &key (port 25) cc bcc reply-to extra-headers - display-name authentication - attachments (buffer-size 256)) - (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 - :authentication authentication - :attachments (check-arg attachments "attachments") - :buffer-size (if (numberp buffer-size) - buffer-size - 256))) - -(defun send-smtp (host from to subject message - &key (port 25) cc bcc reply-to extra-headers - display-name authentication attachments buffer-size) - (with-open-stream (sock (make-smtp-socket host port)) - (open-smtp-connection sock authentication) - (send-message-envelope sock from to cc bcc) - (invoke-smtp-command :data sock) - (send-message-headers sock from to subject cc reply-to extra-headers display-name) - (send-message-body sock message attachments buffer-size) - (invoke-smtp-command :quit sock))) - -(defun open-smtp-connection (sock authentication) - (read-smtp-return-code sock 220 "Wrong response from smtp server") - (cond - (authentication - (invoke-smtp-command :ehlo sock (nix:gethostname)) - (invoke-authentication (first authentication) (rest authentication))) - (t - (invoke-smtp-command :helo sock (nix:gethostname))))) - -(defun send-message-envelope (sock from to cc bcc) - (invoke-smtp-command :mail-from sock from) - (invoke-smtp-command :rcpt-to sock to) - (invoke-smtp-command :rcpt-to sock cc) - (invoke-smtp-command :rcpt-to sock bcc)) - -(defun send-message-headers (sock from to subject cc reply-to extra-headers display-name) - (format-socket sock "Date: ~A" (get-email-date-string)) - (format-socket sock "From: ~@[~A <~]~A~@[>~]" - display-name from display-name) - (format-socket sock "To: ~{ ~a~^,~}" to) - (when cc - (format-socket sock "Cc: ~{ ~A~^,~}" cc)) - (format-socket sock "Subject: ~A" subject) - (format-socket sock "X-Mailer: cl-smtp ~A" *x-mailer*) - (when reply-to - (format-socket sock "Reply-To: ~A" reply-to)) - (dolist (l extra-headers) - (format-socket sock "~A: ~{~A~^,~}" (car l) (rest l))) - (write-to-smtp sock "Mime-Version: 1.0")) - -(defun send-message-body (sock message attachments buffer-size) - (let ((boundary (make-random-boundary))) - (when attachments - (generate-multipart-header sock boundary) - (terpri sock) - (setf message (wrap-message-with-multipart-dividers - message boundary))) - (write-to-smtp sock message) - (when attachments - (dolist (attachment attachments) - (send-attachment sock attachment boundary buffer-size)) - (send-attachments-end-marker sock boundary)) - (write-char #\. sock) (terpri sock) (finish-output sock) - (read-smtp-return-code sock 250 "Message send failed"))) - -(defun get-email-date-string () - (multiple-value-bind (sec min h d m y wd) (get-decoded-time) - (let* ((month (aref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") (- m 1))) - (weekday (aref #("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)))))))))