;; -*- mode: common-lisp; package: net.post-office -*-
 ;;

 ;; See the file LICENSE for the full license governing this code.

 ;;

 
 (defpackage :net.post-office
   (:use #:lisp #:excl)

   (:import-from #:excl #:base64-encode-stream

 		#+(or (version= 7 0)
 		      (version= 8 0)

 		      (version>= 8 1 pre-beta 5))

 		#:base64-decode-stream)

   (:export
    #:base64-encode-stream

    #:base64-decode-stream
    #:qp-encode-stream
    #:qp-decode-stream

    #:qp-decode-usb8
    #:qp-decode-string

    #:with-decoded-part-body-stream))

 
 (in-package :net.post-office)
 
 ;;; Supported transfer encodings
 
 ;; encoders
 
 (defun raw-encode-stream (instream outstream)
   (declare (optimize (speed 3) (safety 0)))
   (let ((buf (make-array 4096 :element-type '(unsigned-byte 8)))
 	got)
     (declare (dynamic-extent buf)
 	     (fixnum got))
     (while (/= 0 (setf got (read-vector buf instream)))
       (write-vector buf outstream :end got))))
 
 (defconstant *qp-hex-digits* "0123456789ABCDEF")
 
 ;; wrap-at is not a hard limit but more of a suggestion.  it may be
 ;; late by by 3 characters.
 (defun qp-encode-stream (instream outstream &key (wrap-at 72))
   (declare (optimize (speed 3)))
   (let ((prev 0)
 	(outcol 0)
 	byte)
     (declare (fixnum byte prev))
 	    
     (macrolet ((whitespace (x) 
 		 (let ((xx (gensym)))
 		   `(let ((,xx ,x))
 		      (or (= ,xx 9) (= ,xx 32))))))
 	      
       (labels ((check-linewrap ()
 		 (if* (and wrap-at (>= outcol wrap-at))
 		    then (format outstream "=~%" outstream)
 			 (setf outcol 0)))
 	       (check-deferred ()
 		 (if* (and (= prev 13) (/= byte 10))
 		    then ;; previous byte was bare CR.  Handle
 			 (check-linewrap)
 			 (write-string "=0D" outstream)
 			 (incf outcol 3))
 		       
 		 (if* (whitespace prev)
 		    then (if* (or (= byte 0) (= byte 10) (= byte 13))
 			    then ;; EOF, EOL, probable EOL.  Encode.
 				 (check-linewrap)
 				 (format outstream "=20")
 				 (incf outcol 3)
 			    else ;; Safe to print deferred whitespace
 				 (check-linewrap)
 				 (write-char (code-char prev) outstream)
 				 (incf outcol 1)))))
 		
 	(while (setf byte (read-byte instream nil nil))
 	  (check-deferred)
 		  
 	  (if* (or (and (>= byte 33) (<= byte 60))
 		   (and (>= byte 62) (<= byte 126)))
 	     then (check-linewrap)
 		  (write-char (code-char byte) outstream)
 		  (incf outcol)
 	   elseif (or (= byte 13) (whitespace byte))
 	     thenret ;; defer handling
 	   elseif (= byte 10) ;; LF
 	     then (write-char #\newline outstream)
 		  (setf outcol 0)
 	     else (check-linewrap)
 		  (format outstream "=~c~c"
 			  (schar *qp-hex-digits* 
 				 (ash byte -4))
 			  (schar *qp-hex-digits*
 				 (logand byte #xf)))
 		  (incf outcol 3))
 		  
 	  (setf prev byte))
 		
 	;; Handle final deferred data
 	(setf byte 0)
 	(check-deferred)))))
 

 ;; Decoding stuff
 

 
 ;; Used by qp-decode-stream

 (eval-when (compile)

 (defconstant *qp-digit-values*
     #.(let ((arr (make-array 257 :element-type 'fixnum)))
 	(dotimes (n 256)
 	  (setf (aref arr n)
 	    (if* (<= (char-code #\0) n (char-code #\9))
 	       then (- n (char-code #\0))
 	     elseif (<= (char-code #\A) n (char-code #\F))
 	       then (- n (- (char-code #\A) 10))

 	     elseif (<= (char-code #\a) n (char-code #\f))
 	       then (- n (- (char-code #\a) 10))

 	       else -1)))
 	(setf (aref arr 256) -2)

 	arr)))

 
 (defun qp-decode-stream (instream outstream &key count)
   (declare (optimize (speed 3)))
   
   (let (unread-buf)
   
     (macrolet ((unread (byte)
 		 `(progn
 		    (setf unread-buf ,byte)
 		    (if count
 			(incf count))))
 	       (get-byte (&key eof-value)
 		 `(block get-byte
 		    (if* count
 		       then (if (zerop count)
 				(return-from get-byte ,eof-value))
 			    (decf count))
 		    (if* unread-buf
 		       then (prog1 unread-buf
 			      (setf unread-buf nil))
 		       else (read-byte instream nil ,eof-value))))
 	       (out (byte)
 		 `(write-byte ,byte outstream))
 	       (eol-p (byte)
 		 `(or (eq ,byte 10) (eq ,byte 13))))
 	       
       (let (byte)
 	(while (setf byte (get-byte))
 	  (if* (eq byte #.(char-code #\=))
 	     then (let ((nextbyte (get-byte)))
 		    (if* (null nextbyte)
 		       then ;; stray equal sign.  just dump and terminate.
 			    (out byte)
 			    (return))
 		    (if* (eol-p nextbyte)
 		       then ;; soft line break.  
 			    (if (eq nextbyte 13) ;; CR
 				(setf nextbyte (get-byte)))
 			    (if (not (eq nextbyte 10)) ;; LF
 				(unread nextbyte))
 		       else ;; =XY encoding
 			    (let* ((byte3 (get-byte :eof-value 256))

 				   (high (aref #.*qp-digit-values* nextbyte))
 				   (low (aref #.*qp-digit-values* byte3))

 				   (value (logior (the fixnum (ash high 4)) low)))
 			      (declare (fixnum byte3 high low value))
 			      (if* (< value 0)
 				 then ;; Invalid or truncated encoding. just dump it.
 				      (out byte)
 				      (out nextbyte)
 				      (if* (eq low -2) ;; EOF
 					 then (return)
 					 else (out byte3))
 				 else (out value)))))
 	     else (out byte)))
 	
 	t))))
 

 ;; 'out' should be at least the size of 'in'.  If it is nil,
 ;; a usb8 array will be allocated and used.   It is okay if 'out' is the
 ;; same buffer as 'in'.
 ;; Returns:
 ;;  1) the supplied or allocated array
 ;;  2) the just past the last byte populated in the array.
 (defun qp-decode-usb8 (in out &key (start1 0) (end1 (length in))

 				   (start2 0) end2
 				   underscores-are-spaces)

   (declare (optimize (speed 3))
 	   ((simple-array (unsigned-byte 8) (*)) in out)
 	   (fixnum start1 end1 start2 end2))
   
   (if (null out)
       (setf out (make-array (length in) :element-type '(unsigned-byte 8))))
   
   (if (null end2)
       (setf end2 (length out)))
   
   (let ((count (- end1 start1)))
     (declare (fixnum count))
     
     (if (< count 0)
 	(error "start1 must be less than end1"))
     
     (if (> start2 end2)
 	(error "start2 must be less than end2"))
     
     (if (< (the fixnum (- end2 start2)) count)
 	(error "Not enough room in output array"))
     
     (macrolet ((unread (byte)
 		 (declare (ignore byte))
 		 `(decf start1))
 	       (get-byte (&key eof-value)
 		 `(if* (>= start1 end1)
 		     then ,eof-value
 		     else (prog1 (aref in start1)
 			    (incf start1))))
 	       (out (byte)
 		 `(prog1 (setf (aref out start2) ,byte)
 		    (incf start2)))
 	       (eol-p (byte)
 		 `(or (eq ,byte 10) (eq ,byte 13))))
 	       
       (let (byte)
 	(while (setf byte (get-byte))
 	  (if* (eq byte #.(char-code #\=))
 	     then (let ((nextbyte (get-byte)))
 		    (if* (null nextbyte)
 		       then ;; stray equal sign.  just dump and terminate.
 			    (out byte)
 			    (return))
 		    (if* (eol-p nextbyte)
 		       then ;; soft line break.  
 			    (if (eq nextbyte 13) ;; CR
 				(setf nextbyte (get-byte)))
 			    (if (not (eq nextbyte 10)) ;; LF
 				(unread nextbyte))
 		       else ;; =XY encoding
 			    (let* ((byte3 (get-byte :eof-value 256))

 				   (high (aref #.*qp-digit-values* nextbyte))
 				   (low (aref #.*qp-digit-values* byte3))

 				   (value (logior (the fixnum (ash high 4)) low)))
 			      (declare (fixnum byte3 high low value))
 			      (if* (< value 0)
 				 then ;; Invalid or truncated encoding. just dump it.
 				      (out byte)
 				      (out nextbyte)
 				      (if* (eq low -2) ;; EOF
 					 then (return)
 					 else (out byte3))
 				 else (out value)))))

 	   elseif (and underscores-are-spaces (eq byte #.(char-code #\_)))
 	     then ;; See the discussion in bug18636 about why this is
 		  ;; done.
 		  (out #.(char-code #\space))

 	     else (out byte)))
 	
 	(values out start2)))))
 
 (defun qp-decode-string (string &key (start 0) (end (length string))
 				     (return :string)

 				     (external-format :default)
 				     underscores-are-spaces)

   (multiple-value-bind (vec len)
       (string-to-octets string :start start :end end :null-terminate nil
 			:external-format :latin1)
     (multiple-value-setq (vec len)

       (qp-decode-usb8 vec vec :end1 len
 		      :underscores-are-spaces underscores-are-spaces))

     (ecase return
       (:string
        (octets-to-string vec :end len :external-format external-format))
       (:usb8
        (subseq vec 0 len)))))
 

 ;; 'instream' must be positioned at the beginning of the part body 
 ;; by the caller beforehand.
 (defmacro with-decoded-part-body-stream ((sym part instream) &body body)

   (let ((p (gensym))
 	(encoding (gensym))

 	(count (gensym))
 	(charset (gensym))
 	(ef (gensym)))

     `(let* ((,p ,part)

 	    (,encoding (mime-part-encoding ,p))
 	    (,count (mime-part-body-size ,p)))
        (excl:with-function-input-stream (,sym #'mime-decode-transfer-encoding
 					      ,instream
 					      ,encoding
 					      ,count)

 	 (let* ((,charset (or (cdr (assoc "charset" (mime-part-parameters ,p)
 					  :test #'equalp))
 			      "us-ascii"))
 		(,ef (or (charset-to-external-format ,charset) :latin1)))
 	   (setf (stream-external-format ,sym) ,ef))

 	 ,@body))))

 (defun mime-decode-transfer-encoding (outstream instream encoding count)
   (cond
    ((equalp encoding "quoted-printable")
     (qp-decode-stream instream outstream :count count))

    #+(or (version= 7 0)
 	 (version= 8 0)

 	 (version>= 8 1 pre-beta 5))

    ((equalp encoding "base64")
     (excl:base64-decode-stream instream outstream :count count :error-p nil))
    (t
     ;; defined in mime-parse.cl
     (stream-to-stream-copy outstream instream count))))