;;;; -*-Mode:LISP; Package:LISP; Base:10; Syntax:ISLISP -*-
;;;; Title:     smtp.lsp
;;;; Author:    C. Jullien
;;;; License:   New BSD license
;;;; CVS:       "$Id: smtp.lsp,v 1.21 2013/06/18 05:21:56 jullien Exp $"

;;;
;;;     smtp.lsp:       Simple Mail Transfer Protocol for sending mail.
;;;
;;;     See RFC-2821 (2001) or, obsolete, RFC-0821 (1982).

;;; 2011/04/12: Use EHLO instead of HELO (RFC-2821).
;;; 2011/04/08: Use keywords.
;;; 2005/08/28: Read multiple response lines (XXX-...)

(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)
   ;; if you want AUTH PLAIN:
   ;; "AUTH PLAIN" + (smtp-base64-encode "mylogname@domain.com" "mypassword")
   (let ((nul (create-string 1 (int-char 0))))
        ;; note can also be login nul login nul passord
        (base64-encode (string-append nul login nul password))))

(defun smtp-check-status (so status)
   ;; "XXX-..." are continuation lines.
   ;; "XXX ..." is the final response line.
   (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)
   ;; Example:
   ;; (smtp-send-mail :server  "smtp.site.com"
   ;;                 :from    "me@domain.com"
   ;;                 :to      "someone@domain.com;someone.else@domain.com"
   ;;                 :cc      "you@domain.com"
   ;;                 :bcc     "secret@domain.com"
   ;;                 :subject "Hello"
   ;;                 :body    "Some message - Me Myself And I--")
   ;; Note: :body argument may be either a single string which is the complete
   ;; body of the message (each line is terminated by newline) or a list of
   ;; strings without newline. In that case, a newline is automatically added.
   (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)
           ;; get connection status
           (smtp-check-status so "220")
           ;; initiate negociation
           (smtp-request so "250" "EHLO ~a" (get-host-name))
           ;; if EHLO fails with error 500, we should try again with HELO
           (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")
           ;; send header
           (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 "~%")
           ;; send body (optional)
           (cond
                 ((null body)
                  ;; Ok! no body
                  t)
                 ((and (consp body) (stringp (car body)))
                  ;; assume a list of line without newline
                  (dolist (line body)
                     (smtp-format so "~a~a" line +smtp-nl+)))
                 (t
                  ;; send body 
                  (smtp-format so "~a" body)))
           (smtp-format so "~a.~a" +smtp-nl+ +smtp-nl+)
           (smtp-check-status so "250")
           ;; quit conversation
           (smtp-request so "221" "QUIT")
           t)))

(provide "smtp")