;;; mew-encode.el --- MIME syntax encoder for Mew

;; Author:  Kazu Yamamoto <Kazu@Mew.org>
;; Created: Oct  2, 1996
;; Revised: Oct 25, 1997

;;; Code:

(defconst mew-encode-version "mew-encode.el version 0.21")

(require 'mew)

(defvar mew-prog-mime-encode-switch
  (list
   (cons mew-b64 '("-b"))
   (cons mew-qp  '("-q"))
   (cons mew-xg  '("-g"))
   )
  )

(defvar mew-prog-mime-encode-text-switch
  (list
   (cons mew-b64 '("-b" "-t"))
   (cons mew-qp  '("-q"))
   (cons mew-xg  '("-g" "-t"))
   )
  )

(defvar mew-encode-multipart-encrypted-switch
  '(("application/pgp-encrypted"  . mew-pgp-encrypt)
;    ("application/moss-keys"      . mew-moss-encrypt)
    )
  )

(defvar mew-encode-multipart-signed-switch
  '(("application/pgp-signature"   . mew-pgp-sign)
;    ("application/moss-signature"  . mew-moss-sign)
;    ("application/pkcs7-signature" . mew-smime-sign)
    )
  )

;;;
;;;
;;;

(defun mew-draft-make-message ()
  "Make a MIME message. Charset guess, mapping directory structure 
to multipart, and so on."
  (interactive)
  (if mew-config-insert-when-composed
      (mew-draft-insert-config))
  (if (mew-header-get-value mew-ct:)
      (progn
	(ding)
	(message "%s already exists!" mew-ct:)
	)
    (message "Making a MIME letter ...")
    (if (mew-attach-p)
	(let ((inherit-signer (or (mew-header-get-address "From:")
				  mew-mail-address)))
	  (mew-draft-make-multi))
      (mew-draft-make-single))
    (mew-draft-make-header)
    (message "Making a MIME letter ... done")))

(defun mew-draft-make-header ()
  ;; RFC 2047 header encoding
  (goto-char (point-min))
  (if (re-search-forward mew-eoh2 nil t)
      (let (key val func)
	(save-restriction
	  (narrow-to-region (point-min) (point))
	  (goto-char (point-min))
	  (while (not (eobp))
	    (if (not (looking-at mew-keyval))
		(forward-line) ;; xxx
	      (setq key (mew-match 1))
	      (setq val (match-beginning 2))
	      (forward-line)
	      (while (looking-at mew-lwsp) (forward-line))
	      (setq func (cdr (mew-assoc-match2 key mew-encode-fields 0)))
	      (if func
		  (funcall func val (1- (point))))
	      )))))
  ;; Header delimiter setup again
  (goto-char (point-min))
  (re-search-forward mew-eoh2)
  (beginning-of-line)
  (setq mew-draft-buffer-header (point-marker)) ;; just in case
  (mew-highlight-header-region
   (point-min) (marker-position mew-draft-buffer-header))
  )

(defun mew-draft-make-single ()
  (mew-draft-make-backup 'single)
  (mew-draft-refresh)
  (goto-char (marker-position mew-draft-buffer-header))
  ;; the beginning of "----"
  (let ((beg (point)))
    (forward-line)
    ;; cursor is just after "----\n"
    (delete-region beg (point))
    )
  (mew-encode-singlepart (mew-encode-syntax-single "text-file") nil nil t)
  )

(defun mew-draft-make-backup (&optional single)
  ;; back up the draft and its syntax
  (let* ((path (mew-expand-folder (mew-draft-to-mime (buffer-name))))
	 (backup-file (expand-file-name mew-draft-backup-file path))
	 (syntax-file (expand-file-name mew-draft-syntax-file path))
	 (syntax mew-encode-syntax) ;; mew-encode-syntax is buffer local
	 (find-file-hooks nil))
    (if (not (file-exists-p path)) (mew-make-directory path)) ;;for single part
    (write-region (point-min) (point-max) backup-file nil 'no-msg)
    (if (not single)
	(save-excursion
	  (set-buffer (find-file-noselect syntax-file))
	  (mew-erase-buffer)
	  (prin1 syntax (current-buffer)) ;; different buffer, so use syntax
	  (terpri (current-buffer))
	  (save-buffer)
	  (message "") ;; flush echo area
	  (kill-buffer (current-buffer))
	  ))
    ))

;; xxx will be obsoleted?
(defun mew-encode-escape-region (beg end)
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (let ((case-fold-search nil))
	(re-search-forward "^From \\|^\\.\n" nil t)
	))
    ))
 
(defun mew-encode-get-topts (cte)
  (cdr (mew-assoc-case-equal cte mew-prog-mime-encode-text-switch 0))
  )

(defun mew-encode-text-magic (infile ctl cte)
  ;; return (file charset cte encopts)
  ;; If infile is 't', target is buffered.
  (let* ((charset (mew-syntax-get-member ctl "charset"))
	 ;; charset exists only when file is not buffered.
	 encopts outfile)
    (if (and charset cte)
	(list infile charset cte (mew-encode-get-topts cte)) ;; return
      (if (stringp infile)
	  ;; Even if charset is specified, we need to convert it to
	  ;; transfer charset.
	  (mew-frwlet
	   (or (mew-charset-to-cs charset) mew-cs-infile) mew-cs-noconv
	   ;; Input the text file converting its charset to the internel.
	   ;; If charset is specified, use it.
	   ;; If mew-cs-infile is *autoconv*/'autodetect, charset is guessed
	   ;; by Mule's heuristic. For more information, see
	   ;; set[up]-<language>-function in Emacs/Mule.
	   (insert-file-contents infile)
	   )
	)
      ;; Target is now certainly bufferd.
      ;; Let's guess charset if not specified. The charset of CoverPage 
      ;; for just singlepart(buffered) is always guessed.
      ;; Even if the file is EUC-Japan, charset is guessed as ISO-2022-JP.
      ;; Even if Latin1 is encoded in ISO-2022-JP-2, 
      ;; charset is guessed as ISO-8859-1.
      (if (null charset) 
	  (setq charset (mew-charset-guess-region (point) (point-max))))
      (if charset
	  ()
	(message "Cannot guess charset. Confirm charset later!!")
	(ding)
	(sit-for 1)
	(setq charset "us-ascii"))
      ;; Guess cte for mewencode executed later.
      ;; xxx how about mew-encode-escape-region?
      (if cte
	  (setq encopts (mew-encode-get-topts cte))
	(setq cte (or (mew-charset-to-cte charset) mew-b64))
	(setq encopts (mew-encode-get-topts cte)))
      (if (null encopts)
	  ()
	;; We MUST save text since charset MAY change.
	(mew-frwlet
	 mew-cs-noconv (mew-charset-to-cs charset)
	 (setq outfile (mew-make-temp-name))
	 ;; NEVER use call-process-region for privary reasons
	 (write-region (point) (point-max) outfile nil 'no-msg))
	;; outfile will be used, so delete the region.
	(delete-region (point) (point-max)))
      (list outfile charset cte encopts)
      )))

(defun mew-encode-singlepart (syntax &optional path depth buffered)
  ;; path is nil if called make-single or security multipart
  ;; buffered is t if called make-single
  (let* ((file (expand-file-name (mew-syntax-get-file syntax) path))
	 (ctl (mew-syntax-get-ct syntax))
	 (ct (capitalize (car ctl))) ;; just in case
	 (ctparams (cdr ctl))
	 (cte (mew-syntax-get-cte syntax))
	 (cd (mew-syntax-get-cd syntax))
	 (cdpl (mew-syntax-get-cdp syntax))
	 (cdp (car cdpl))
	 (cdpparams (cdr cdpl))
	 (privacy (mew-syntax-get-privacy syntax))
	 (beg (point))
	 (text-sw mew-prog-mime-encode-text-switch)
	 (binary-sw mew-prog-mime-encode-switch)
	 charset fcce encopts)
    (if (null (string-match "Text/" ct))
	;; No need to guess charset.
	;; The text based object is encoded by mewencode replacing LF 
	;; with CRLF. This is NOT identical to line break replacement for 
	;; object to be signed below.
	(if (null cte)
	    (setq cte mew-7bit)
	  (if (mew-member-case-equal ct mew-mime-content-type-text-list)
	      (setq encopts (cdr (mew-assoc-case-equal cte text-sw 0)))
	    (setq encopts (cdr (mew-assoc-case-equal cte binary-sw 0)))))
      ;; Need to guess charset
      (setq fcce (mew-encode-text-magic (or buffered file) ctl cte))
      (setq file (nth 0 fcce) charset (nth 1 fcce) 
	    cte (nth 2 fcce) encopts (nth 3 fcce))
      ;; file is nil if buffered
      (setq ctparams (list (format "charset=%s" charset)))
      )
    ;; Insert ct and its ctparams. This is flexible enough for msg/extb
    (mew-header-insert-here mew-ct: ct 'noret)
    (mew-header-insert-param-here ctparams)
    (insert "\n")
    ;; Insert cte.
    (mew-header-insert-here mew-cte: cte) ;; cte is never nil here
    ;; Insert cd.
    (if cd
	(let (start)
	  (mew-header-insert-here mew-cd: nil 'noret)
	  (setq start (point))
	  (insert cd)
	  (mew-header-encode-text start (point))
	  (insert "\n"))
      )
    (if cdp
	(progn
	  (mew-header-insert-here mew-cdp: cdp 'noret)
	  (mew-header-insert-param-here cdpparams)
	  (insert "\n")))
    ;; Terminate content-header.
    (insert "\n")
    ;; header "\n" (cur) [text]
    (if encopts
	;; Binary objects matches here.
	;; If called charset-magic and encopts is not nil, file is not nil.
	;; Encoded file is always in us-ascii domain. So just insert it.
	(mew-piolet mew-cs-autoconv mew-cs-noconv
	 (apply (function call-process) mew-prog-mime-encode 
		file t nil encopts)
	 )
      (if file ;; not buffered	 
	  ;; Probably 7bit text based object like phantom body of 
	  ;; message/external-body. 
	  (insert-file-contents file)))
    ;; Go to RFC1847 privacy services.
    ;; RFC1847 and services using it such as RFC1848 MOSS and RFC2015 PGP/MIME
    ;; allows 8bit/binary MIME canonical form(i.e. 7bit content-header and 
    ;; 8bit/binary content-body) for encryption (not for signing). 
    ;; But Mew restricts an object to be ecnrypted(or, of course, signed) 
    ;; to be in 7bit for the following two reasons:
    ;;   (1) It is technically awkward that an object consists of 
    ;;      a 7bit header part and a BINARY body part. For the former
    ;;      is text based but the latter is not text based.
    ;;   (2) 8BIT TEXT objects are obstacles for multi-lingual environment.
    ;;      US-ASCII, 7bit-encoded 8bit text, ISO-2022 families are allowed.
    ;;      (It's not impossible to implement but too few advantage.)
    ;;
    ;; Now we gained 7bit-encoded MIME canonical object here.
    ;;         content-header<LF>
    ;;         <LF>
    ;;         7bit-content-body<LF>
    ;;
    (if (null privacy)
	()
      (save-restriction
	(narrow-to-region beg (point-max))
	(let ((case-fold-search t) 
	      (decrypters (mew-syntax-get-decrypters syntax))
	      protocol ct)
	  (while privacy
	    (goto-char (point-min)) 
	    (setq ct (nth 0 (car privacy)))
	    (setq protocol (nth 1 (car privacy)))
	    (setq privacy (cdr privacy))
	    (cond 
	     ((string-match mew-ct-mle ct)
	      (mew-encode-multipart-encrypted ct protocol depth decrypters))
	     ((string-match mew-ct-mls ct)
	      (mew-encode-multipart-signed ct protocol depth))
	     )
	    ))))
    (goto-char (point-max))
    ))

(defun mew-draft-make-multi ()
  ;;
  ;; delete multipart syntax
  ;;
  (goto-char (marker-position mew-draft-buffer-attach))
  (delete-region (point) (point-max))
  ;; disable marker
  (set-marker mew-draft-buffer-attach nil)
  (setq mew-draft-buffer-attach nil)
  ;;
  (mew-draft-make-backup)
  ;;
  ;; delete body
  ;;
  ;; delete delimiter
  (mew-draft-refresh)
  (goto-char (marker-position mew-draft-buffer-header))
  ;; the beginning of "----"
  (let* ((beg (point))
	 (syntax mew-encode-syntax) 
	 ;; use local variable to prevent side effects when undo
	 (cpath (mew-expand-folder (mew-draft-to-mime (buffer-name))))
	 (coverfile (expand-file-name mew-draft-coverpage cpath))
	 (path (mew-expand-folder mew-draft-mime-folder)))
    (forward-line)
    ;; cursor is just after "----\n"
    (delete-region beg (point))
    ;; disable marker
    (set-marker mew-draft-buffer-header nil)
    (setq mew-draft-buffer-header nil)
    ;; just after the header
    ;; see if cover page is empty or not
    (while (and (looking-at "^$") (not (eobp)))
      (forward-line))
    (if (not (eobp))
	;; A cover page exists, so save it.
	;; On Mule, from internal to mew-cs-draft.
	;; This code may be overhead but makes code simple.
	(mew-frwlet
	 mew-cs-noconv mew-cs-draft
	 (write-region beg (point-max) coverfile nil 'no-msg)
	 )
      ;; A cover page doesn't exist
      ;; Remove the cover page entry from the syntax
      (setq syntax (mew-syntax-remove-entry syntax '(1))))
    (delete-region beg (point-max))
    ;; Now only the header in the draft
    ;;
    ;; Let's go multi
    ;;
    (mew-encode-multipart syntax path 0)
    ))

(defun mew-encode-multipart (syntax path depth)
  (let* ((boundary
	  (mew-boundary-get ;; 0 is nil for Next_Part
	   (if (> depth 0) (format "BOUNDARY%s" (int-to-string depth)))))
	 (fullname (expand-file-name (mew-syntax-get-file syntax) path))
	 (ctl (mew-syntax-get-ct syntax))
	 (ct (capitalize (car ctl))) ;; just in case
	 (cte (mew-syntax-get-cte syntax))
	 (cd (mew-syntax-get-cd syntax))
	 (privacy (mew-syntax-get-privacy syntax))
	 (len (length syntax))
	 (cnt mew-syntax-magic)
	 (beg (point)))
    (mew-header-insert-here 
     mew-ct: (concat ct ";\n\tboundary=\"" boundary "\""))
    (mew-header-insert-here mew-cte: (or cte mew-7bit))
    (if cd
	(let (start)
	  (mew-header-insert-here mew-cd: nil 'noret)
	  (setq start (point))
	  (insert cd)
	  (mew-header-encode-text start (point))
	  (insert "\n"))
      )
    (while (< cnt len)
      (insert (concat "\n--" boundary "\n"))
      (if (mew-syntax-multipart-p (aref syntax cnt))
	  (mew-encode-multipart (aref syntax cnt) fullname (1+ depth))
	(mew-encode-singlepart (aref syntax cnt) fullname (1+ depth)))
      (setq cnt (1+ cnt))
      )
    (insert (concat "\n--" boundary "--\n"))
    ;; 
    ;; Let's go privacy services.
    ;;
    (if (null privacy)
	()
      (save-restriction
	(narrow-to-region beg (point-max))
	(let ((case-fold-search t) 
	      (decrypters (mew-syntax-get-decrypters syntax))
	      protocol ct)
	  (while privacy
	    (goto-char (point-min)) 
	    (setq ct (nth 0 (car privacy)))
	    (setq protocol (nth 1 (car privacy)))
	    (setq privacy (cdr privacy))
	    (cond 
	     ((string-match mew-ct-mle ct)
	      (mew-encode-multipart-encrypted ct protocol depth decrypters))
	     ((string-match mew-ct-mls ct)
	      (mew-encode-multipart-signed ct protocol depth))
	     )
	    ))))
    (goto-char (point-max))
    ))

;;;
;;; Privacy services
;;;

(defun mew-security-multipart-boundary (depth)
   (if depth
       (mew-boundary-get (format "Security_Multipart%s" (int-to-string depth)))
     (mew-boundary-get "Security_Multipart")))

(defun mew-encode-multipart-encrypted (ct protocol depth decrypters)
  ;; called in the narrowed region
  (let* ((boundary (mew-security-multipart-boundary depth))
	 (switch mew-encode-multipart-encrypted-switch) ;; save length
	 (func (cdr (mew-assoc-case-equal protocol switch 0)))
	file1 file2 file3 cte2 cte3 fc error)
    (setq decrypters (mew-encode-decrypters-list decrypters))
    ;; Write the part converting line breaks.
    (setq file1 (mew-save-transfer-form (point-min) (point-max) nil))
    ;; The narrowed region stores nothing
    ;; Call the protocol function
    (condition-case nil
	(setq fc (funcall func file1 decrypters))
      (error
       (if (file-exists-p file1) (delete-file file1))
       (error "unknown error for %s. Check %s, anyway" 
	      mew-ct-mle mew-temp-dir)))
    (setq file2 (nth 0 fc) cte2 (nth 1 fc) file3 (nth 2 fc) cte3 (nth 3 fc))
    (setq error (nth 4 fc))
    (if error
	(progn
	  (if (file-exists-p file1) (delete-file file1))
	  (if (file-exists-p file2) (delete-file file2))
	  (if (file-exists-p file3) (delete-file file3))
	  (error (concat error " Type "
			 (substitute-command-keys
			  "\\<mew-draft-mode-map>\\[mew-draft-undo]")
			 " to get the draft back.")))
      ;; Create multipart content-header
      (mew-header-insert-here mew-ct: ct 'noret)
      (insert (format ";\n\tprotocol=\"%s\"" protocol))
      (insert (format ";\n\tboundary=\"%s\"\n" boundary)) ;; \n doubled
      (insert (format "\n--%s\n" boundary))
      ;; Insert control keys
      (mew-encode-singlepart 
       (mew-encode-syntax-single file2 (list protocol) cte2))
      (insert (format "\n--%s\n" boundary))
      ;; Insert encrpted body
      (mew-encode-singlepart 
       (mew-encode-syntax-single file3 mew-type-apo cte3))
      (insert (format "\n--%s--\n" boundary))
      ;; Throw away the garbage 
      (if (file-exists-p file1) (delete-file file1))
      (if (file-exists-p file2) (delete-file file2))
      (if (file-exists-p file3) (delete-file file3))
      )
    ))

(defun mew-encode-multipart-signed (ct protocol depth)
  ;; called in the narrowed region
  (let* ((boundary (mew-security-multipart-boundary depth))
	 (switch mew-encode-multipart-signed-switch);; save length
	 (func (cdr (mew-assoc-case-equal protocol switch 0)))
	 file1 file2 micalg cte2 fmc error)
    (setq file1 (mew-save-transfer-form (point-min) (point-max) 'retain))
    ;; The narrowed region still the ORIGINAL part (i.e. line breaks are LF)
    ;; Call the protocol function
    (condition-case nil
	(setq fmc (funcall func file1))
      (error
       (if (file-exists-p file1) (delete-file file1))
       (error "unknown error for %s. Check %s, anyway" 
	      mew-ct-mls mew-temp-dir)))
    (setq file2 (nth 0 fmc) cte2 (nth 1 fmc) micalg (nth 2 fmc))
    (setq error (nth 3 fmc))
    (if error
	(progn
	  (if (file-exists-p file1) (delete-file file1))
	  (if (file-exists-p file2) (delete-file file2))
	  (error (concat error " Type "
			 (substitute-command-keys
			  "\\<mew-draft-mode-map>\\[mew-draft-undo]")
			 " to get the draft back.")))
      (goto-char (point-min))
      ;; Before the signed part
      ;; Create multipart content-header
      (mew-header-insert-here mew-ct: ct 'noret)
      (insert (format ";\n\tprotocol=\"%s\"" protocol))
      (insert (format ";\n\tmicalg=\"%s\"" micalg))
      (insert (format ";\n\tboundary=\"%s\"\n" boundary)) ;; \n doubled
      (insert (format "\n--%s\n" boundary))
      (goto-char (point-max))
      ;; After the sigend part
      (insert (format "\n--%s\n" boundary))
      (mew-encode-singlepart 
       (mew-encode-syntax-single file2 (list protocol) cte2))
      (insert (format "\n--%s--\n" boundary))
      ;; Throw away the garbage 
      (if (file-exists-p file1) (delete-file file1))
      (if (file-exists-p file2) (delete-file file2))
      )
    ))

(defun mew-save-transfer-form (beg end retain)
  ;; called in the narrowed region
  (let ((sbeg beg) (send end) (draft-buf (current-buffer)) file)
    (if retain
	(progn
	  (mew-set-buffer-tmp)
	  ;; tmp buffer
	  (insert-buffer-substring draft-buf beg end)
	  (setq sbeg (point-min) send (point-max))))
    (if mew-cs-7bit-crlf
	()
      (goto-char sbeg) ;; just in case
      (while (search-forward "\n" nil t) (replace-match "\r\n" nil t))
      (setq send (point-max)))
    (setq file (mew-make-temp-name))
    (mew-frwlet mew-cs-noconv mew-cs-7bit-crlf
      (write-region sbeg send file nil 'no-msg))
    (if retain
	(mew-erase-buffer)
      (delete-region sbeg send))
    (set-buffer draft-buf)
    file ;; return value
    ))

(defun mew-encode-decrypters-list (string)
  (let ((list))
    (setq list (mew-header-canform-list
                (mew-header-expand-alias-list
                 (mew-header-delete-nullstring-list
                  (mew-header-extract-addr-list
                   (mew-header-split
		    (mew-header-syntax string)
                    ?,))))))
    (cons mew-mail-address list);; to decrypt by myself
    ))

(defvar mew-default-boundary "--%s(%s_%s)--")

(defun mew-boundary-get (&optional string)
  (if (null string) (setq string "Next_Part"))
  (format mew-default-boundary
	  string
	  (mew-replace-character (current-time-string) 32 ?_) ; 32 == " "
	  (mew-random-string)
	  )
  )

;;
;; charset
;;

(defun mew-charset-8bit-p (charset)
  (let ((case-fold-search t))
    (cond 
     ((string-match "iso-8859" charset) t)
     ((string-match "iso-2022" charset) nil)
     ((string-match "us-ascii" charset) nil)
     (t t) ;; just in case
     )
    ))

(defun mew-charset-iso-2022-p (charset)
  (let ((case-fold-search t))
    (cond 
     ((string-match "iso-2022" charset) t)
     (t nil)
     )
    ))


(provide 'mew-encode)

;;; Copyright Notice:

;; Copyright (C) 1996, 1997, 1998 Mew developing team.
;; All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. All advertising materials mentioning features or use of this software
;;    must display the following acknowledgement:
;;       This product includes software developed by 
;;       Mew developing team and its contributors.
;; 4. Neither the name of the team nor the names of its contributors
;;    may be used to endorse or promote products derived from this software
;;    without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; mew-encode.el ends here