(require "setf")
(require "datetime")
(require "sysinfo")
(require "base64")
(defpackage #:smtp
(:use #:openlisp #:base64)
(:export #:send-mail))
(in-package #:smtp)
(defconstant +smtp-nl+ (convert '(#\Carriage-Return #\Newline) <string>))
(defglobal *smtp-port* 25)
(defglobal *smtp-mailer* nil)
(defdynamic *smtp-debug* nil)
(defun smtp-debug (&rest flag)
(if flag
(setf (dynamic *smtp-debug*) flag)
(dynamic *smtp-debug*)))
(defun smtp-format (so fmt &rest args)
(when (smtp-debug)
(apply #'format (standard-output) fmt args))
(apply #'format so fmt args))
(defun smtp-x-mailer ()
(or *smtp-mailer*
(let ((info (system-info)))
(setf *smtp-mailer*
(format () "Openlisp v~s (\"~a ~a\"; ~s; \"~s bit\"; ~s)"
(version)
(sysinfo-sysname info)
(sysinfo-sysrelease info)
(sysinfo-sysversion info)
(sysinfo-address-size info)
(sysinfo-character-set info))))))
(defun smtp-request (so status fmt &rest args)
(when (smtp-debug)
(apply #'format (standard-output) fmt args)
(format-fresh-line (standard-output)))
(apply #'format so fmt args)
(send so +smtp-nl+ (length +smtp-nl+))
(smtp-check-status so status))
(defun smtp-base64-encode (login password)
(let ((nul (create-string 1 (int-char 0))))
(base64-encode (string-append nul login nul password))))
(defun smtp-check-status (so status)
(let ((reply nil)
(loop t))
(while (and loop
(setf reply (read-line so nil nil))
(stringp reply)
(> (length reply) 3))
(when (smtp-debug)
(format (standard-output) "~a~%" reply))
(setf loop (char= (elt reply 3) #\-)))
(unless (and (stringp reply) (eq (string-index status reply) 0))
(error "SMTP error: ~a was expected, got ~a~%" status reply))))
(defun send-mail (&rest args)
(let ((server nil)
(from nil)
(to nil)
(cc nil)
(bcc nil)
(subject nil)
(body nil))
(while args
(let ((key (pop args)))
(unless (keywordp key)
(error "getopt: ~a is not a keyword~%" key))
(unless args
(error "getopt: missing value for ~a~%" key))
(case key
((:server) (setf server (pop args)))
((:from) (setf from (pop args)))
((:to) (setf to (pop args)))
((:cc) (setf cc (pop args)))
((:bcc) (setf bcc (pop args)))
((:subject) (setf subject (pop args)))
((:body) (setf body (pop args)))
(t (error "getopt: invalid key ~s~a" key)))))
(unless (and server from
(or to cc bcc))
(error "incomplete arguments~%"))
(with-client-socket (so (get-host-address server) *smtp-port* :tcp)
(smtp-check-status so "220")
(smtp-request so "250" "EHLO ~a" (get-host-name))
(smtp-request so "250" "MAIL FROM: <~a>" from)
(dolist (mail (string-split ";" to))
(smtp-request so "250" "RCPT TO: <~a>" mail))
(dolist (mail (string-split ";" cc))
(smtp-request so "250" "RCPT TO: <~a>" mail))
(dolist (mail (string-split ";" bcc))
(smtp-request so "250" "RCPT TO: <~a>" mail))
(smtp-request so "354" "DATA")
(smtp-format so "From: ~a~%" from)
(smtp-format so "To: ~a~%" to)
(when cc
(smtp-format so "Cc: ~a~%" cc))
(when bcc
(smtp-format so "Bcc: ~a~%" bcc))
(when subject
(smtp-format so "Subject: ~a~%" subject))
(smtp-format so "Date: ~a~%" (get-internal-date nil :GMT))
(smtp-format so "Content-Type: text/plain; charset=\"iso-8859-1\"~%")
(smtp-format so "Content-Encoding: Binary~%")
(smtp-format so "X-Mailer: ~a~%" (smtp-x-mailer))
(smtp-format so "~%")
(cond
((null body)
t)
((and (consp body) (stringp (car body)))
(dolist (line body)
(smtp-format so "~a~a" line +smtp-nl+)))
(t
(smtp-format so "~a" body)))
(smtp-format so "~a.~a" +smtp-nl+ +smtp-nl+)
(smtp-check-status so "250")
(smtp-request so "221" "QUIT")
t)))
(provide "smtp")