github/melpa
1
0
Fork 0
mirror of https://github.com/correl/melpa.git synced 2024-11-22 19:18:39 +00:00
Code Issues Projects Releases Packages Wiki Activity

Use a version of url-copy-file which fails when it gets a 500

Browse source 
This was causing error pages to get turned into wiki packages
due to error pages served by the emacswiki. See #2294
This commit is contained in:
Steve Purcell 2014-12-18 21:00:08 +00:00
parent 1e367afce9
commit 2309a41e26
1 changed files with 23 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
package-build.el
View file

@ -264,6 +264,27 @@ seconds; the server cuts off after 10 requests in 20 seconds.")
(progn ,@body)
(setq pb/last-wiki-fetch-time (float-time))))))
(defun package-build-download-url (url newname &optional ok-if-already-exists)
"Copy URL to NEWNAME. Both args must be strings.
Like `url-copy-file', but it produces an error if the http response is not 200.
Signals a `file-already-exists' error if file NEWNAME already exists,
unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
A number as third arg means request confirmation if NEWNAME already exists."
(if (and (file-exists-p newname)
(not ok-if-already-exists))
(error "Opening output file: File already exists, %s" newname))
(let ((buffer (url-retrieve-synchronously url))
(handle nil))
(if (not buffer)
(error "Opening input file: No such file or directory, %s" url))
(with-current-buffer buffer
(unless (= 200 url-http-response-status)
(error "HTTP error %s fetching %s" url-http-response-status url))
(setq handle (mm-dissect-buffer t)))
(mm-save-part-to-file handle newname)
(kill-buffer buffer)
(mm-destroy-parts handle)))
(defun pb/grab-wiki-file (filename)
"Download FILENAME from emacswiki, returning its last-modified time."
(let* ((download-url
@ -271,7 +292,7 @@ seconds; the server cuts off after 10 requests in 20 seconds.")
(wiki-url
(format "http://www.emacswiki.org/emacs/%s" filename)))
(pb/with-wiki-rate-limit
(url-copy-file download-url filename t))
(package-build-download-url download-url filename t))
(when (zerop (nth 7 (file-attributes filename)))
(error "Wiki file %s was empty - has it been removed?" filename))
;; The Last-Modified response header for the download is actually
@ -1123,7 +1144,7 @@ Returns the archive entry for the package."
;; Note also that it would be straightforward to generate the SVG ourselves, which would
;; save the network overhead.
(defun pb/write-melpa-badge-image (package-name version target-dir)
(url-copy-file
(package-build-download-url
(concat "http://img.shields.io/badge/"
(if package-build-stable "melpa stable" "melpa")
"-"