mbox-parser

mbox-parser.lisp

;;; mbox parser in Common Lisp
;; needs cl-mime and cl-base64
;; (ql:quickload :cl-mime)
;; (ql:quickload :cl-base64)
;;
;; Example: returns all emails in an mbox (as CL-MIME:MIME objects)
;;
;; (with-open-file (in #p"/path/to/mbox")
;;   (let ((p (make-parser :stream in)))
;;     (loop for mime = (next-mime p)
;;        while mime
;;        collect mime)))

(defpackage #:mbox-parser
  (:use #:cl))

(in-package #:mbox-parser)

(defparameter *mail-start* "From ")

(defstruct parser
  stream
  from-line)

(defun starts-with (prefix string &key (start 0) end)
  (string= prefix string
           :start2 start
           :end2 (min (or end (length string)) (+ start (length prefix)))))

(defun is-from-line (line)
  (starts-with *mail-start* line))

(defun is-escaped-line (line)
  (and (not (zerop (length line)))
       (eql (char line 0) #\>)
       (let ((rest-start (position #\> line :test (complement #'eql) :start 1)))
         (starts-with *mail-start* line :start rest-start))))

(defun unescape-line (line)
  (if (is-escaped-line line)
      (subseq line 1)
      line))

(defun next-mime (parser)
  (with-slots (stream from-line)
      parser
    (let ((first-line (read-line stream nil nil)))
      (cond ((null first-line) nil)
            ((null from-line)
             (assert (is-from-line first-line)
                     nil
                     "Expected From_ line, got: ~A" first-line)
             (setf from-line first-line)
             (next-mime parser))
            (t (cl-mime:parse-mime
                (with-output-to-string (out)
                  (write-line (unescape-line first-line) out)
                  (loop
                     (let ((line (read-line stream nil nil)))
                       (cond
                         ((null line) (return))
                         ((is-from-line line) (setf from-line line) (return))
                         (t (write-line (unescape-line line) out))))))))))))

(defun mime-attachments (mime)
  (let* ((parts (cl-mime:content mime)))
    (remove-if-not (lambda (mime)
                     (string= (cl-mime:content-disposition mime) "attachment"))
                   parts)))

(defun attachment-filename (attachment)
  (or (cl-mime:get-content-disposition-parameter attachment :filename)
      (cl-mime:get-content-type-parameter attachment :name)))

(defun write-attachment (attachment pathname)
  (when (zerop (length (file-namestring pathname)))
    (setf pathname (merge-pathnames (parse-namestring (attachment-filename attachment))
                                    pathname)))
  (with-open-file (out pathname :direction :output :element-type '(unsigned-byte 8))
    (let ((array (cl-base64:base64-string-to-usb8-array (cl-mime:content attachment))))
      (write-sequence array out)))
  pathname)