Update with-url branch and rename to with-fetched-urlwith-fetched-url

2 files changed, 141 insertions, 179 deletions

diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 49bf10d4ebe..764c6d6edc8 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -32,6 +32,7 @@
 (require 'url-util)			; for url-get-url-at-point
 (require 'mm-url)
 (require 'puny)
+(require 'with-url)
 (eval-when-compile (require 'subr-x)) ;; for string-trim
 
 (defgroup eww nil
@@ -263,6 +264,10 @@ word(s) will be searched for via `eww-search-prefix'."
        (current-buffer)
      (get-buffer-create "*eww*")))
   (eww-setup-buffer)
+  (eww--fetch-url url))
+
+(cl-defun eww--fetch-url (url &key (method 'get) data point buffer encode
+                              data-encoding)
   ;; Check whether the domain only uses "Highly Restricted" Unicode
   ;; IDNA characters.  If not, transform to punycode to indicate that
   ;; there may be funny business going on.
@@ -270,15 +275,18 @@ word(s) will be searched for via `eww-search-prefix'."
     (when (url-host parsed)
       (unless (puny-highly-restrictive-domain-p (url-host parsed))
         (setf (url-host parsed) (puny-encode-domain (url-host parsed)))
-        (setq url (url-recreate-url parsed)))))
-  (plist-put eww-data :url url)
-  (plist-put eww-data :title "")
-  (eww-update-header-line-format)
-  (let ((inhibit-read-only t))
-    (insert (format "Loading %s..." url))
-    (goto-char (point-min)))
-  (url-retrieve url 'eww-render
-                (list url nil (current-buffer))))
+        (setq url (url-recreate-url parsed))))
+    (plist-put eww-data :url url)
+    (plist-put eww-data :title "")
+    (eww-update-header-line-format)
+    (let ((inhibit-read-only t))
+      (insert (format "Loading %s..." url))
+      (goto-char (point-min)))
+    (let ((buffer (or buffer (current-buffer))))
+      (with-fetched-url (url :method method
+                             :data data
+                             :data-encoding data-encoding)
+        (eww-render point buffer encode)))))
 
 (defun eww--dwim-expand-url (url)
   (setq url (string-trim url))
@@ -354,27 +362,22 @@ Currently this means either text/html or application/xhtml+xml."
   (member content-type '("text/html"
 			 "application/xhtml+xml")))
 
