cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

email.lisp (4290B)

      1 ;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.email
     24   (:use :cl)
     25   (:export :directory-reader
     26            :file-reader))
     27 
     28 (in-package :rw.email)
     29 
     30 ;;(with-open-file (s "~/Mail/goethe/27") (rw:till (rw:peek-reader (rw:char-reader s))))
     31 
     32 (defun header-reader (reader)
     33   (let (eof (r (rw:peek-reader reader)))
     34     (flet ((peek () (rw:peek r))
     35            (next () (rw:next r))
     36            (skip () (rw:skip r))
     37            (till (items) (rw:till r items)))
     38       (lambda ()
     39         (or eof
     40             (case (peek)
     41               ((nil) (setq eof 'eof))
     42               (#\newline (next) (setq eof t))
     43               (t (cons
     44                   (prog1 (till '(#\space #\tab #\newline #\:))
     45                     (assert (eql #\: (next)))
     46                     (skip))
     47                   (with-output-to-string (s)
     48                     (flet ((line ()
     49                              (write-string (till '(#\newline)) s)
     50                              (assert (eql #\newline (next)))))
     51                       (line)
     52                       (do ()
     53                           ((not (member (peek) '(#\space #\tab))))
     54                         (terpri s)
     55                         (line))))))))))))
     56 
     57 (defun header-alist (reader)
     58   (rw:till (rw:peek-reader (header-reader (rw:char-reader reader)))))
     59 
     60 (defun content-type (reader) ;; TODO make link undefined, add collector?
     61   (flet ((peek () (rw:peek reader))
     62          (next () (rw:next reader))
     63          (skip () (rw:skip reader))
     64          (till (items) (rw:till reader items)))
     65     (let ((mime (till '(#\space #\tab #\newline #\;))))
     66       (make
     67        (link mime)
     68        (assert (eql #\; (next)))
     69        (skip)
     70        (do ()
     71            ((not (peek)))
     72          (link (let ((k (till '(#\space #\tab #\newline #\=))))
     73                  (cond
     74                    ((string= "type" k) :type)
     75                    ((string= "boundary" k) :boundary)
     76                    (t (error "unknown attribute ~s of content-type ~s" k mime)))))
     77          (assert (eql #\= (next)))
     78          (assert (eql #\" (next)))
     79          (link (till '(#\space #\tab #\newline #\")))
     80          (assert (eql #\" (next)))
     81          (when (eql #\; (peek))
     82            (next)
     83            (skip)))))))
     84 
     85 ;; https://en.wikipedia.org/wiki/MIME#Multipart_subtypes
     86 (defun parse-nnml-file (pathname)
     87   (with-open-file (s pathname)
     88     (let ((x (rw:peek-reader (rw:char-reader (cdr (assoc "Content-Type" (header-alist s) :test #'string=))))))
     89       (destructuring-bind (mime &key type boundary) (content-type x)
     90         (cond
     91           #+nil
     92           ((string= "multipart/mixed" mime)
     93            (list mime type boundary))
     94           ((string= "multipart/alternative" mime)
     95            (list mime type boundary))
     96           ((string= "multipart/related" mime)
     97            (list mime type boundary))
     98           #+nil
     99           ((string= "multipart/form-data" mime)
    100            (list mime type boundary))
    101           #+nil
    102           ((string= "multipart/signed" mime)
    103            (list mime type boundary))
    104           #+nil
    105           ((string= "multipart/encrypted" mime)
    106            (list mime type boundary))
    107           (t (error "unknown content-type ~s" mime)))))))
    108 
    109 ;;(parse-nnml-file "~/Mail/goethe/27")