mime-api.cl

#+(version= 8 1)
(sys:defpatch "mime" 4
  "v1: changes to internal/undocumented portions of module;
v2: better parse-mime-structure behavior in the face of malformatted headers;
v3: Improved performance when converting charset to external-format;
v4: decode-header-text: handle underscore & remove soft newlines."
  :type :system
  :post-loadable t)

#+(version= 8 0)
(sys:defpatch "mime" 3
  "v0: New module.  See documentation.;
v1: Improve default transfer encoding determination;
v2: make-mime-part: Default external-format is :utf8;
v3: add mime structure parsing support."
  :type :system
  :post-loadable t)

;; -*- mode: common-lisp; package: net.post-office -*-
;;
;; imap.cl
;; imap and pop interface
;;
;; See the file LICENSE for the full license governing this code.
;;

(defpackage :net.post-office
  (:use #:lisp #:excl)
  (:export
   ;; functions/methods
   #:make-mime-part
   #:mime-part-writer
   #:mime-part-p
   #:mime-part-constructed-p
   #:map-over-parts
   #:decode-header-text
   
   ;; macros
   #:mime-get-header
   #:with-mime-part-constructed-stream

   ;; classes
   #:mime-part-constructed
   
   ;; slot accessors
   #:mime-part-type
   #:mime-part-subtype
   #:mime-part-parameters
   #:mime-part-id
   #:mime-part-description
   #:mime-part-encoding
   #:mime-part-headers
   #:mime-part-parts
   #:mime-part-boundary))

(provide :mime)

(in-package :net.post-office)

(eval-when (compile load eval)
  (require :osi)
  (require :regexp2))

(defclass mime-part ()
  (
   (type :accessor mime-part-type :initform nil)
   (subtype :accessor mime-part-subtype :initform nil)
   (parameters :accessor mime-part-parameters :initform nil) ;; alist
   (id :accessor mime-part-id :initform nil)
   (description :accessor mime-part-description :initform nil)
   (encoding :accessor mime-part-encoding :initform nil)
   (headers ;; parsed headers alist
    :accessor mime-part-headers :initform nil)
   (parts ;; list of subparts (for multipart types)
    :accessor mime-part-parts :initform nil)
   (boundary :accessor mime-part-boundary :initform nil)))

(defclass mime-part-constructed (mime-part)
  (
   (source-type :accessor source-type)
   (source :accessor source)
   (disposition :accessor disposition :initform nil)
   (disposition-name :accessor disposition-name :initform nil)))

(defmacro mime-get-header (header part)
  `(cdr (assoc ,header (mime-part-headers ,part) :test #'equalp)))

(defun message-rfc822-p (type subtype)
  (and (equalp type "message") (equalp subtype "rfc822")))

(defun multipart-p (part)
  (equalp (mime-part-type part) "multipart"))

(defun multipart-mixed-p (part)
  (and (equalp (mime-part-type part) "multipart")
       (equalp (mime-part-subtype part) "mixed")))

(defun mime-part-p (thing)
  (typep thing 'mime-part))

(defun mime-part-constructed-p (thing)
  (typep thing 'mime-part-constructed))

(defun generate-boundary ()
  (declare (optimize (speed 3)))
  (let ((hex "01234567890abcdef"))
    (with-output-to-string (s)
      (write-string "----------_" s)
      (dotimes (n 32)
	(write-char (schar hex (random 16)) s)))))

(defun make-mime-part (&key content-type encoding headers 
			    (attachmentp nil attachmentp-supplied)
			    name text (start 0) end file
			    subparts (external-format :utf8)
			    parameters charset id description)
  (let ((part (make-instance 'mime-part-constructed))
	type subtype multipart textp filepath orig-text)
    
    (if* (and text file)
       then (error "Only one of :text or :file may be specified"))
    
    (if* (and text (null end))
       then (setf end (length text)))

    (when file
      (if* (streamp file)
	 then (setf filepath (ignore-errors (namestring file)))
	 else (setf filepath file)))

    ;; Select default content-type
    (when (null content-type)
      (if* filepath
	 then (setf content-type (lookup-mime-type filepath)))
      
      (when (null content-type)
	(setf content-type
	  (if* subparts 
	     then "multipart/mixed"
	   elseif file
	     then "application/octet-stream"
	   elseif (and text (stringp text))
	     then "text/plain"
	     else "application/octet-stream"))))
      
    (let ((pos (position #\/ content-type)))
      (if (null pos)
	  (error "Invalid content-type: ~s" content-type))
      
      (setf type (subseq content-type 0 pos))
      (setf subtype (subseq content-type (1+ pos))))
    
    (setf multipart (equalp type "multipart"))
    (setf textp (or (equalp type "text") (message-rfc822-p type subtype)))

    (if* (and subparts (not multipart))
       then (error "subparts may not be specified for non-multipart parts"))
    
    (if* (and (not multipart) (null text) (null file))
       then (error "One of :text or :file must be specified"))

    
    ;; Select default charset
    (if* (and (null charset) textp)
       then (setf charset 
	      (or 
	       (guess-charset-from-ef (find-external-format external-format))
	       "us-ascii")))

    ;; For :text, break down to the final usb8.
    (when text
      (setf orig-text text)
      (setf text (if* (stringp text)
		    then (string-to-octets text :null-terminate nil
					   :external-format external-format
					   :start start
					   :end end)
		    else (subseq text start end))))
    
    ;; Select default encoding, which is always base64 except for
    ;; when :text was supplied as a string, in which case we scan to
    ;; choose between 7bit and base64.
    (when (and (not multipart) (null encoding))
      (setf encoding
	(if* (and (stringp orig-text) (not (8-bit-array-p text)))
	   then "7bit"
	   else "base64")))
  
    (setf (mime-part-type part) type)
    (setf (mime-part-subtype part) subtype)
    (setf (mime-part-parameters part) parameters)
    (if* charset
       then (push (cons "charset" charset) (mime-part-parameters part)))
    (setf (mime-part-encoding part) encoding)
    (setf (mime-part-id part) id)
    (setf (mime-part-description part) description)
    (setf (mime-part-headers part) headers)
    
    (if* file
       then (setf (source part) file)
	    (if* (streamp file)
	       then (setf (source-type part) :stream)
	       else (with-open-file (f file)) ;; make sure we can read it.
		    (setf (source-type part) :file))
	    (if* (not attachmentp-supplied)
	       then (setf attachmentp t))
       else (setf (source-type part) :usb8)
	    (setf (source part) text))

    (if* (and (not textp) (not attachmentp) (not multipart))
       then (setf (disposition part) "inline"))

    (when attachmentp
      (setf (disposition part) "attachment")
      (if* (and (null name) file)
	 then (setf name (excl.osi:basename filepath))))

    (if* name
       then (setf (disposition-name part) name))
  
    (if* multipart
       then (let ((boundary (generate-boundary)))
	      (setf (mime-part-boundary part) boundary)
	      (push (cons "boundary" boundary) 
		    (mime-part-parameters part))))
    
    (setf (mime-part-parts part) subparts)
    
    part))

(defun 8-bit-array-p (usb8)
  (declare (optimize (speed 3) (safety 0))
	   ((simple-array (unsigned-byte 8) (*)) usb8))
  (dotimes (n (length usb8))
    (declare (fixnum n))
    (if (> (aref usb8 n) 127)
	(return t))))

(defparameter *ef-nick-to-mime-charset*
    '((:ascii . "us-ascii")
      (:iso-2022-jp . "iso-2022-jp")
      (:koi8-r . "koi8-r")
      (:shiftjis . "shift_jis")
      (:euc . "euc-jp")
      (:gb2312 . "gb2312")
      (:big5 . "big5")
      (:utf8 . "utf-8")))
      
(defun guess-charset-from-ef (ef)
  (dolist (nick (ef-nicknames (find-external-format ef)))
    (let ((charset (cdr (assoc nick *ef-nick-to-mime-charset*))))
      (if charset (return-from guess-charset-from-ef charset))))
  (let ((ef-name (string-downcase (symbol-name (ef-name (crlf-base-ef ef))))))
    ;; Try iso-8559-x names.
    (multiple-value-bind (found ignore suffix)
	(match-re "^iso8859-(\\d+)-base" ef-name)
      (declare (ignore ignore))
      (if found
	  (return-from guess-charset-from-ef 
	    (format nil "iso-8859-~a" suffix))))
    
    ;; Try windows- names.
    (multiple-value-bind (found whole value)
	(match-re "^(\\d+)-base$" ef-name)
      (declare (ignore whole))
      (if found
	  (return-from guess-charset-from-ef
	    (format nil "windows-~a" value))))))

(defmethod mime-part-writer ((part mime-part-constructed) 
			     &key (stream *terminal-io*))
  (mime-part-constructed-writer part stream t))

(defun mime-part-constructed-writer (part stream top-level)
  (if* top-level
     then (format stream "MIME-Version: 1.0~%"))
  
  ;; First dump user-supplied headers.
  (dolist (h (mime-part-headers part))
    (format stream "~a: ~a~%" (car h) (cdr h)))

  ;; Now dump headers that are based on class fields.

  (let* ((type (mime-part-type part))
	 (multipart (equalp type "multipart")))
    (format stream "Content-Type: ~a/~a" type (mime-part-subtype part))
    (dolist (param (mime-part-parameters part))
      (format stream ";~%    ~a=~s" (car param) (cdr param)))
    (format stream "~%")
    
    (if* (mime-part-encoding part)
       then (format stream "Content-Transfer-Encoding: ~a~%" 
		    (mime-part-encoding part)))
  
    (if* (mime-part-id part)
       then (format stream "Content-Id: ~a~%" (mime-part-id part)))
  
    (if* (mime-part-description part)
       then (format stream "Content-Description: ~a~%" 
		    (mime-part-description part)))
  
  
    (if* (disposition part)
       then (format stream "Content-Disposition: ~a" (disposition part))
	    (if* (disposition-name part)
	       then (format stream ";~%    filename=~s" (disposition-name part)))
	    (format stream "~%"))
  
    (format stream "~%") ;; terminate headers
  
    (if* multipart 
       then (let ((boundary (mime-part-boundary part)))
	      (if top-level
		  (format stream "~
This is a multi-part message in MIME format.~%"))
	      (dolist (subpart (mime-part-parts part))
		(format stream "~%--~a~%" boundary)
		(mime-part-constructed-writer subpart stream nil))
	      (format stream "~%--~a--~%" boundary))
       else (let ((instream (if* (eq (source-type part) :stream)
			       then (source part)
			     elseif (eq (source-type part) :file)
			       then (open (source part))
			       else (make-buffer-input-stream (source part)))))
	      (unwind-protect
		  (let ((encoding (mime-part-encoding part)))
		    (if* (equalp encoding "base64")
		       then (excl::base64-encode-stream instream stream)
		     elseif (equalp encoding "quoted-printable")
		       then (qp-encode-stream instream stream)
		       else (raw-encode-stream instream stream)))
		    ;; cleanup
		(if* (not (eq (source-type part) :stream))
		   then (close instream)))))))

(defun mime-part-writer-1 (stream part)
  (mime-part-writer part :stream stream))

(defmacro with-mime-part-constructed-stream ((stream part) &body body)
  `(excl::with-function-input-stream (,stream #'mime-part-writer-1 ,part)
     ,@body))


;; misc

(defun map-over-parts (part function)
  (funcall function part)
  (if* (multipart-p part)
     then (dolist (p (mime-part-parts part))
	    (map-over-parts p function))
   elseif (message-rfc822-p (mime-part-type part) (mime-part-subtype part))
     then (map-over-parts (mime-part-message part) function)))

;;

(defparameter *default-charset-to-ef* 
    '(("us-ascii" . :latin1)
      ("ansi_x3.4-1968" . :latin1)
      ("shift-jis" . :shiftjis)
      ("gbk" . :936)
      #+ignore("euc-kr" :iso-2022-kr)))

(defparameter *charset-to-ef* nil)

(defparameter *charset-to-ef-lock* (mp:make-process-lock))

(defparameter *debug-charset-to-ef* nil)

(defun init-charset-to-ef ()
  (let ((ht (make-hash-table :test #'equal)))
    (dolist (pair *default-charset-to-ef*)
      (setf (gethash (car pair) ht) (find-external-format (cdr pair) :errorp nil)))
    (setf *charset-to-ef* ht)))

(defun charset-to-external-format (charset)
  (setf charset (string-downcase charset))
  (mp:with-process-lock (*charset-to-ef-lock*)
    (if (null *charset-to-ef*)
	(init-charset-to-ef))

    (macrolet ((save-and-return (ef)
		 (let ((ef-x (gensym)))
		   `(let ((,ef-x ,ef))
		      (progn (setf (gethash charset *charset-to-ef*) ,ef-x)
			     (return-from charset-to-external-format ,ef-x))))))
      
      (let ((ef (gethash charset *charset-to-ef*)))
	(if ef 
	    (return-from charset-to-external-format ef)) ;; Use cached result
	
	(if (setf ef (find-external-format charset :errorp nil))
	    (save-and-return ef))
	
	(multiple-value-bind (matched x inner)
	    (match-re "^windows-(\\d+)$" charset)
	  (declare (ignore x))
	  (if (and matched (setf ef (find-external-format inner :errorp nil)))
	      (save-and-return ef)))

	(multiple-value-bind (matched x dig)
	    (match-re "^iso-8859-(\\d+)(?:-[ie])?$" charset)
	  (declare (ignore x))
	  (if (and matched (setf ef (find-external-format (format nil "iso8859-~a" dig) :errorp nil)))
	      (save-and-return ef)))

	(if *debug-charset-to-ef*
	    (format t "no external found for ~a~%" charset))
	
	;; No luck
	nil))))

(defun decode-header-text (text)
  (declare (optimize (speed 3))
	   (string text))
  (when (null text) (error "first argument expected to be non-nil."))
  (let ((pos 0)
	(len (length text))
	last-tail)
    (declare (fixnum pos len))
    (with-output-to-string (res)
      (while (< pos len)
	(multiple-value-bind (matched whole charset encoding encoded tail)
	    (match-re "=\\?([^?]+)\\?(q|b)\\?(.*?)\\?=(\\s+)?" text 
		      :start pos
		      :case-fold t
		      :return :index)
	  
	  (when (null matched)
	    (when last-tail
	      (write-string text res
			    :start (car last-tail) :end (cdr last-tail)))
	    (return))
	  
	  ;; Write out the "before" stuff.
	  (write-string text res :start pos :end (car whole))
	  
	  (let* ((charset (subseq text (car charset) (cdr charset)))
		 (ef (charset-to-external-format charset)))
	    (if (null ef)
		(error "No external format found for MIME charset ~s" charset))
	    (write-string 
	     (if* (char-equal (char text (car encoding)) #\q)
		then (qp-decode-string text
				       :start (car encoded)
				       :end (cdr encoded)
				       :external-format ef
				       :underscores-are-spaces t)
		else ;; FIXME: Clean this up with/if rfe6174 is completed.
		     (octets-to-string
		      (base64-string-to-usb8-array 
		       (subseq text (car encoded) (cdr encoded)))
		      :external-format ef))
	     res))
	  
	  (setf pos (cdr whole))
	  (setf last-tail tail)))
	  
      ;; Write out the remaining portion.
      (write-string text res :start pos))))


;; Stuff ripped off from aserve

(defun split-namestring (file)
  ;; split the namestring into root and tail and then the tail
  ;; into name and type
  ;; 
  ;; any of the return value can be nil if the corresponding item
  ;; isn't present.
  ;;
  ;; rules for splitting the tail into name and type components:
  ;;  if the last period in the tail is at the beginning or end of the
  ;;  tail, then the name is exactly the tail and type is nil.
  ;;  Thus .foo and bar.  are just names, no type
  ;;  but .foo.c  has a name of ".foo" and a type of "c"
  ;;  Thus if there is a non-nil type then it means that 
  ;;    1. there will be a non nil name as well
  ;;    2. to reconstruct the filename you need to add a period between
  ;;       the name and type.
  ;;
  (let ((pos (min (or (or (position #\/ file :from-end t) most-positive-fixnum)
		      #+mswindows (position #\\ file :from-end t))))
	root
	tail)
    
    (if* (equal file "") then (return-from split-namestring nil))
    
    (if* (and pos (< pos most-positive-fixnum))
       then ; we have root and tail
	    (if* (eql pos (1- (length file)))
	       then ; just have root
		    (return-from split-namestring
		      (values file nil nil nil)))
	    
    
	    (setq root (subseq file 0 (1+ pos))
		  tail (subseq file (1+ pos)))
       else (setq tail file))
    
    
    ; split the tail
    (let ((pos (position #\. tail :from-end t)))
      (if* (or (null pos)
	       (zerop pos)
	       (equal pos (1- (length tail))))
	 then ; name begins or ends with . so it's not
	      ; a type separator
	      (values root tail tail nil)
	 else ; have all pieces
	      (values root tail
		      (subseq tail 0 pos)
		      (subseq tail (1+ pos)))))))


; we can specify either an exact url or one that handles all
; urls with a common prefix.
;;
;; if the prefix is given as a list: e.g. ("ReadMe") then it says that
;; this mime type applie to file named ReadMe.  Note that file types
;; are checked first and if no match then a filename match is done.
;
(defparameter *file-type-to-mime-type*
    ;; this list constructed by generate-mime-table in parse.cl
    '(("application/EDI-Consent") ("application/EDI-X12") ("application/EDIFACT")
      ("application/activemessage") ("application/andrew-inset" "ez")
      ("application/applefile") ("application/atomicmail")
      ("application/batch-SMTP") ("application/beep+xml") ("application/cals-1840")
      ("application/commonground") ("application/cybercash")
      ("application/dca-rft") ("application/dec-dx") ("application/dvcs")
      ("application/eshop") ("application/http") ("application/hyperstudio")
      ("application/iges") ("application/index") ("application/index.cmd")
      ("application/index.obj") ("application/index.response")
      ("application/index.vnd") ("application/iotp") ("application/ipp")
      ("application/isup") ("application/font-tdpfr")
      ("application/mac-binhex40" "hqx") ("application/mac-compactpro" "cpt")
      ("application/macwriteii") ("application/marc") ("application/mathematica")
      ("application/mathematica-old") ("application/msword" "doc")
      ("application/news-message-id") ("application/news-transmission")
      ("application/ocsp-request") ("application/ocsp-response")
      ("application/octet-stream" "bin" "dms" "lha" "lzh" "exe" "class" "so" "dll"
       "img" "iso")
      ("application/ogg" "ogg") ("application/parityfec") ("application/pdf" "pdf")
      ("application/pgp-encrypted") ("application/pgp-keys")
      ("application/pgp-signature") ("application/pkcs10")
      ("application/pkcs7-mime") ("application/pkcs7-signature")
      ("application/pkix-cert") ("application/pkix-crl") ("application/pkixcmp")
      ("application/postscript" "ai" "eps" "ps")
      ("application/prs.alvestrand.titrax-sheet") ("application/prs.cww")
      ("application/prs.nprend") ("application/qsig")
      ("application/remote-printing") ("application/riscos")
      ("application/rtf" "rtf") ("application/sdp") ("application/set-payment")
      ("application/set-payment-initiation") ("application/set-registration")
      ("application/set-registration-initiation") ("application/sgml")
      ("application/sgml-open-catalog") ("application/sieve") ("application/slate")
      ("application/smil" "smi" "smil") ("application/timestamp-query")
      ("application/timestamp-reply") ("application/vemmi")
      ("application/vnd.3M.Post-it-Notes") ("application/vnd.FloGraphIt")
      ("application/vnd.accpac.simply.aso") ("application/vnd.accpac.simply.imp")
      ("application/vnd.acucobol") ("application/vnd.aether.imp")
      ("application/vnd.anser-web-certificate-issue-initiation")
      ("application/vnd.anser-web-funds-transfer-initiation")
      ("application/vnd.audiograph") ("application/vnd.businessobjects")
      ("application/vnd.bmi") ("application/vnd.canon-cpdl")
      ("application/vnd.canon-lips") ("application/vnd.claymore")
      ("application/vnd.commerce-battelle") ("application/vnd.commonspace")
      ("application/vnd.comsocaller") ("application/vnd.contact.cmsg")
      ("application/vnd.cosmocaller") ("application/vnd.cups-postscript")
      ("application/vnd.cups-raster") ("application/vnd.cups-raw")
      ("application/vnd.ctc-posml") ("application/vnd.cybank")
      ("application/vnd.dna") ("application/vnd.dpgraph") ("application/vnd.dxr")
      ("application/vnd.ecdis-update") ("application/vnd.ecowin.chart")
      ("application/vnd.ecowin.filerequest") ("application/vnd.ecowin.fileupdate")
      ("application/vnd.ecowin.series") ("application/vnd.ecowin.seriesrequest")
      ("application/vnd.ecowin.seriesupdate") ("application/vnd.enliven")
      ("application/vnd.epson.esf") ("application/vnd.epson.msf")
      ("application/vnd.epson.quickanime") ("application/vnd.epson.salt")
      ("application/vnd.epson.ssf") ("application/vnd.ericsson.quickcall")
      ("application/vnd.eudora.data") ("application/vnd.fdf")
      ("application/vnd.ffsns") ("application/vnd.framemaker")
      ("application/vnd.fsc.weblaunch") ("application/vnd.fujitsu.oasys")
      ("application/vnd.fujitsu.oasys2") ("application/vnd.fujitsu.oasys3")
      ("application/vnd.fujitsu.oasysgp") ("application/vnd.fujitsu.oasysprs")
      ("application/vnd.fujixerox.ddd") ("application/vnd.fujixerox.docuworks")
      ("application/vnd.fujixerox.docuworks.binder") ("application/vnd.fut-misnet")
      ("application/vnd.grafeq") ("application/vnd.groove-account")
      ("application/vnd.groove-identity-message")
      ("application/vnd.groove-injector") ("application/vnd.groove-tool-message")
      ("application/vnd.groove-tool-template") ("application/vnd.groove-vcard")
      ("application/vnd.hhe.lesson-player") ("application/vnd.hp-HPGL")
      ("application/vnd.hp-PCL") ("application/vnd.hp-PCLXL")
      ("application/vnd.hp-hpid") ("application/vnd.hp-hps")
      ("application/vnd.httphone") ("application/vnd.hzn-3d-crossword")
      ("application/vnd.ibm.afplinedata") ("application/vnd.ibm.MiniPay")
      ("application/vnd.ibm.modcap") ("application/vnd.informix-visionary")
      ("application/vnd.intercon.formnet") ("application/vnd.intertrust.digibox")
      ("application/vnd.intertrust.nncp") ("application/vnd.intu.qbo")
      ("application/vnd.intu.qfx") ("application/vnd.irepository.package+xml")
      ("application/vnd.is-xpr") ("application/vnd.japannet-directory-service")
      ("application/vnd.japannet-jpnstore-wakeup")
      ("application/vnd.japannet-payment-wakeup")
      ("application/vnd.japannet-registration")
      ("application/vnd.japannet-registration-wakeup")
      ("application/vnd.japannet-setstore-wakeup")
      ("application/vnd.japannet-verification")
      ("application/vnd.japannet-verification-wakeup") ("application/vnd.koan")
      ("application/vnd.lotus-1-2-3") ("application/vnd.lotus-approach")
      ("application/vnd.lotus-freelance") ("application/vnd.lotus-notes")
      ("application/vnd.lotus-organizer") ("application/vnd.lotus-screencam")
      ("application/vnd.lotus-wordpro") ("application/vnd.mcd")
      ("application/vnd.mediastation.cdkey") ("application/vnd.meridian-slingshot")
      ("application/vnd.mif" "mif") ("application/vnd.minisoft-hp3000-save")
      ("application/vnd.mitsubishi.misty-guard.trustweb")
      ("application/vnd.mobius.daf") ("application/vnd.mobius.dis")
      ("application/vnd.mobius.msl") ("application/vnd.mobius.plc")
      ("application/vnd.mobius.txf") ("application/vnd.motorola.flexsuite")
      ("application/vnd.motorola.flexsuite.adsi")
      ("application/vnd.motorola.flexsuite.fis")
      ("application/vnd.motorola.flexsuite.gotap")
      ("application/vnd.motorola.flexsuite.kmr")
      ("application/vnd.motorola.flexsuite.ttc")
      ("application/vnd.motorola.flexsuite.wem")
      ("application/vnd.mozilla.xul+xml") ("application/vnd.ms-artgalry")
      ("application/vnd.ms-asf") ("application/vnd.ms-excel" "xls")
      ("application/vnd.ms-lrm") ("application/vnd.ms-powerpoint" "ppt")
      ("application/vnd.ms-project") ("application/vnd.ms-tnef")
      ("application/vnd.ms-works") ("application/vnd.mseq")
      ("application/vnd.msign") ("application/vnd.music-niff")
      ("application/vnd.musician") ("application/vnd.netfpx")
      ("application/vnd.noblenet-directory") ("application/vnd.noblenet-sealer")
      ("application/vnd.noblenet-web") ("application/vnd.novadigm.EDM")
      ("application/vnd.novadigm.EDX") ("application/vnd.novadigm.EXT")
      ("application/vnd.osa.netdeploy") ("application/vnd.palm")
      ("application/vnd.pg.format") ("application/vnd.pg.osasli")
      ("application/vnd.powerbuilder6") ("application/vnd.powerbuilder6-s")
      ("application/vnd.powerbuilder7") ("application/vnd.powerbuilder7-s")
      ("application/vnd.powerbuilder75") ("application/vnd.powerbuilder75-s")
      ("application/vnd.previewsystems.box")
      ("application/vnd.publishare-delta-tree") ("application/vnd.pvi.ptid1")
      ("application/vnd.pwg-xhtml-print+xml") ("application/vnd.rapid")
      ("application/vnd.s3sms") ("application/vnd.seemail")
      ("application/vnd.shana.informed.formdata")
      ("application/vnd.shana.informed.formtemplate")
      ("application/vnd.shana.informed.interchange")
      ("application/vnd.shana.informed.package") ("application/vnd.sss-cod")
      ("application/vnd.sss-dtf") ("application/vnd.sss-ntf")
      ("application/vnd.sun.xml.writer" "sxw")
      ("application/vnd.sun.xml.writer.template" "stw")
      ("application/vnd.sun.xml.calc" "sxc")
      ("application/vnd.sun.xml.calc.template" "stc")
      ("application/vnd.sun.xml.draw" "sxd")
      ("application/vnd.sun.xml.draw.template" "std")
      ("application/vnd.sun.xml.impress" "sxi")
      ("application/vnd.sun.xml.impress.template" "sti")
      ("application/vnd.sun.xml.writer.global" "sxg")
      ("application/vnd.sun.xml.math" "sxm") ("application/vnd.street-stream")
      ("application/vnd.svd") ("application/vnd.swiftview-ics")
      ("application/vnd.triscape.mxs") ("application/vnd.trueapp")
      ("application/vnd.truedoc") ("application/vnd.tve-trigger")
      ("application/vnd.ufdl") ("application/vnd.uplanet.alert")
      ("application/vnd.uplanet.alert-wbxml")
      ("application/vnd.uplanet.bearer-choice-wbxml")
      ("application/vnd.uplanet.bearer-choice") ("application/vnd.uplanet.cacheop")
      ("application/vnd.uplanet.cacheop-wbxml") ("application/vnd.uplanet.channel")
      ("application/vnd.uplanet.channel-wbxml") ("application/vnd.uplanet.list")
      ("application/vnd.uplanet.list-wbxml") ("application/vnd.uplanet.listcmd")
      ("application/vnd.uplanet.listcmd-wbxml") ("application/vnd.uplanet.signal")
      ("application/vnd.vcx") ("application/vnd.vectorworks")
      ("application/vnd.vidsoft.vidconference") ("application/vnd.visio")
      ("application/vnd.vividence.scriptfile") ("application/vnd.wap.sic")
      ("application/vnd.wap.slc") ("application/vnd.wap.wbxml" "wbxml")
      ("application/vnd.wap.wmlc" "wmlc")
      ("application/vnd.wap.wmlscriptc" "wmlsc") ("application/vnd.webturbo")
      ("application/vnd.wrq-hp3000-labelled") ("application/vnd.wt.stf")
      ("application/vnd.xara") ("application/vnd.xfdl")
      ("application/vnd.yellowriver-custom-menu") ("application/whoispp-query")
      ("application/whoispp-response") ("application/wita")
      ("application/wordperfect5.1") ("application/x-bcpio" "bcpio")
      ("application/x-bittorrent" "torrent") ("application/x-bzip2" "bz2")
      ("application/x-cdlink" "vcd") ("application/x-chess-pgn" "pgn")
      ("application/x-compress") ("application/x-cpio" "cpio")
      ("application/x-csh" "csh") ("application/x-director" "dcr" "dir" "dxr")
      ("application/x-dvi" "dvi") ("application/x-futuresplash" "spl")
      ("application/x-gtar" "gtar") ("application/x-gzip" "gz" "tgz")
      ("application/x-hdf" "hdf") ("application/x-javascript" "js")
      ("application/x-kword" "kwd" "kwt") ("application/x-kspread" "ksp")
      ("application/x-kpresenter" "kpr" "kpt") ("application/x-kchart" "chrt")
      ("application/x-killustrator" "kil")
      ("application/x-koan" "skp" "skd" "skt" "skm")
      ("application/x-latex" "latex") ("application/x-netcdf" "nc" "cdf")
      ("application/x-rpm" "rpm") ("application/x-sh" "sh")
      ("application/x-shar" "shar") ("application/x-shockwave-flash" "swf")
      ("application/x-stuffit" "sit") ("application/x-sv4cpio" "sv4cpio")
      ("application/x-sv4crc" "sv4crc") ("application/x-tar" "tar")
      ("application/x-tcl" "tcl") ("application/x-tex" "tex")
      ("application/x-texinfo" "texinfo" "texi")
      ("application/x-troff" "t" "tr" "roff") ("application/x-troff-man" "man")
      ("application/x-troff-me" "me") ("application/x-troff-ms" "ms")
      ("application/x-ustar" "ustar") ("application/x-wais-source" "src")
      ("application/x400-bp") ("application/xhtml+xml" "xhtml" "xht")
      ("application/xml") ("application/xml-dtd")
      ("application/xml-external-parsed-entity") ("application/zip" "zip")
      ("audio/32kadpcm") ("audio/basic" "au" "snd") ("audio/g.722.1") ("audio/l16")
      ("audio/midi" "mid" "midi" "kar") ("audio/mp4a-latm") ("audio/mpa-robust")
      ("audio/mpeg" "mpga" "mp2" "mp3") ("audio/parityfec") ("audio/prs.sid")
      ("audio/telephone-event") ("audio/tone") ("audio/vnd.cisco.nse")
      ("audio/vnd.cns.anp1") ("audio/vnd.cns.inf1") ("audio/vnd.digital-winds")
      ("audio/vnd.everad.plj") ("audio/vnd.lucent.voice") ("audio/vnd.nortel.vbk")
      ("audio/vnd.nuera.ecelp4800") ("audio/vnd.nuera.ecelp7470")
      ("audio/vnd.nuera.ecelp9600") ("audio/vnd.octel.sbc") ("audio/vnd.qcelp")
      ("audio/vnd.rhetorex.32kadpcm") ("audio/vnd.vmx.cvsd")
      ("audio/x-aiff" "aif" "aiff" "aifc") ("audio/x-mpegurl" "m3u")
      ("audio/x-pn-realaudio" "ram" "rm") ("audio/x-realaudio" "ra")
      ("audio/x-wav" "wav") ("chemical/x-pdb" "pdb") ("chemical/x-xyz" "xyz")
      ("image/bmp" "bmp") ("image/cgm") ("image/g3fax") ("image/gif" "gif")
      ("image/ief" "ief") ("image/jpeg" "jpeg" "jpg" "jpe") ("image/naplps")
      ("image/png" "png") ("image/prs.btif") ("image/prs.pti")
      ("image/tiff" "tiff" "tif") ("image/vnd.cns.inf2")
      ("image/vnd.djvu" "djvu" "djv") ("image/vnd.dwg") ("image/vnd.dxf")
      ("image/vnd.fastbidsheet") ("image/vnd.fpx") ("image/vnd.fst")
      ("image/vnd.fujixerox.edmics-mmr") ("image/vnd.fujixerox.edmics-rlc")
      ("image/vnd.mix") ("image/vnd.net-fpx") ("image/vnd.svf")
      ("image/vnd.wap.wbmp" "wbmp") ("image/vnd.xiff") ("image/x-cmu-raster" "ras")
      ("image/x-portable-anymap" "pnm") ("image/x-portable-bitmap" "pbm")
      ("image/x-portable-graymap" "pgm") ("image/x-portable-pixmap" "ppm")
      ("image/x-rgb" "rgb") ("image/x-xbitmap" "xbm") ("image/x-xpixmap" "xpm")
      ("image/x-xwindowdump" "xwd") ("message/delivery-status")
      ("message/disposition-notification") ("message/external-body")
      ("message/http") ("message/news") ("message/partial") ("message/rfc822")
      ("message/s-http") ("model/iges" "igs" "iges")
      ("model/mesh" "msh" "mesh" "silo") ("model/vnd.dwf")
      ("model/vnd.flatland.3dml") ("model/vnd.gdl") ("model/vnd.gs-gdl")
      ("model/vnd.gtw") ("model/vnd.mts") ("model/vnd.vtu")
      ("model/vrml" "wrl" "vrml") ("multipart/alternative")
      ("multipart/appledouble") ("multipart/byteranges") ("multipart/digest")
      ("multipart/encrypted") ("multipart/form-data") ("multipart/header-set")
      ("multipart/mixed") ("multipart/parallel") ("multipart/related")
      ("multipart/report") ("multipart/signed") ("multipart/voice-message")
      ("text/calendar") ("text/css" "css") ("text/directory") ("text/enriched")
      ("text/html" "html" "htm") ("text/parityfec") ("text/plain" "asc" "txt")
      ("text/prs.lines.tag") ("text/rfc822-headers") ("text/richtext" "rtx")
      ("text/rtf" "rtf") ("text/sgml" "sgml" "sgm")
      ("text/tab-separated-values" "tsv") ("text/t140") ("text/uri-list")
      ("text/vnd.DMClientScript") ("text/vnd.IPTC.NITF") ("text/vnd.IPTC.NewsML")
      ("text/vnd.abc") ("text/vnd.curl") ("text/vnd.flatland.3dml")
      ("text/vnd.fly") ("text/vnd.fmi.flexstor") ("text/vnd.in3d.3dml")
      ("text/vnd.in3d.spot") ("text/vnd.latex-z") ("text/vnd.motorola.reflex")
      ("text/vnd.ms-mediapackage") ("text/vnd.wap.si") ("text/vnd.wap.sl")
      ("text/vnd.wap.wml" "wml") ("text/vnd.wap.wmlscript" "wmls")
      ("text/x-setext" "etx") ("text/xml" "xml" "xsl")
      ("text/xml-external-parsed-entity") ("video/mp4v-es")
      ("video/mpeg" "mpeg" "mpg" "mpe") ("video/parityfec") ("video/pointer")
      ("video/quicktime" "qt" "mov") ("video/vnd.fvt") ("video/vnd.motorola.video")
      ("video/vnd.motorola.videop") ("video/vnd.mpegurl" "mxu") ("video/vnd.mts")
      ("video/vnd.nokia.interleaved-multimedia") ("video/vnd.vivo")
      ("video/x-msvideo" "avi") ("video/x-sgi-movie" "movie")
      ("x-conference/x-cooltalk" "ice")))

(defvar *mime-types* nil)

(defun build-mime-types-table ()
  (if* (null *mime-types*)
     then (setf *mime-types* (make-hash-table :test #'equalp))
	  (dolist (ent *file-type-to-mime-type*)
	    (dolist (type (cdr ent))
	      (setf (gethash type *mime-types*) (car ent))))))
  

(build-mime-types-table)  ;; build the table now

;; return mime type if known
(defmethod lookup-mime-type (filename) 
  (if* (pathnamep filename)
     then (setq filename (namestring filename)))
  (multiple-value-bind (root tail name type)
      (split-namestring filename)
    (declare (ignore root name))
    (if* (and type (gethash type *mime-types*))
       thenret
     elseif (gethash (list tail) *mime-types*) 
       thenret)))