-(defun eww-render (status url &optional point buffer encode)
-  (let* ((headers (eww-parse-headers))
+(defun eww-render (&optional point buffer encode)
+  (let* ((url (url-status 'url))
 	 (content-type
 	  (mail-header-parse-content-type
-           (if (zerop (length (cdr (assoc "content-type" headers))))
-	       "text/plain"
-             (cdr (assoc "content-type" headers)))))
+           (or (url-header 'content-type) "text/plain")))
 	 (charset (intern
 		   (downcase
 		    (or (cdr (assq 'charset (cdr content-type)))
 			(eww-detect-charset (eww-html-p (car content-type)))
 			"utf-8"))))
-	 (data-buffer (current-buffer))
 	 (shr-target-id (url-target (url-generic-parse-url url)))
 	 last-coding-system-used)
-    (let ((redirect (plist-get status :redirect)))
-      (when redirect
-        (setq url redirect)))
     (with-current-buffer buffer
       ;; Save the https peer status.
-      (plist-put eww-data :peer (plist-get status :peer))
+      (plist-put eww-data :peer (url-status 'tls-peer))
+      ;; (plist-put eww-data :peer (plist-get status :peer))
       ;; Make buffer listings more informative.
       (setq list-buffers-directory url)
       ;; Let the URL library have a handle to the current URL for
@@ -383,6 +386,14 @@ Currently this means either text/html or application/xhtml+xml."
     (unwind-protect
 	(progn
 	  (cond
+           ((url-errorp)
+            (with-current-buffer buffer
+              (let ((inhibit-read-only t))
+                (erase-buffer)
+                (insert (format "Error when fetching '%s':\n%s %s\n"
+                                url (car (url-status 'response))
+                                (cadr (url-status 'response))))
+                (goto-char (point-min)))))
            ((and eww-use-external-browser-for-content-type
                  (string-match-p eww-use-external-browser-for-content-type
                                  (car content-type)))
@@ -408,22 +419,7 @@ Currently this means either text/html or application/xhtml+xml."
 	    (setq eww-history-position 0)
 	    (and last-coding-system-used
 		 (set-buffer-file-coding-system last-coding-system-used))
-	    (run-hooks 'eww-after-render-hook)))
-      (kill-buffer data-buffer))))
-
-(defun eww-parse-headers ()
-  (let ((headers nil))
-    (goto-char (point-min))
-    (while (and (not (eobp))
-		(not (eolp)))
-      (when (looking-at "\\([^:]+\\): *\\(.*\\)")
-	(push (cons (downcase (match-string 1))
-		    (match-string 2))
-	      headers))
-      (forward-line 1))
-    (unless (eobp)
-      (forward-line 1))
-    headers))
+	    (run-hooks 'eww-after-render-hook))))))
 
 (defun eww-detect-charset (html-p)
   (let ((case-fold-search t)
@@ -933,14 +929,17 @@ If LOCAL is non-nil (interactively, the command was invoked with
 a prefix argument), don't reload the page from the network, but
 just re-display the HTML already fetched."
   (interactive "P")
-  (let ((url (plist-get eww-data :url)))
+  (let ((url (plist-get eww-data :url))
+        (point (point))
+        (buffer (current-buffer)))
     (if local
 	(if (null (plist-get eww-data :dom))
 	    (error "No current HTML data")
 	  (eww-display-html 'utf-8 url (plist-get eww-data :dom)
 			    (point) (current-buffer)))
-      (url-retrieve url 'eww-render
-		    (list url (point) (current-buffer) encode)))))
+      (let ((inhibit-read-only t))
+        (erase-buffer)
+        (eww--fetch-url url :point point :buffer buffer :encode encode)))))
 
 ;; Form support.
 
@@ -1400,7 +1399,11 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
   (interactive)
   (let* ((this-input (get-text-property (point) 'eww-form))
 	 (form (plist-get this-input :eww-form))
-	 values next-submit)
+         (url (if (cdr (assq :action form))
+                  (shr-expand-url (cdr (assq :action form))
+                                  (plist-get eww-data :url))
+                (plist-get eww-data :url)))
+         values next-submit)
     (dolist (elem (sort (eww-inputs form)
 			(lambda (o1 o2)
 			  (< (car o1) (car o2)))))
@@ -1443,42 +1446,16 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
 	(push (cons (plist-get (cdr elem) :name)
 		    (or (plist-get (cdr elem) :value) ""))
 	      values)))
-    (if (and (stringp (cdr (assq :method form)))
-	     (equal (downcase (cdr (assq :method form))) "post"))
-	(let ((mtype))
-	  (dolist (x values mtype)
-	    (if (equal (car x) "file")
-		(progn
-		  (setq mtype "multipart/form-data"))))
-	  (cond ((equal mtype "multipart/form-data")
-		 (let ((boundary (mml-compute-boundary '())))
-		   (let ((url-request-method "POST")
-			 (url-request-extra-headers
-			  (list (cons "Content-Type"
-				      (concat "multipart/form-data; boundary="
-					      boundary))))
-			 (url-request-data
-			  (mm-url-encode-multipart-form-data values boundary)))
-		     (eww-browse-url (shr-expand-url
-				      (cdr (assq :action form))
-				      (plist-get eww-data :url))))))
-		(t
-		 (let ((url-request-method "POST")
-		       (url-request-extra-headers
-			'(("Content-Type" .
-			   "application/x-www-form-urlencoded")))
-		       (url-request-data
-			(mm-url-encode-www-form-urlencoded values)))
-		   (eww-browse-url (shr-expand-url
-				    (cdr (assq :action form))
-				    (plist-get eww-data :url)))))))
-      (eww-browse-url
-       (concat
-	(if (cdr (assq :action form))
-	    (shr-expand-url (cdr (assq :action form)) (plist-get eww-data :url))
-	  (plist-get eww-data :url))
-	"?"
-	(mm-url-encode-www-form-urlencoded values))))))
+    (eww-save-history)
+    (let ((inhibit-read-only t))
+      (erase-buffer))
+    (eww--fetch-url
+     url
+     :method (if (cl-equalp (cdr (assq :method form)) "post")
+                 'post
+               'get)
+     :data-encoding 'url-encode
+     :data values)))
 
 (defun eww-browse-with-external-browser (&optional url)
   "Browse the current URL with an external browser.
@@ -1532,20 +1509,17 @@ Differences in #targets are ignored."
   (let ((url (get-text-property (point) 'shr-url)))
     (if (not url)
         (message "No URL under point")
-      (url-retrieve url 'eww-download-callback (list url)))))
-
-(defun eww-download-callback (status url)
-  (unless (plist-get status :error)
-    (let* ((obj (url-generic-parse-url url))
-           (path (car (url-path-and-query obj)))
-           (file (eww-make-unique-file-name
-                  (eww-decode-url-file-name (file-name-nondirectory path))
-                  eww-download-directory)))
-      (goto-char (point-min))
-      (re-search-forward "\r?\n\r?\n")
-      (let ((coding-system-for-write 'no-conversion))
-        (write-region (point) (point-max) file))
-      (message "Saved %s" file))))
+      (with-fetched-url (url)
+        (if (url-errorp)
+            (message "Error while downloading: %s" (url-status 'response))
+          (let* ((obj (url-generic-parse-url url))
+                 (path (car (url-path-and-query obj)))
+                 (file (eww-make-unique-file-name
+                        (eww-decode-url-file-name (file-name-nondirectory path))
+                        eww-download-directory)))
+            (let ((coding-system-for-write 'no-conversion))
+              (write-region (point) (point-max) file))
+            (message "Saved %s" file)))))))
 
 (defun eww-decode-url-file-name (string)
   (let* ((binary (url-unhex-string string))
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index fb17b856f44..da837c5f255 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -39,6 +39,8 @@
 (require 'svg)
 (require 'image)
 (require 'puny)
+(require 'with-url)
+(require 'mail-parse)
 
 (defgroup shr nil
   "Simple HTML Renderer"
@@ -450,13 +452,16 @@ the URL of the image to the kill buffer instead."
 (defun shr-insert-image ()
   "Insert the image under point into the buffer."
   (interactive)
-  (let ((url (get-text-property (point) 'image-url)))
+  (let ((url (get-text-property (point) 'image-url))
+        (buffer (current-buffer))
+        (start (1- (point)))
+        (end (point-marker)))
     (if (not url)
 	(message "No image under point")
       (message "Inserting %s..." url)
-      (url-retrieve url 'shr-image-fetched
-		    (list (current-buffer) (1- (point)) (point-marker))
-		    t t))))
+      (with-fetched-url (url :verbose 0
+                             :cookies nil)
+        (shr-image-fetched buffer start end)))))
 
 (defun shr-zoom-image ()
   "Toggle the image size.
@@ -480,17 +485,19 @@ size, and full-buffer size."
 	(when (> (- (point) start) 2)
 	  (delete-region start (1- (point)))))
       (message "Inserting %s..." url)
-      (url-retrieve url 'shr-image-fetched
-		    (list (current-buffer) (1- (point)) (point-marker)
-			  (list (cons 'size
-				      (cond ((or (eq size 'default)
-						 (null size))
-					     'original)
-					    ((eq size 'original)
-					     'full)
-					    ((eq size 'full)
-					     'default)))))
-		    t))))
+      (let ((buffer (current-buffer))
+            (start (1- (point)))
+            (end (point-marker)))
+        (with-fetched-url (url :verbose 0)
+          (shr-image-fetched buffer start end
+                             (list (cons 'size
+                                         (cond ((or (eq size 'default)
+                                                    (null size))
+                                                'original)
+                                               ((eq size 'original)
+                                                'full)
+                                               ((eq size 'full)
+                                                'default))))))))))
 
 ;;; Utility functions.
 
@@ -991,43 +998,37 @@ the mouse click event."
   (let ((url (get-text-property (point) 'shr-url)))
     (if (not url)
 	(message "No link under point")
-      (url-retrieve (shr-encode-url url)
-		    'shr-store-contents (list url directory)
-		    nil t))))
-
-(defun shr-store-contents (status url directory)
-  (unless (plist-get status :error)
-    (when (or (search-forward "\n\n" nil t)
-	      (search-forward "\r\n\r\n" nil t))
-      (write-region (point) (point-max)
-		    (expand-file-name (file-name-nondirectory url)
-				      directory)))))
-
-(defun shr-image-fetched (status buffer start end &optional flags)
-  (let ((image-buffer (current-buffer)))
-    (when (and (buffer-name buffer)
-	       (not (plist-get status :error)))
-      (url-store-in-cache image-buffer)
-      (goto-char (point-min))
-      (when (or (search-forward "\n\n" nil t)
-		(search-forward "\r\n\r\n" nil t))
-	(let ((data (shr-parse-image-data)))
-	  (with-current-buffer buffer
-	    (save-excursion
-	      (save-restriction
-		(widen)
-		(let ((alt (buffer-substring start end))
-		      (properties (text-properties-at start))
-		      (inhibit-read-only t))
-		  (delete-region start end)
-		  (goto-char start)
-		  (funcall shr-put-image-function data alt flags)
-		  (while properties
-		    (let ((type (pop properties))
-			  (value (pop properties)))
-		      (unless (memq type '(display image-size))
-			(put-text-property start (point) type value)))))))))))
-    (kill-buffer image-buffer)))
+      (with-fetched-url ((shr-encode-url url) :cookies nil)
+        (if (url-errorp)
+            (message "Couldn't fetch URL")
+          (write-region (point) (point-max)
+                        (expand-file-name (file-name-nondirectory url)
+                                          directory)))))))
+
+(defun shr-image-fetched (buffer start end &optional flags)
+  (when (and (buffer-name buffer)
+             (url-okp))
+    (let ((data (shr-parse-image-data
+                 (intern (car
+                          (mail-header-parse-content-type
+                           (or (url-header 'content-type) "text/plain")))
+                         obarray))))
+      (with-current-buffer buffer
+	(with-current-buffer buffer
+	  (save-excursion
+	    (save-restriction
+	      (widen)
+	      (let ((alt (buffer-substring start end))
+		    (properties (text-properties-at start))
+		    (inhibit-read-only t))
+		(delete-region start end)
+		(goto-char start)
+		(funcall shr-put-image-function data alt flags)
+		(while properties
+		  (let ((type (pop properties))
+			(value (pop properties)))
+		    (unless (memq type '(display image-size))
+		      (put-text-property start (point) type value))))))))))))
 
 (defun shr-image-from-data (data)
   "Return an image from the data: URI content DATA."
@@ -1138,36 +1139,13 @@ width/height instead."
          :max-height max-height
          :format content-type)))))
 
-;; url-cache-extract autoloads url-cache.
-(declare-function url-cache-create-filename "url-cache" (url))
-(autoload 'mm-disable-multibyte "mm-util")
 (autoload 'browse-url-mail "browse-url")
 
-(defun shr-get-image-data (url)
-  "Get image data for URL.
-Return a string with image data."
-  (with-temp-buffer
-    (mm-disable-multibyte)
-    (when (ignore-errors
-	    (url-cache-extract (url-cache-create-filename (shr-encode-url url)))
-	    t)
-      (when (re-search-forward "\r?\n\r?\n" nil t)
-	(shr-parse-image-data)))))
-
 (declare-function libxml-parse-xml-region "xml.c"
 		  (start end &optional base-url discard-comments))
 
-(defun shr-parse-image-data ()
-  (let ((data (buffer-substring (point) (point-max)))
-	(content-type
-	 (save-excursion
-	   (save-restriction
-	     (narrow-to-region (point-min) (point))
-	     (let ((content-type (mail-fetch-field "content-type")))
-	       (and content-type
-		    ;; Remove any comments in the type string.
-		    (intern (replace-regexp-in-string ";.*" "" content-type)
-			    obarray)))))))
+(defun shr-parse-image-data (&optional content-type)
+  (let ((data (buffer-substring (point) (point-max))))
     ;; SVG images may contain references to further images that we may
     ;; want to block.  So special-case these by parsing the XML data
     ;; and remove anything that looks like a blocked bit.
@@ -1196,9 +1174,12 @@ START, and END.  Note that START and END should be markers."
 		   (funcall shr-put-image-function
 			    image (buffer-substring start end))
 		   (delete-region (point) end))))
-	 (url-retrieve url 'shr-image-fetched
-		       (list (current-buffer) start end)
-		       t t)))))
+         (let ((buffer (current-buffer))
+               (start (1- (point)))
+               (end (point-marker)))
+           (with-fetched-url (url :verbose 0
+                                  :cookies nil)
+             (shr-image-fetched buffer start end)))))))
 
 (defun shr-heading (dom &rest types)
   (shr-ensure-paragraph)
@@ -1598,20 +1579,27 @@ The preference is a float determined from `shr-prefer-media-type'."
 	  (setq shr-start (point))
           (shr-insert alt))
 	 ((and (not shr-ignore-cache)
-	       (url-is-cached (shr-encode-url url)))
-	  (funcall shr-put-image-function (shr-get-image-data url) alt
-                   (list :width width :height height)))
-	 (t
-	  (when (and shr-ignore-cache
-		     (url-is-cached (shr-encode-url url)))
-	    (let ((file (url-cache-create-filename (shr-encode-url url))))
-	      (when (file-exists-p file)
-		(delete-file file))))
+	       (with-url-cached-p (shr-encode-url url)))
+          (let ((buffer (current-buffer)))
+            (let ((data
+                   (with-fetched-url ((shr-encode-url url)
+                                      :cache t
+                                      :wait t)
+                     (when (url-okp)
+                       (shr-parse-image-data
+                        (intern (car
+                                 (mail-header-parse-content-type
+                                  (or (url-header 'content-type)
+                                      "text/plain")))
+                                obarray))))))
+              (funcall shr-put-image-function data alt
+                       (list :width width :height height)))))
+         (t
           (when (image-type-available-p 'svg)
             (insert-image
              (shr-make-placeholder-image dom)
              (or alt "")))
-          (insert " ")
+          (insert "-")
 	  (url-queue-retrieve
 	   (shr-encode-url url) 'shr-image-fetched
 	   (list (current-buffer) start (set-marker (make-marker) (point))