Modified versions of the Gnus functions gnus-article-browse-html-article and gnus-article-browse-html-parts

gnus-html-article-overrides.el

;; These modifications are potentially dangerous.  Read the description below carefully!
;;
;; Opening an HTML message in an external browser with
;; gnus-article-browse-html-article creates temporary files (by default in /tmp)
;; and points your browser to the URL file:///tmp/mm-blah.html.  If you're
;; running Emacs over an ssh tunnel, Conkeror/Firefox will send that URL to the
;; client browser.  Of course, the files in /tmp aren't accessible on the
;; client.  The modifications here cause the files to be placed in a web
;; accessible location defined in the variable gnus-tmp-www-dir, changes file
;; permissions, and updates the URL for the HTML message to be
;; https://my_system_name/mm-blah.html so your HTML message is viewable from the
;; client browser.  This means you have to be running a web server on the remote host.
;; It also means your mail files will have permissions allowing other users (the
;; web server) to view the files and your mail will be (temporarily) accessible
;; on the web!  Take appropriate precautions like password protecting the
;; directory gnus-tmp-www-dir.

(setq gnus-tmp-www-dir "/www/tmp/Gnus")

(defun jrm-gnus-article-browse-html-article (&optional arg)
  "View \"text/html\" parts of the current article with a WWW browser.
Inline images embedded in a message using the cid scheme, as they are
generally considered to be safe, will be processed properly.
The message header is added to the beginning of every html part unless
the prefix argument ARG is given.

Warning: Spammers use links to images (using the http scheme) in HTML
articles to verify whether you have read the message.  As
`gnus-article-browse-html-article' passes the HTML content to the
browser without eliminating these \"web bugs\" you should only
use it for mails from trusted senders.

If you always want to display HTML parts in the browser, set
`mm-text-html-renderer' to nil.

This command creates temporary files to pass HTML contents including
images if any to the browser, and deletes them when exiting the group
\(if you want).

This modified version of the function places the files in a web
accessible location defined in gnus-tmp-www-dir.  Take
appropriate precautions like password protecting the web site.
Your mail will be (temporarily) on the web!"
  ;; Cf. `mm-w3m-safe-url-regexp'
  (interactive "P")
  (if arg
      (gnus-summary-show-article)
    (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
				    gnus-visible-headers))
	  ;; As we insert a <hr>, there's no need for the body boundary.
	  (gnus-treat-body-boundary nil))
      (gnus-summary-show-article)))
  (with-current-buffer gnus-article-buffer
    (let ((header (unless arg
		    (save-restriction
		      (widen)
		      (buffer-substring-no-properties
		       (goto-char (point-min))
		       (if (search-forward "\n\n" nil t)
			   (match-beginning 0)
			 (goto-char (point-max))
			 (skip-chars-backward "\t\n ")
			 (point))))))
	  parts)
      (set-buffer gnus-original-article-buffer)
      (setq parts (mm-dissect-buffer t t))
      ;; If singlepart, enforce a list.
      (when (and (bufferp (car parts))
		 (stringp (car (mm-handle-type parts))))
	(setq parts (list parts)))
      ;; Process the list
      (unless (jrm-gnus-article-browse-html-parts parts header)
	(gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
      (mm-destroy-parts parts)
      (unless arg
	(gnus-summary-show-article)))))

(defun jrm-gnus-article-browse-html-parts (list &optional header)
  "View all \"text/html\" parts from LIST.
Recurse into multiparts.  The optional HEADER that should be a decoded
message header will be added to the bodies of the \"text/html\" parts."
  ;; Internal function used by `jrm-gnus-article-browse-html-article'.
  (let (type file charset content cid-dir tmp-file showed
	     (temporary-file-directory gnus-tmp-www-dir))
    ;; Find and show the html-parts.
    (dolist (handle list)
      ;; If HTML, show it:
      (cond ((not (listp handle)))
	    ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
		 (and (equal (car type) "message/external-body")
		      (or header
			  (setq file (mm-handle-filename handle)))
		      (or (mm-handle-cache handle)
			  (condition-case code
			      (progn (mm-extern-cache-contents handle) t)
			    (error
			     (gnus-message 3 "%s" (error-message-string code))
			     (when (>= gnus-verbose 3) (sit-for 2))
			     nil)))
		      (progn
			(setq handle (mm-handle-cache handle)
			      type (mm-handle-type handle))
			(equal (car type) "text/html"))))
	     (setq charset (mail-content-type-get type 'charset)
		   content (mm-get-part handle))
	     (with-temp-buffer
	       (if (eq charset 'gnus-decoded)
		   (mm-enable-multibyte)
		 (mm-disable-multibyte))
	       (insert content)
	       ;; resolve cid contents
	       (let ((case-fold-search t)
		     cid-file)
		 (goto-char (point-min))
		 (while (re-search-forward "\
<img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\""
					   nil t)
		   (unless cid-dir
		     (setq cid-dir (mm-make-temp-file "cid" t))
		     (set-file-modes cid-dir #o750)
		     (add-to-list 'gnus-article-browse-html-temp-list cid-dir))
		   (setq file nil
			 content nil)
		   (when (setq cid-file
			       (gnus-article-browse-html-save-cid-content
				(match-string 2)
				(with-current-buffer gnus-article-buffer
				  gnus-article-mime-handles)
				cid-dir))
		     (when (eq system-type 'cygwin)
		       (setq cid-file
			     (concat "/" (substring
					  (with-output-to-string
					    (call-process "cygpath" nil
							  standard-output
							  nil "-m" cid-file))
					  0 -1))))
		     (set-file-modes cid-file #o640)
		     (replace-match (concat "file://" cid-file)
				    nil nil nil 1))))
	       (unless content (setq content (buffer-string))))
	     (when (or charset header (not file))
	       (setq tmp-file (mm-make-temp-file
			       ;; Do we need to care for 8.3 filenames?
			       "mm-" nil ".html"))
	       (set-file-modes tmp-file #o640))
	     ;; Add a meta html tag to specify charset and a header.
	     (cond
	      (header
	       (let (title eheader body hcharset coding)
		 (with-temp-buffer
		   (mm-enable-multibyte)
		   (setq case-fold-search t)
		   (insert header "\n")
		   (setq title (message-fetch-field "subject"))
		   (goto-char (point-min))
		   (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|\\(&\\)\\|\n"
					     nil t)
		     (replace-match (cond ((match-beginning 1) "&lt;")
					  ((match-beginning 2) "&gt;")
					  ((match-beginning 3) "&amp;")
					  (t "<br>\n"))))
		   (goto-char (point-min))
		   (while (re-search-forward "^[\t ]+" nil t)
		     (dotimes (i (prog1
				     (current-column)
				   (delete-region (match-beginning 0)
						  (match-end 0))))
		       (insert "&nbsp;")))
		   (goto-char (point-min))
		   (insert "<div align=\"left\">\n")
		   (goto-char (point-max))
		   (insert "</div>\n<hr>\n")
		   ;; We have to examine charset one by one since
		   ;; charset specified in parts might be different.
		   (if (eq charset 'gnus-decoded)
		       (setq charset 'utf-8
			     eheader (mm-encode-coding-string (buffer-string)
							      charset)
			     title (when title
				     (mm-encode-coding-string title charset))
			     body (mm-encode-coding-string content charset))
		     (setq hcharset (mm-find-mime-charset-region (point-min)
								 (point-max)))
		     (cond ((= (length hcharset) 1)
			    (setq hcharset (car hcharset)
				  coding (mm-charset-to-coding-system
					  hcharset nil t)))
			   ((> (length hcharset) 1)
			    (setq hcharset 'utf-8
				  coding hcharset)))
		     (if coding
			 (if charset
			     (progn
			       (setq body
				     (mm-charset-to-coding-system charset
								  nil t))
			       (if (eq coding body)
				   (setq eheader (mm-encode-coding-string
						  (buffer-string) coding)
					 title (when title
						 (mm-encode-coding-string
						  title coding))
					 body content)
				 (setq charset 'utf-8
				       eheader (mm-encode-coding-string
						(buffer-string) charset)
				       title (when title
					       (mm-encode-coding-string
						title charset))
				       body (mm-encode-coding-string
					     (mm-decode-coding-string
					      content body)
					     charset))))
			   (setq charset hcharset
				 eheader (mm-encode-coding-string
					  (buffer-string) coding)
				 title (when title
					 (mm-encode-coding-string
					  title coding))
				 body content))
		       (setq eheader (mm-string-as-unibyte (buffer-string))
			     body content)))
		   (erase-buffer)
		   (mm-disable-multibyte)
		   (insert body)
		   (when charset
		     (mm-add-meta-html-tag handle charset t))
		   (when title
		     (goto-char (point-min))
		     (unless (search-forward "<title>" nil t)
		       (re-search-forward "<head>\\s-*" nil t)
		       (insert "<title>" title "</title>\n")))
		   (goto-char (point-min))
		   (or (re-search-forward
			"<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
		       (re-search-forward
			"</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
		   (insert eheader)
		   (replace-regexp (concat "file://" gnus-tmp-www-dir) "./")
		   (mm-write-region (point-min) (point-max)
				    tmp-file nil nil nil 'binary t))))
	      (charset
	       (mm-with-unibyte-buffer
		 (insert (if (eq charset 'gnus-decoded)
			     (mm-encode-coding-string content
						      (setq charset 'utf-8))
			   content))
		 (if (or (mm-add-meta-html-tag handle charset)
			 (not file))
		     (mm-write-region (point-min) (point-max)
				      tmp-file nil nil nil 'binary t)
		   (setq tmp-file nil))))
	      (tmp-file
	       (mm-save-part-to-file handle tmp-file)))
	     (when tmp-file
	       (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
	     (add-hook 'gnus-summary-prepare-exit-hook
		       'gnus-article-browse-delete-temp-files)
	     (add-hook 'gnus-exit-gnus-hook
		       (lambda  ()
			 (gnus-article-browse-delete-temp-files t)))
	     ;; FIXME: Warn if there's an <img> tag?
	     (browse-url-of-file (concat
				  "https://" system-name
				  (replace-regexp-in-string "/www" "" tmp-file)))
	     (setq showed t))
	    ;; If multipart, recurse
	    ((equal (mm-handle-media-supertype handle) "multipart")
	     (when (jrm-gnus-article-browse-html-parts handle header)
	       (setq showed t)))
	    ((equal (mm-handle-media-type handle) "message/rfc822")
	     (mm-with-multibyte-buffer
	       (mm-insert-part handle)
	       (setq handle (mm-dissect-buffer t t))
	       (when (and (bufferp (car handle))
			  (stringp (car (mm-handle-type handle))))
		 (setq handle (list handle)))
	       (when header
		 (article-decode-encoded-words)
		 (let ((gnus-visible-headers
			(or (get 'gnus-visible-headers 'standard-value)
			    gnus-visible-headers)))
		   (article-hide-headers))
		 (goto-char (point-min))
		 (search-forward "\n\n" nil 'move)
		 (skip-chars-backward "\t\n ")
		 (setq header (buffer-substring (point-min) (point)))))
	     (when (prog1
		       (jrm-gnus-article-browse-html-parts handle header)
		     (mm-destroy-parts handle))
	       (setq showed t)))))
    showed))