;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*- ;;; ;;; Time-stamp: <2008-11-25 22:04:06 madhu> ;;; Touched: Thu May 20 18:14:29 2004 +0530 ;;; Bugs-To: (enometh@net.meer) ;;; Originally-based-on: Teemu Kalvas' fastcgi-cmucl;fastcgi.lisp ;;; Status: Experimental. Do not redistribute. ;;; Copyright (C) 2004, 2006 Madhu. All rights reserved. ;;; (cl:defpackage "CMIME2" ; octet version (:use "CL") (:nicknames "CMIME")) (cl:in-package "CMIME2") ;;; ---------------------------------------------------------------------- ;;; ;;; (defpackage "CMIME-KEYWORDS" (:use) (:export "BASE64" "QUOTED-PRINTABLE")) (defpackage "CMIME-HEADERS" (:use) (:export "CONTENT-DISPOSITION" "CONTENT-TYPE" "CONTENT-DESCRIPTION" "CONTENT-ID" "CONTENT-TRANSFER-ENCODING" "MIME-VERSION")) (eval-when (load eval compile) (pushnew :cmime *features*)) ;;; ---------------------------------------------------------------------- ;;; ;;; (defconstant Space 32 "(char-code #\\Space)") (defconstant Newline 10 "(char-code #\\Newline)") (defconstant Return 13 "(char-code #\\Return)") (defconstant Colon 58 "(char-code #\\Colon)") (defconstant Tab 9 "(char-code #\\Tab)") (defconstant Space 32 "(char-code #\\Space)") (defconstant Tab 9 "(char-code #\\Tab)") (defconstant Quotedbl 34 "(char-code #\\\")") (defconstant Backslash 92 "(char-code #\\\\)") (defconstant Bracketleft 91 "(char-code #\\\[)") (defconstant Bracketright 93 "(char-code #\\\])") (defconstant Parenleft 40 "(char-code #\\\()") (defconstant Parenright 41 "(char-code #\\\))") (defconstant Equal 61 "(char-code #\\=)") (defconstant Slash 47 "(char-code #\\/)") (defconstant Semicolon 59 "(char-code #\\;)") ;;; ---------------------------------------------------------------------- ;;; ;;; (defun get-end-of-line (byte-buffer &key (start 0) end) "Return as values the positions at and past the end of the current line." ;; should we return endl or end for second value? (loop with endl = (or end (length byte-buffer)) for i from start below endl if (= (aref byte-buffer i) Newline) ; lf return (values i (if (< (1+ i) endl) (1+ i) endl)) if (= (aref byte-buffer i) Return) return (values i (if (< (1+ i) endl) (if (= (aref byte-buffer (1+ i)) Newline) ; crlf (if (< (+ i 2) endl) (+ i 2) end) (+ i 1)) endl)))) (defun read-headers (byte-buffer &key (start 0) end collect-key collect-val finish-key-val) "Return as values the keyword :EOH and position past the end of headers. If non-NIL, COLLECT-KEY and COLLECT-VAL are functions that take a single octet as argument. These are mapped over the octets of the key and value of each header. If non-NIL, FINISH-KEY-VAL is a function that takes no arguments. It is invoked after reading each header." ;; TODO: seperate FINISH-KEY and FINISH-VALUE so VALUE need not be ;; processed. (let (line-end next-line-start (state :key)) (loop for pos = start then next-line-start do (multiple-value-setq (line-end next-line-start) (get-end-of-line byte-buffer :start pos :end end)) (when (= line-end pos) (return (values (if (eq state :key) :EOH) next-line-start))) (ecase state (:key (let ((colonpos (position Colon byte-buffer :start pos :end line-end))) (assert colonpos) (assert (< (1+ colonpos) (or end (length byte-buffer)))) (when collect-key ; collect key (loop for i from pos below colonpos do (funcall collect-key (aref byte-buffer i)))) (let ((startv (position-if-not (lambda (c) (or (= c Space) (= c Tab))) byte-buffer :start (1+ colonpos):end line-end))) (when (and startv (< startv line-end)) ; collect val (when collect-val (loop for i from startv below line-end do (funcall collect-val (aref byte-buffer i))))) (or (when (< next-line-start (or end (length byte-buffer))) (when (or (= (aref byte-buffer next-line-start) Tab) (= (aref byte-buffer next-line-start) Space)) (setq state :value))) (when finish-key-val (funcall finish-key-val)))))) (:value (let ((startc (position-if-not (lambda (c) (or (= c Tab) (= c Space))) byte-buffer :start pos :end line-end))) (when (and startc (< startc line-end)) ; collect cont (when collect-val (funcall collect-val Space) ; ??? (loop for i from startc below line-end do (funcall collect-val (aref byte-buffer i))))) (and (when (< next-line-start (or end (length byte-buffer))) (unless (or (= (aref byte-buffer next-line-start) Tab) (= (aref byte-buffer next-line-start) Space)) (setq state :key))) (when finish-key-val (funcall finish-key-val))))))))) (defmacro with-string-headers-do ((buffer &key (start 0) end) (key-var val-var) &body body) "TESTING. Execute BODY repeatedly in an environment binding variables KEY-VAR and VAL-VAR to strings containing each key value pair of headers in BUFFER." `(let ((,key-var (make-array 0 :fill-pointer 0 :adjustable t :element-type 'character)) (,val-var (make-array 0 :fill-pointer 0 :adjustable t :element-type 'character))) (flet ((collect-key (byte) (vector-push-extend (code-char byte) ,key-var)) (collect-val (byte) (vector-push-extend (code-char byte) ,val-var)) (finish-key-val () ,@body (setf (fill-pointer ,key-var) 0 (fill-pointer ,val-var) 0))) (read-headers ,buffer :start ,start :end ,end :collect-key #'collect-key :collect-val #'collect-val :finish-key-val #'finish-key-val)))) #|| (defvar $nn-buf (user::slurp-file #p"home:outbox/Vamsi.thesis.mail.mac")) (length $nn-buf) (get-end-of-line $nn-buf); => 56, 57 (with-string-headers-do ($nn-buf :start 57) (key val) (format t "~S: ~S~&" key val)); => :EOH, 1276 ||# #+elisp (progn (put 'prog 'common-lisp-indent-function 'lisp-indent-tagbody)) #+elisp (let (annoyance b c d (foo (bar car)) (bar) bar)) ;;; -------------------------------------------------------------------------- ;;; ;;; MIME-DECODERS ;;; ;;; (defconstant *mime-reverse-hextable* #(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 0 1 2 3 4 5 6 7 8 9 nil nil nil nil nil nil nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)) ;;; ;;; (defun mime-decode-quoted-printable (byte-buffer &key (start 0) end stream) "STREAM is an a binary (octet) output stream." ; Chunks input at #\=. (let ((pos start) nextpos (eos (or end (length byte-buffer))) weight1 weight2 char2) (loop (unless (< pos eos) (assert (= pos eos)) (return eos)) (cond ((setq nextpos (position Equal byte-buffer :start pos :end eos)) (write-sequence byte-buffer stream :start pos :end nextpos) (cond ((< (1+ nextpos) eos) (cond ((= (setq char2 (aref byte-buffer (1+ nextpos))) Newline) (setq pos (+ nextpos 2))) ((= char2 Return) (cond ((< (+ nextpos 2) eos) (cond ((= (aref byte-buffer (+ nextpos 2)) Newline) (setq pos (+ nextpos 3))) (t (setq pos (+ nextpos 2))))) (t (return eos)))) ((setq weight1 (aref *mime-reverse-hextable* char2)) (cond ((< (+ nextpos 2) eos) (cond ((setq weight2 (aref *mime-reverse-hextable* (aref byte-buffer (+ nextpos 2)))) (write-byte (+ (* 16 weight1) weight2) stream) (setf pos (+ nextpos 3))) (t (error "HEX2")))) (t (error "EOF-READING-HEX2")))) (t (error "HEX1")))) (t (error "EOS")))) (t (write-sequence byte-buffer stream :start pos :end eos) (return eos)))))) (defun make-octet-vector (sequence &key (start 0) end) ; XXX "TESTING. SEQUENCE is of characters" (let ((len (length sequence))) (make-array len :element-type '(unsigned-byte 8) :initial-contents (if (and (= start 0) (or (null end) (= end len))) (map 'vector 'char-code sequence) (loop for i from start below (or end len) collect (elt sequence i)))))) #|| (with-open-file (stream "/tmp/xyz" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (mime-decode-quoted-printable (make-octet-vector "Hey, =20 =20 Please call me when you get into the office! =20 It's much appreciated. =A0 =20 Karina Walls ") :stream stream)) (user::slurp-file "/tmp/xyz" 'character) ||# ;;; ;;; (defconstant *mime-reverse-base64-table* #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL 62 NIL NIL NIL 63 52 53 54 55 56 57 58 59 60 61 NIL NIL NIL NIL NIL NIL NIL 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 NIL NIL NIL NIL NIL NIL 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) "(loop with vec = (make-array 256 :initial-element nil) for pos from 0 for c across \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" do (setf (aref vec (char-code c)) pos) finally (return vec))") (defun mime-decode-base64 (byte-buffer &key (start 0) end stream) "Stream is a binary (octet) output stream. Returns as values the position of end of input, and the number of bytes written to the stream. Any additional return values are only for debugging and indicate the state when decoding ended." (let ((buf-pos 0) (pos start) (eos (or end (length byte-buffer)))) (declare (type (integer 0) buf-pos start eos)) (flet ((next-byte (&aux c) ;; can we return 0 instead of NIL on eos? (loop (cond ((< pos eos) (cond ((setq c (aref *mime-reverse-base64-table* (aref byte-buffer pos))) (return c)) (t (assert (find (aref byte-buffer pos) (list Newline Return Equal))) (incf pos)))) (t (return nil)))))) (declare (dynamic-extent #'next-byte)) (loop with c for n = (next-byte) ; six unless n return (values pos buf-pos) do (incf pos) (locally (declare (type (unsigned-byte 24) n)) (setq n (* n 64)) ; twelve (cond ((setq c (next-byte)) (incf n c) (incf pos)) (t (error "Unexpected end of base64 encoded input."))) (setq n (* n 64)) ; eighteen (cond ((setq c (next-byte)) (incf n c) (incf pos)) (t (write-byte (ldb (byte 8 10) n) stream) (return (values pos (+ buf-pos 1) n :base-2)))) (setq n (* n 64)) ; twenty-four (cond ((setq c (next-byte)) (incf n c) (incf pos) (write-byte (ldb (byte 8 16) n) stream) (write-byte (ldb (byte 8 8) n) stream) (write-byte (ldb (byte 8 0) n) stream) (incf buf-pos 3)) (t (write-byte (ldb (byte 8 16) n) stream) (write-byte (ldb (byte 8 8) n) stream) (return (values pos (+ buf-pos 2) n :base-3))))))))) #|| (defvar *ccrCentralEGQ* "AAAAFKqp8qBJcxBEK1jCaqOKwNFFl5+z====") (defvar *ccrCentralEGAlpha* "AAAAoJ8uNGMxIhRoDNvAssG0YjH8MIo9bvU3i2vdsYRWE3XrW+DjzfS3hHInTAQZ3VQyy1xf pOLSg5Y8FoGJrhuX108QVnUtl6VT3GNw7WGIcIWF62XsFmrinEmc9hOw1byLEBrRbx4xz9fv EQqz6vlouotsh65VzFY+08fXgcrnhbs2Ned08+JkWl8zLftY/PD1zH/D0fiwyEhbRxwAt/nZ k8Q=") (with-open-file (stream "/tmp/xyz" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (mime-decode-base64 (make-octet-vector *ccrCentralEGQ*) :stream stream)) (user::slurp-file "/tmp/xyz") (with-open-file (stream "/tmp/xyz" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (mime-decode-base64 (make-octet-vector *ccrCentralEGAlpha*):stream stream)) (user::slurp-file "/tmp/xyz") ||# ;;; ---------------------------------------------------------------------- ;;; ;;; RFC822 TOKENIZER ;;; ;;; (defun next-rfc822-token (byte-buffer &key (start 0) end collect-fn specials) "Return as values the type (a keyword), the start position, and the end position of the next token. byte-buffer is an array of octets. SPECIALS is a sequence of octets which are tokenized literally. COLLECT-FN if non-nil is a function which takes a single octet as argument; It is mapped across the octets of a Quoted-string or Domain-literal token. (Comments are ignored)." (unless end (setq end (length byte-buffer))) (prog ((pos start) (state :init) char (nesting 0)) loop (cond ((null (setq char (and (< pos end) (aref byte-buffer pos)))) (return (values (if (eq state :atom) :atom :eos) start end))) (t (ecase state (:init (cond ((or (= char Space) (= char Tab)) (incf start) (incf pos) (go loop)) ((= char Parenleft) (setq state :comment) (incf nesting) (incf pos) (go loop)) ((= char Quotedbl) (setq state :quoted-string) (incf pos) (go loop)) ((= char Bracketleft) (setq state :domain-literal) (incf pos) (go loop)) ((find char specials) (return (values :special start (1+ pos)))) (t (setq state :atom) (incf pos) (go loop)))) (:comment (cond ((= char Parenright) (decf nesting) (cond ((zerop nesting) (return (values state start (1+ pos)))) (t (incf pos) (go loop)))) ((= char Backslash) (incf pos 2) (go loop)) (t (incf pos) (go loop)))) ((:quoted-string :domain-literal) (cond ((= char Backslash) (when collect-fn (if (< (1+ pos) end) (funcall collect-fn (aref byte-buffer (1+ pos))))) (incf pos 2) (go loop)) ((or (and (eq state :quoted-string) (= char Quotedbl)) (and (eq state :domain-literal) (= char Bracketright))) (return (values state start (1+ pos)))) (t (when collect-fn (funcall collect-fn (aref byte-buffer pos))) (incf pos) (go loop)))) (:atom (cond ((or (<= char Space) (find char specials)) (return (values state start pos))) (t (incf pos) (go loop))))))))) #|| (defvar *rfc822-tokenizer-specials* (make-octet-vector '(#\( #\) #\< #\> #\@ #\, #\; #\: #\\ #\. #\[ #\])) "TESTING. Sequence of octets that are treated especially in rfc822.") (defun rfc822-tokenize-string1 (string &optional (specials *rfc822-tokenizer-specials*)) "TESTING." (let ((input (make-octet-vector string)) (pos 0) type start2 end2) (loop (multiple-value-setq (type start2 end2) (next-rfc822-token input :start pos :specials specials)) (if (eq type :eos) (return end2)) (warn "~S ~S" type (subseq string start2 end2)) (setq pos end2)))) (rfc822-tokenize-string1 "Madhu ()") ||# ;;; ---------------------------------------------------------------------- ;;; ;;; ;;; madhu 070314 support babyl's handling apple mail's content type ;;; header boundary=ATOM instead of boundary="quoted-string" (defvar *cmime-intern-keyword-case* :upcase ;madhu 070314 "One of :UPCASE or :PRESERVE. Controls case conversion in the function CMIME-INTERN-KEYWORD.") (defun cmime-intern-keyword (byte-buffer &key (start 0) end (case *cmime-intern-keyword-case*)) (intern (coerce (loop for i from start below (or end (length byte-buffer)) for c = (aref byte-buffer i) for ch = (code-char c) for uch = (ecase case ; TODO INVERT ETC (:upcase (char-upcase ch)) (:preserve ch)) collect uch) 'string) "CMIME-KEYWORDS")) ;; XXX This loses with octet buffers, forcing a roundtrip to ;; characterland. (defmacro with-cmime-tokenizer ((byte-buffer &key (start 0) end specials (block-named (gensym))) &body BODY) "Uses the rfc822 tokenizer. Evaluates BODY in a named block in an environment where the following functions are available via labels: MATCH-STRING, MATCH-ATOM, MATCH-SPECIAL. These functions call the rfc822 tokenizer to attempt a match. MATCH-STRING returns the next quoted string. MATCH-ATOM returns an interned symbol. At present MATCH-STRING and MATCH-ATOM do not take arguments. MATCH-SPECIAL takes a single octet argument and returns it if matched. If any of these functions fail to match, they return nil. Also available is MATCH-ENDP, which does not call the tokenizer, but can be used to check if we are at the end of the string. Also available is MATCH-NEXT which calls the rfc822 tokenizer and returns the next token; as a string (if the next token is of type :quoted-string) or an interned symbol (if :atom) or an octet (if :special)." `(let ((.pos. ,start) (.array. (make-array 0 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)) .type. .start2. .end2.) (block ,block-named (labels ((.collect-byte. (byte) (vector-push-extend byte .array.)) (.next-token. () (multiple-value-setq (.type. .start2. .end2.) (next-rfc822-token ,byte-buffer :start .pos. :end ,end :specials ,specials :collect-fn #'.collect-byte.)) (setq .pos. .end2.)) (match-string (&optional TODO) (declare (ignore TODO)) (.next-token.) (if (eq .type. :quoted-string) (prog1 (map 'string 'code-char .array.) (setf (fill-pointer .array.) 0)))) (match-atom (&optional TODO) (declare (ignore TODO)) (.next-token.) (if (eq .type. :atom) (CMIME-INTERN-KEYWORD ,byte-buffer :start .start2. :end .end2.))) (match-special (code) (.next-token.) (if (and (eq .type. :special) (= code (aref ,byte-buffer .start2.))) code)) (match-next () (.next-token.) (ecase .type. (:quoted-string (prog1 (map 'string 'code-char .array.) (setf (fill-pointer .array.) 0))) (:atom (CMIME-INTERN-KEYWORD ,byte-buffer :start .start2. :end .end2.)) (:special (aref ,byte-buffer .start2.)))) (match-endp () (eq .type. :eos))) ,@body)))) ;;; ;;; (defun cmime-parse-content-type (byte-buffer &key (start 0) end) (with-cmime-tokenizer (byte-buffer :start start :end end :specials (list Equal Slash Semicolon)) (let ((major (match-atom)) (special (match-special Slash)) (minor (match-atom))) (assert (= special Slash)) (list* (cons major minor) (loop while (match-special Semicolon) finally (assert (match-endp)) collect (let* ((key (match-atom)) (special (match-special Equal)) (val (case key ;madhu 070314 ugh applemail ((CMIME-KEYWORDS::BOUNDARY CMIME-KEYWORDS::FILENAME CMIME-KEYWORDS::NAME) (let ((*cmime-intern-keyword-case* :PRESERVE)) (match-next))) (t (match-next))))) (assert (symbolp key)) (assert (= special Equal)) (cons key val))))))) (defun cmime-parse-content-transfer-encoding (byte-buffer &key (start 0) end) (with-cmime-tokenizer (byte-buffer :start start :end end) (let ((ret (match-atom))) (prog1 ret (assert ret) (assert (symbolp ret)))))) (defun cmime-parse-content-disposition (byte-buffer &key (start 0) end) (with-cmime-tokenizer (byte-buffer :start start :end end :specials (list Equal Semicolon)) (let ((disposition (match-atom))) (assert disposition) (list* disposition (loop while (match-special Semicolon) finally (assert (match-endp)) collect (let* ((key (match-atom)) (special (match-special Equal)) (val (case key ;madhu 070314 ugh applemail ((CMIME-KEYWORDS::FILENAME CMIME-KEYWORDS::NAME) (let ((*cmime-intern-keyword-case* :PRESERVE)) (match-next))) (t (match-next))))) (assert key) (assert (= special Equal)) (cons key val))))))) #|| (cmime-parse-content-type (make-octet-vector "multipart/alternative; boundary=\"--77122590416565430\"")) (cmime-parse-content-type (make-octet-vector "text/plain")) (cmime-parse-content-type (make-octet-vector " application/octet-stream; name=\"726a.jpg\"")) (cmime-parse-content-transfer-encoding (make-octet-vector " base64 ")) (cmime-parse-content-transfer-encoding (make-octet-vector "quoted-printable")) (cmime-parse-content-disposition (make-octet-vector " attachment; filename=\"pos1in3v5.pdf\"")) (cmime-parse-content-disposition (make-octet-vector " attachment; foobar=car")) ||# ;;; --------------------------------------------------------------------------- ;;; ;;; (defvar *cmime-header-parsers* '(("Content-Disposition" . cmime-parse-content-disposition) ("Content-Type" . cmime-parse-content-type) ("Content-Description") ("Content-ID") ("Content-Transfer-Encoding" . cmime-parse-content-transfer-encoding) ("Mime-Version"))) ;; XXX This loses with octet buffers, forcing a roundtrip to ;; characterland. ;;; ;;; (defun cmime-parse-headers (byte-buffer &key (start 0) end headers) "Returns HEADERS, an alist. Expect START to be at start of headers. Second return value is position of end of headers." (multiple-value-bind (ret eohpos) (with-string-headers-do (byte-buffer :start start :end end) (key val) (let ((cons (assoc key *cmime-header-parsers* :test #'string-equal))) (when cons (let* ((header-key (intern (string-upcase key) "CMIME-HEADERS")) (parser (cdr cons)) (header-val (cond (parser ;XXX (funcall parser (MAKE-OCTET-VECTOR val))) (t (copy-seq val))))) (let ((old-cons (assoc header-key headers))) (cond (old-cons (warn "REPLACING OLD VALUE: ~A: ~A" header-key (cdr old-cons)) (setf (cdr old-cons) header-val)) (t (push (cons header-key header-val) headers)))))))) (when (eq ret :eoh) (values headers eohpos)))) #|| (defvar $headers) (defvar $eoh) (multiple-value-setq ($headers $eoh) (cmime-parse-headers $nn-buf :start 57)) ||# (defun cmime-extract-boundary (headers) "Returns an octet vector which can be used to match boundaries. HEADERS is an alist of headers returned by CMIME-PARSE-HEADERS." (when headers (let ((content-type (cdr (assoc "Content-Type" headers :key #'symbol-name :test #'string-equal)))) (when content-type (let ((boundary-string (cdr (assoc "Boundary" content-type :key #'symbol-name :test #'string-equal)))) (when boundary-string (etypecase boundary-string (string (let ((boundary (concatenate 'string "--" boundary-string))) (make-octet-vector boundary)))))))))) #|| (setq $b (cmime-extract-boundary $headers)) ||# ;;; --------------------------------------------------------------------------- ;;; ;;; (defun non-existant-file-writeable-p (pathname) (with-open-file (stream pathname :if-exists :error :if-does-not-exist :create :direction :output :element-type 'character) (write-char #\Newline stream) (delete-file stream))) (defun ensure-file-does-not-exist (pathname) (loop (if (probe-file pathname) (restart-case (error "~S exists." pathname) (delete-it () :report (lambda (stream) (format stream "Delete file ~S" pathname)) (cond ((delete-file pathname) (warn "Deleted ~S" pathname)) (t (warn "Delete failed: ~S" pathname))))) (return T)))) (defun get-valid-pathname (&optional default) "Query user for a writeable pathname -- ensuring that the given pathname does not exist but can be created." (prog (pathname string) loop (finish-output *query-io*) (clear-input *query-io*) (format *query-io* "Enter a pathname designator~@[ [~A]~]: " default) (setq string (read-line *query-io*)) (setq pathname (if (string-equal string "") (if default (prog1 (pathname default) (setq default nil)) (go loop)) (pathname string))) (restart-case (cond ((and (ensure-file-does-not-exist pathname) (non-existant-file-writeable-p pathname) (return pathname))) ((go loop))) (retry () :report (lambda (stream) (format stream "Try entering a different pathname.")) (go loop))))) ;;; ---------------------------------------------------------------------- ;;; ;;; (defun cmime-save-part-handler (headers byte-buffer start end partno) "Called by CMIME-SAVE-PARTS on each part." (format *query-io* "Found part ~D (length ~D): Headers:~&~S~&" partno (- end start) headers) (let ((enctype (cdr (assoc 'CMIME-HEADERS::CONTENT-TRANSFER-ENCODING headers)))) (when (case enctype ((CMIME-KEYWORDS::BASE64 CMIME-KEYWORDS::QUOTED-PRINTABLE) t)) (finish-output *query-io*) (clear-input *query-io*) (when (y-or-n-p "Save it? ") (with-open-file (stream (GET-VALID-PATHNAME) :direction :output :element-type '(unsigned-byte 8)) (ecase enctype (CMIME-KEYWORDS::BASE64 (mime-decode-base64 byte-buffer :start start :end end :stream stream)) (CMIME-KEYWORDS::QUOTED-PRINTABLE (mime-decode-quoted-printable byte-buffer :start start :end end :stream stream)))))))) (defun CMIME-SAVE-PARTS (byte-buffer &key (start 0) end boundary (save-part-handler #'cmime-save-part-handler)) "Expect start to be at begining of the message body. BOUNDARY is an sequence of octets. Find mime parts in byte-buffer delimited by BOUNDARY and call SAVE-PARTS-HANDLER with 5 arguments: the parsed headers, the byte-buffer, position of the start of data, position of the end of data, and an integer part number. Returns the last position of byte-buffer read." (loop with next-boundary-start for part from 1 for boundary-start = (search boundary byte-buffer :start2 start :end2 end) then next-boundary-start unless boundary-start return start do (multiple-value-bind (boundary-end headers-start) (get-end-of-line byte-buffer :start boundary-start) (declare (ignore boundary-end)) (unless (setq next-boundary-start (search boundary byte-buffer :start2 headers-start)) (return headers-start)) (multiple-value-bind (headers end-of-headers) (cmime-parse-headers byte-buffer :start headers-start :end next-boundary-start) (funcall SAVE-PART-HANDLER headers byte-buffer end-of-headers next-boundary-start part))))) #|| (cmime-save-parts $nn-buf :start 57 :boundary $b :save-part-handler (lambda (headers byte-buffer start end partno) (warn "FOUND PART ~D between ~D and ~D (length ~D): ~ HEADERS:~&~S~&" partno start end (- end start) headers))) ||# ;; ;; support the older api ;; (defmacro ensure-byte-vector (array-var &key (start 0) end) `(etypecase (elt ,array-var 0) (character (setq ,array-var (make-octet-vector ,array-var :start ,start :end ,end))) ((unsigned-byte 8)))) (defun save-parts (buffer &key (start 0) end content-type) (ensure-byte-vector buffer :start start :end end) (ensure-byte-vector content-type) (let ((parsed-content-type (cmime-parse-content-type content-type))) (when parsed-content-type (let* ((bcons (assoc 'CMIME-KEYWORDS::BOUNDARY parsed-content-type)) (parsed-boundary (cdr bcons)) (boundary (etypecase parsed-boundary ;madhu 070314 ugh (null nil) ;; TODO HANDLE OCTET VECTOR HERE (symbol (concatenate 'string "--" (symbol-name parsed-boundary))) (string (concatenate 'string "--" parsed-boundary))))) (when boundary (ensure-byte-vector boundary) (cmime-save-parts buffer :start start :end end :boundary boundary)))))) (defun parse-message-id (byte-buffer &key (start 0) end) ;; (map 'vector #'char-code "<>") => 60 62 (ensure-byte-vector byte-buffer :start start :end end) (with-cmime-tokenizer (byte-buffer :start 0 :end end :specials #(60 62)) (assert (= (match-special 60) 60)) (let ((ret (match-atom))) (assert (= (match-special 62) 62)) ret))) #|| (parse-message-id (make-octet-vector " ")) ||#