protocols/smtp/attachments.lisp

   1 ;;; -*- mode: Lisp -*-
   2
   3 ;;; This file is part of CL-SMTP, the Lisp SMTP Client
   4
   5 ;;; Copyright (C) 2004/2005 Jan Idzikowski
   6
   7 ;;; This library is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the Lisp Lesser General Public License
   9 ;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
  10
  11 ;;; This library is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; Lisp Lesser GNU General Public License for more details.
  15
  16 ;;; File: attachments.lisp
  17 ;;; Description: encoding and transmitting login to include a mime attachment
  18
  19 ;;;
  20 ;;; Contributed by Brian Sorg
  21 ;;;
  22 ;;; Thanks to David Cooper for make-random-boundary
  23 ;;;
  24 (in-package :net.smtp-client)
  25
  26 ;;; Addition to allow for sending mime attachments along with the smtp message
  27
  28 ;;---- Initialize array of possible boundary characters to make start of attachments
  29 (defparameter *boundary-chars*
  30   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
  31
  32 (defun make-random-boundary (&optional (length 50) (boundary-chars *boundary-chars*))
  33   (let ((boundary (make-string length))
  34         (chars-length (length boundary-chars)))
  35     (dotimes (i length boundary)
  36       (setf (aref boundary i) (char *boundary-chars* (random chars-length))))))
  37
  38 (defun generate-multipart-header (sock boundary)
  39   (format-socket sock "Content-type: multipart/mixed;~%~tBoundary=\"~A\""
  40                  boundary))
  41
  42 (defun wrap-message-with-multipart-dividers (message boundary)
  43   (concatenate 'string (format nil "--~A~%" boundary)
  44                (format nil "Content-type: text/plain~%")
  45                (format nil "Content-Disposition: inline~%")
  46                (format nil "~%")
  47                message (format nil "~%")))
  48
  49 (defun send-attachment (sock attachment boundary buffer-size)
  50   (when (probe-file attachment)
  51     (let ((name (file-namestring attachment)))
  52       (send-attachment-header sock boundary name)
  53       (base64-encode-file attachment sock :buffer-size buffer-size))))
  54
  55 (defun send-attachment-header (sock boundary name)
  56   (format-socket sock "~%--~A~%Content-type: application/octet-stream;~%~tname=\"~A\"~%Content-Transfer-Encoding: base64~%Content-Disposition: attachment; filename=\"~A\"~%" boundary name name))
  57
  58 (defun send-attachments-end-marker (sock boundary)
  59   (write-to-smtp sock (format nil "~%--~A--~%" boundary)))
  60
  61 (defun base64-encode-file (file-in sock
  62                            &key
  63                            (buffer-size 256) ;; in KB
  64                            (wrap-at-column 76))
  65   (let* ((max-buffer-size (* buffer-size 1024))
  66          (byte-count 0)
  67          (buffer (make-array max-buffer-size
  68                              :element-type '(unsigned-byte 8))))
  69     (when (probe-file file-in)
  70       ;;-- open filein ---------
  71       (with-open-file (strm-in file-in
  72                                :element-type '(unsigned-byte 8))
  73         (loop
  74            (setq byte-count 0)
  75            ;; read a portion of the file into the buffer
  76            (setq byte-count (dotimes (i max-buffer-size max-buffer-size)
  77                               (let ((bchar (read-byte strm-in nil 'EOF)))
  78                                 (if (eql bchar 'EOF)
  79                                     (return i)
  80                                     (setf (aref buffer i) bchar)))))
  81            ;; encode the buffer and write out to stream
  82            (usb8-array-to-base64-stream
  83             (if (< byte-count max-buffer-size)
  84                 (trimmed-buffer byte-count buffer)
  85                 buffer)
  86             sock :columns wrap-at-column)
  87            (finish-output sock)
  88            ;;-- when finished reading exit do loop
  89            (when (< byte-count max-buffer-size)
  90              (return)))))))
  91
  92 (defun trimmed-buffer (byte-count buffer)
  93   "Creates an array the length of byte-count and copies contents of buffer into it.
  94 Needed in Lispworks, Lispworks initialized all elements of the buffer array when it was made, allegro doesn't
  95 seem to have this behavior"
  96   (let ((trimmed-buffer (make-array byte-count :element-type '(unsigned-byte 8))))
  97     (dotimes (i byte-count trimmed-buffer)
  98       (setf (aref trimmed-buffer i) (aref buffer i)))))
  99
 100
 101
 102
 103
 104
 105