(eval-when-compile (require 'cl))
(defvar url-http-extra-headers)
(defvar url-http-target-url)
(defvar url-http-proxy)
(defvar url-http-connection-opened)
(require 'url-gw)
(require 'url-util)
(require 'url-parse)
(require 'url-cookie)
(require 'mail-parse)
(require 'url-auth)
(require 'url)
(autoload 'url-cache-create-filename "url-cache")
(defconst url-http-default-port 80 "Default HTTP port.")
(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
(defalias 'url-http-expand-file-name 'url-default-expander)
(defvar url-http-real-basic-auth-storage nil)
(defvar url-http-proxy-basic-auth-storage nil)
(defvar url-http-open-connections (make-hash-table :test 'equal
:size 17)
"A hash table of all open network connections.")
(defvar url-http-version "1.1"
"What version of HTTP we advertise, as a string.
Valid values are 1.1 and 1.0.
This is only useful when debugging the HTTP subsystem.
Setting this to 1.0 will tell servers not to send chunked encoding,
and other HTTP/1.1 specific features.")
(defvar url-http-attempt-keepalives t
"Whether to use a single TCP connection multiple times in HTTP.
This is only useful when debugging the HTTP subsystem. Setting to
nil will explicitly close the connection to the server after every
request.")
(defsubst url-http-debug (&rest args)
(if quit-flag
(let ((proc (get-buffer-process (current-buffer))))
(if proc
(progn
(set-process-sentinel proc nil)
(set-process-filter proc nil)))
(error "Transfer interrupted!")))
(apply 'url-debug 'http args))
(defun url-http-mark-connection-as-busy (host port proc)
(url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
(set-process-query-on-exit-flag proc t)
(puthash (cons host port)
(delq proc (gethash (cons host port) url-http-open-connections))
url-http-open-connections)
proc)
(defun url-http-mark-connection-as-free (host port proc)
(url-http-debug "Marking connection as free: %s:%d %S" host port proc)
(when (memq (process-status proc) '(open run connect))
(set-process-buffer proc nil)
(set-process-sentinel proc 'url-http-idle-sentinel)
(set-process-query-on-exit-flag proc nil)
(puthash (cons host port)
(cons proc (gethash (cons host port) url-http-open-connections))
url-http-open-connections))
nil)
(defun url-http-find-free-connection (host port)
(let ((conns (gethash (cons host port) url-http-open-connections))
(found nil))
(while (and conns (not found))
(if (not (memq (process-status (car conns)) '(run open connect)))
(progn
(url-http-debug "Cleaning up dead process: %s:%d %S"
host port (car conns))
(url-http-idle-sentinel (car conns) nil))
(setq found (car conns))
(url-http-debug "Found existing connection: %s:%d %S" host port found))
(pop conns))
(if found
(url-http-debug "Reusing existing connection: %s:%d" host port)
(url-http-debug "Contacting host: %s:%d" host port))
(url-lazy-message "Contacting host: %s:%d" host port)
(url-http-mark-connection-as-busy
host port
(or found
(let ((buf (generate-new-buffer " *url-http-temp*")))
(unwind-protect
(let ((proc (url-open-stream host buf host port)))
(when (processp proc)
(set-process-buffer proc nil))
proc)
(kill-buffer buf)))))))
(defun url-http-user-agent-string ()
(if (or (eq url-privacy-level 'paranoid)
(and (listp url-privacy-level)
(memq 'agent url-privacy-level)))
""
(format "User-Agent: %sURL/%s%s\r\n"
(if url-package-name
(concat url-package-name "/" url-package-version " ")
"")
url-version
(cond
((and url-os-type url-system-type)
(concat " (" url-os-type "; " url-system-type ")"))
((or url-os-type url-system-type)
(concat " (" (or url-system-type url-os-type) ")"))
(t "")))))
(defun url-http-create-request (&optional ref-url)
"Create an HTTP request for `url-http-target-url', referred to by REF-URL."
(declare (special proxy-info
url-http-method url-http-data
url-http-extra-headers))
(let* ((extra-headers)
(request nil)
(no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers)))
(using-proxy url-http-proxy)
(proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
url-http-extra-headers))
(not using-proxy))
nil
(let ((url-basic-auth-storage
'url-http-proxy-basic-auth-storage))
(url-get-authentication url-http-target-url nil 'any nil))))
(real-fname (concat (url-filename url-http-target-url)
(url-recreate-url-attributes url-http-target-url)))
(host (url-host url-http-target-url))
(auth (if (cdr-safe (assoc "Authorization" url-http-extra-headers))
nil
(url-get-authentication (or
(and (boundp 'proxy-info)
proxy-info)
url-http-target-url) nil 'any nil))))
(if (equal "" real-fname)
(setq real-fname "/"))
(setq no-cache (and no-cache (string-match "no-cache" no-cache)))
(if auth
(setq auth (concat "Authorization: " auth "\r\n")))
(if proxy-auth
(setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
(if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
(string= ref-url "")))
(setq ref-url nil))
(if (or (memq url-privacy-level '(low high paranoid))
(and (listp url-privacy-level)
(memq 'lastloc url-privacy-level)))
(setq ref-url nil))
(setq extra-headers (mapconcat
(lambda (x)
(concat (car x) ": " (cdr x)))
url-http-extra-headers "\r\n"))
(if (not (equal extra-headers ""))
(setq extra-headers (concat extra-headers "\r\n")))
(setq request
(mapconcat
'string-as-unibyte
(delq nil
(list
(or url-http-method "GET") " "
(if using-proxy (url-recreate-url url-http-target-url) real-fname)
" HTTP/" url-http-version "\r\n"
"MIME-Version: 1.0\r\n"
"Connection: " (if (or using-proxy
(not url-http-attempt-keepalives))
"close" "keep-alive") "\r\n"
(if url-extensions-header
(format
"Extension: %s\r\n" url-extensions-header))
(if (/= (url-port url-http-target-url)
(url-scheme-get-property
(url-type url-http-target-url) 'default-port))
(format
"Host: %s:%d\r\n" host (url-port url-http-target-url))
(format "Host: %s\r\n" host))
(if url-personal-mail-address
(concat
"From: " url-personal-mail-address "\r\n"))
(if url-mime-encoding-string
(concat
"Accept-encoding: " url-mime-encoding-string "\r\n"))
(if url-mime-charset-string
(concat
"Accept-charset: " url-mime-charset-string "\r\n"))
(if url-mime-language-string
(concat
"Accept-language: " url-mime-language-string "\r\n"))
"Accept: " (or url-mime-accept-string "*/*") "\r\n"
(url-http-user-agent-string)
proxy-auth
auth
(url-cookie-generate-header-lines host real-fname
(equal "https" (url-type url-http-target-url)))
(if (and (not no-cache)
(member url-http-method '("GET" nil)))
(let ((tm (url-is-cached url-http-target-url)))
(if tm
(concat "If-modified-since: "
(url-get-normalized-date tm) "\r\n"))))
(if ref-url (concat
"Referer: " ref-url "\r\n"))
extra-headers
(if url-http-data
(concat
"Content-length: " (number-to-string
(length url-http-data))
"\r\n"))
"\r\n"
url-http-data))
""))
(url-http-debug "Request is: \n%s" request)
request))
(defun url-http-clean-headers ()
"Remove trailing \r from header lines.
This allows us to use `mail-fetch-field', etc."
(declare (special url-http-end-of-headers))
(goto-char (point-min))
(while (re-search-forward "\r$" url-http-end-of-headers t)
(replace-match "")))
(defun url-http-handle-authentication (proxy)
(declare (special status success url-http-method url-http-data
url-callback-function url-callback-arguments))
(url-http-debug "Handling %s authentication" (if proxy "proxy" "normal"))
(let ((auths (or (nreverse
(mail-fetch-field
(if proxy "proxy-authenticate" "www-authenticate")
nil nil t))
'("basic")))
(type nil)
(url (url-recreate-url url-current-object))
(url-basic-auth-storage 'url-http-real-basic-auth-storage)
auth
(strength 0))
(if proxy
(setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage))
(dolist (this-auth auths)
(setq this-auth (url-eat-trailing-space
(url-strip-leading-spaces
this-auth)))
(let* ((this-type
(if (string-match "[ \t]" this-auth)
(downcase (substring this-auth 0 (match-beginning 0)))
(downcase this-auth)))
(registered (url-auth-registered this-type))
(this-strength (cddr registered)))
(when (and registered (> this-strength strength))
(setq auth this-auth
type this-type
strength this-strength))))
(if (not (url-auth-registered type))
(progn
(widen)
(goto-char (point-max))
(insert "<hr>Sorry, but I do not know how to handle " type
" authentication. If you'd like to write it,"
" send it to " url-bug-address ".<hr>")
(setq status t))
(let* ((args (url-parse-args (subst-char-in-string ?, ?\ (auth (url-get-authentication url (cdr-safe (assoc "realm" args))
type t args)))
(if (not auth)
(setq success t)
(push (cons (if proxy "Proxy-Authorization" "Authorization") auth)
url-http-extra-headers)
(let ((url-request-method url-http-method)
(url-request-data url-http-data)
(url-request-extra-headers url-http-extra-headers))
(url-retrieve-internal url url-callback-function
url-callback-arguments)))))))
(defun url-http-parse-response ()
"Parse just the response code."
(declare (special url-http-end-of-headers url-http-response-status
url-http-response-version))
(if (not url-http-end-of-headers)
(error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name)))
(url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
(goto-char (point-min))
(skip-chars-forward " \t\n") (skip-chars-forward "HTTP/") (setq url-http-response-version
(buffer-substring (point)
(progn
(skip-chars-forward "[0-9].")
(point))))
(setq url-http-response-status (read (current-buffer))))
(defun url-http-handle-cookies ()
"Handle all set-cookie / set-cookie2 headers in an HTTP response.
The buffer must already be narrowed to the headers, so `mail-fetch-field' will
work correctly."
(let ((cookies (nreverse (mail-fetch-field "Set-Cookie" nil nil t)))
(cookies2 (nreverse (mail-fetch-field "Set-Cookie2" nil nil t))))
(and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies)))
(and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2)))
(while cookies
(url-cookie-handle-set-cookie (pop cookies)))
)
)
(defun url-http-parse-headers ()
"Parse and handle HTTP specific headers.
Return t if and only if the current buffer is still active and
should be shown to the user."
(declare (special url-http-end-of-headers url-http-response-status
url-http-response-version
url-http-method url-http-data url-http-process
url-callback-function url-callback-arguments))
(url-http-mark-connection-as-free (url-host url-current-object)
(url-port url-current-object)
url-http-process)
(if (or (not (boundp 'url-http-end-of-headers))
(not url-http-end-of-headers))
(error "Trying to parse headers in odd buffer: %s" (buffer-name)))
(goto-char (point-min))
(url-http-debug "url-http-parse-headers called in (%s)" (buffer-name))
(url-http-parse-response)
(mail-narrow-to-head)
(let ((connection (mail-fetch-field "Connection")))
(cond
((string= url-http-response-version "1.0")
(unless (and connection
(string= (downcase connection) "keep-alive"))
(delete-process url-http-process)))
(t
(when (and connection
(string= (downcase connection) "close"))
(delete-process url-http-process)))))
(let ((class nil)
(success nil))
(setq class (/ url-http-response-status 100))
(url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
(url-http-handle-cookies)
(case class
(1 (url-mark-buffer-as-dead (current-buffer))
(error "HTTP responses in class 1xx not supported (%d)" url-http-response-status))
(2 (case url-http-response-status
((204 205)
(url-mark-buffer-as-dead (current-buffer))
(setq success t))
(otherwise
(widen)
(if (and url-automatic-caching (equal url-http-method "GET"))
(url-store-in-cache (current-buffer)))
(setq success t))))
(3 (let ((redirect-uri (or (mail-fetch-field "Location")
(mail-fetch-field "URI"))))
(case url-http-response-status
(300
nil)
((301 302 307)
(if (member url-http-method '("HEAD" "GET"))
nil
(url-http-debug "Converting `%s' request to `GET' because of REDIRECT(%d)"
url-http-method url-http-response-status)
(setq url-http-method "GET"
url-http-data nil)))
(303
(setq url-http-method "GET"
url-http-data nil))
(304
(url-http-debug "Extracting document from cache... (%s)"
(url-cache-create-filename (url-view-url t)))
(url-cache-extract (url-cache-create-filename (url-view-url t)))
(setq redirect-uri nil
success t))
(305
(error "Redirection thru a proxy server not supported: %s"
redirect-uri))
(otherwise
nil))
(when redirect-uri
(if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
(setq redirect-uri (match-string 1 redirect-uri)))
(if (string-match "^<\\(.*\\)>$" redirect-uri)
(setq redirect-uri (match-string 1 redirect-uri)))
(if (not (string-match url-nonrelative-link redirect-uri))
(setq redirect-uri
(url-expand-file-name redirect-uri url-http-target-url)))
(let ((url-request-method url-http-method)
(url-request-data url-http-data)
(url-request-extra-headers url-http-extra-headers))
(if (or (< url-max-redirections 0)
(and (> url-max-redirections 0)
(let ((events (car url-callback-arguments))
(old-redirects 0))
(while events
(if (eq (car events) :redirect)
(setq old-redirects (1+ old-redirects)))
(and (setq events (cdr events))
(setq events (cdr events))))
(< old-redirects url-max-redirections))))
(progn
(setf (car url-callback-arguments)
(nconc (list :redirect redirect-uri)
(car url-callback-arguments)))
(set (make-local-variable 'url-redirect-buffer)
(url-retrieve-internal
redirect-uri url-callback-function
url-callback-arguments))
(url-mark-buffer-as-dead (current-buffer)))
(url-http-debug "Maximum redirections reached")
(setf (car url-callback-arguments)
(nconc (list :error (list 'error 'http-redirect-limit
redirect-uri))
(car url-callback-arguments)))
(setq success t))))))
(4 (case url-http-response-status
(401
(url-http-handle-authentication nil))
(402
(url-mark-buffer-as-dead (current-buffer))
(error "Somebody wants you to give them money"))
(403
(setq success t))
(404
(setq success t))
(405
(setq success t))
(406
(setq success t))
(407
(url-http-handle-authentication t))
(408
(setq success t))
(409
(setq success t))
(410
(setq success t))
(411
(setq success t))
(412
(setq success t))
((413 414)
(setq success t))
(415
(setq success t))
(416
(setq success t))
(417
(setq success t))
(otherwise
(setq success t)))
(when success
(setf (car url-callback-arguments)
(nconc (list :error (list 'error 'http url-http-response-status))
(car url-callback-arguments)))))
(5
(setq success t)
(case url-http-response-status
(501
nil)
(502
nil)
(503
nil)
(504
nil)
(505
nil)
(507 nil))
(when success
(setf (car url-callback-arguments)
(nconc (list :error (list 'error 'http url-http-response-status))
(car url-callback-arguments)))))
(otherwise
(error "Unknown class of HTTP response code: %d (%d)"
class url-http-response-status)))
(if (not success)
(url-mark-buffer-as-dead (current-buffer)))
(url-http-debug "Finished parsing HTTP headers: %S" success)
(widen)
success))
(defun url-http-activate-callback ()
"Activate callback specified when this buffer was created."
(declare (special url-http-process
url-callback-function
url-callback-arguments))
(url-http-mark-connection-as-free (url-host url-current-object)
(url-port url-current-object)
url-http-process)
(url-http-debug "Activating callback in buffer (%s)" (buffer-name))
(apply url-callback-function url-callback-arguments))
(defun url-http-idle-sentinel (proc why)
"Remove this (now defunct) process PROC from the list of open connections."
(maphash (lambda (key val)
(if (memq proc val)
(puthash key (delq proc val) url-http-open-connections)))
url-http-open-connections))
(defun url-http-end-of-document-sentinel (proc why)
(url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
(process-buffer proc))
(url-http-idle-sentinel proc why)
(with-current-buffer (process-buffer proc)
(goto-char (point-min))
(if (not (looking-at "HTTP/"))
(url-http-activate-callback)
(if (url-http-parse-headers)
(url-http-activate-callback)))))
(defun url-http-simple-after-change-function (st nd length)
(declare (special url-http-end-of-headers))
(url-lazy-message "Reading %s..." (url-pretty-length nd)))
(defun url-http-content-length-after-change-function (st nd length)
"Function used when we DO know how long the document is going to be.
More sophisticated percentage downloaded, etc.
Also does minimal parsing of HTTP headers and will actually cause
the callback to be triggered."
(declare (special url-current-object
url-http-end-of-headers
url-http-content-length
url-http-content-type
url-http-process))
(if url-http-content-type
(url-display-percentage
"Reading [%s]... %s of %s (%d%%)"
(url-percentage (- nd url-http-end-of-headers)
url-http-content-length)
url-http-content-type
(url-pretty-length (- nd url-http-end-of-headers))
(url-pretty-length url-http-content-length)
(url-percentage (- nd url-http-end-of-headers)
url-http-content-length))
(url-display-percentage
"Reading... %s of %s (%d%%)"
(url-percentage (- nd url-http-end-of-headers)
url-http-content-length)
(url-pretty-length (- nd url-http-end-of-headers))
(url-pretty-length url-http-content-length)
(url-percentage (- nd url-http-end-of-headers)
url-http-content-length)))
(if (> (- nd url-http-end-of-headers) url-http-content-length)
(progn
(url-display-percentage nil nil)
(url-lazy-message "Reading... done.")
(if (url-http-parse-headers)
(url-http-activate-callback)))))
(defun url-http-chunked-encoding-after-change-function (st nd length)
"Function used when dealing with 'chunked' encoding.
Cannot give a sophisticated percentage, but we need a different
function to look for the special 0-length chunk that signifies
the end of the document."
(declare (special url-current-object
url-http-end-of-headers
url-http-content-type
url-http-chunked-length
url-http-chunked-counter
url-http-process url-http-chunked-start))
(save-excursion
(goto-char st)
(let ((read-next-chunk t)
(case-fold-search t)
(regexp nil)
(no-initial-crlf nil))
(while read-next-chunk
(setq no-initial-crlf (= 0 url-http-chunked-counter))
(if url-http-content-type
(url-display-percentage nil
"Reading [%s]... chunk #%d"
url-http-content-type url-http-chunked-counter)
(url-display-percentage nil
"Reading... chunk #%d"
url-http-chunked-counter))
(url-http-debug "Reading chunk %d (%d %d %d)"
url-http-chunked-counter st nd length)
(setq regexp (if no-initial-crlf
"\\([0-9a-z]+\\).*\r?\n"
"\r?\n\\([0-9a-z]+\\).*\r?\n"))
(if url-http-chunked-start
(if (> nd (+ url-http-chunked-start url-http-chunked-length))
(progn
(url-http-debug "Got to the end of chunk #%d!"
url-http-chunked-counter)
(goto-char (+ url-http-chunked-start
url-http-chunked-length)))
(url-http-debug "Still need %d bytes to hit end of chunk"
(- (+ url-http-chunked-start
url-http-chunked-length)
nd))
(setq read-next-chunk nil)))
(if (not read-next-chunk)
(url-http-debug "Still spinning for next chunk...")
(if no-initial-crlf (skip-chars-forward "\r\n"))
(if (not (looking-at regexp))
(progn
(url-http-debug "Did not see start of chunk @ %d!" (point))
(setq read-next-chunk nil))
(add-text-properties (match-beginning 0) (match-end 0)
(list 'start-open t
'end-open t
'chunked-encoding t
'face 'cursor
'invisible t))
(setq url-http-chunked-length (string-to-number (buffer-substring
(match-beginning 1)
(match-end 1))
16)
url-http-chunked-counter (1+ url-http-chunked-counter)
url-http-chunked-start (set-marker
(or url-http-chunked-start
(make-marker))
(match-end 0)))
(delete-region (match-beginning 0) (match-end 0)) (url-http-debug "Saw start of chunk %d (length=%d, start=%d"
url-http-chunked-counter url-http-chunked-length
(marker-position url-http-chunked-start))
(if (= 0 url-http-chunked-length)
(progn
(url-http-debug "Saw end of stream chunk!")
(setq read-next-chunk nil)
(url-display-percentage nil nil)
(goto-char (match-end 1))
(if (re-search-forward "^\r*$" nil t)
(url-http-debug "Saw end of trailers..."))
(if (url-http-parse-headers)
(url-http-activate-callback))))))))))
(defun url-http-wait-for-headers-change-function (st nd length)
(declare (special url-current-object
url-http-end-of-headers
url-http-content-type
url-http-content-length
url-http-transfer-encoding
url-callback-function
url-callback-arguments
url-http-process
url-http-method
url-http-after-change-function
url-http-response-status))
(url-http-debug "url-http-wait-for-headers-change-function (%s)"
(buffer-name))
(when (not (bobp))
(let ((end-of-headers nil)
(old-http nil)
(content-length nil))
(goto-char (point-min))
(if (and (looking-at ".*\n") (not (looking-at "^HTTP/[1-9]\\.[0-9]")))
(setq end-of-headers t
url-http-end-of-headers 0
old-http t)
(when (re-search-forward "^\r*$" nil t)
(url-http-debug "Saw end of headers... (%s)" (buffer-name))
(setq url-http-end-of-headers (set-marker (make-marker)
(point))
end-of-headers t)
(url-http-clean-headers)))
(if (not end-of-headers)
nil
(if old-http
(message "HTTP/0.9 How I hate thee!")
(progn
(url-http-parse-response)
(mail-narrow-to-head)
(setq url-http-transfer-encoding (mail-fetch-field
"transfer-encoding")
url-http-content-type (mail-fetch-field "content-type"))
(if (mail-fetch-field "content-length")
(setq url-http-content-length
(string-to-number (mail-fetch-field "content-length"))))
(widen)))
(when url-http-transfer-encoding
(setq url-http-transfer-encoding
(downcase url-http-transfer-encoding)))
(cond
((or (= url-http-response-status 204)
(= url-http-response-status 205))
(url-http-debug "%d response must have headers only (%s)."
url-http-response-status (buffer-name))
(when (url-http-parse-headers)
(url-http-activate-callback)))
((string= "HEAD" url-http-method)
(url-http-debug "HEAD request must have headers only (%s)."
(buffer-name))
(when (url-http-parse-headers)
(url-http-activate-callback)))
((string= "CONNECT" url-http-method)
(url-http-debug "CONNECT request must have headers only.")
(when (url-http-parse-headers)
(url-http-activate-callback)))
((equal url-http-response-status 304)
(when (url-http-parse-headers)
(url-http-activate-callback)))
(old-http
(url-http-debug
"Saw HTTP/0.9 response, connection closed means end of document.")
(setq url-http-after-change-function
'url-http-simple-after-change-function))
((equal url-http-transfer-encoding "chunked")
(url-http-debug "Saw chunked encoding.")
(setq url-http-after-change-function
'url-http-chunked-encoding-after-change-function)
(when (> nd url-http-end-of-headers)
(url-http-debug
"Calling initial chunked-encoding for extra data at end of headers")
(url-http-chunked-encoding-after-change-function
(marker-position url-http-end-of-headers) nd
(- nd url-http-end-of-headers))))
((integerp url-http-content-length)
(url-http-debug
"Got a content-length, being smart about document end.")
(setq url-http-after-change-function
'url-http-content-length-after-change-function)
(cond
((= 0 url-http-content-length)
(url-http-debug
"Got 0-length content-length, activating callback immediately.")
(when (url-http-parse-headers)
(url-http-activate-callback)))
((> nd url-http-end-of-headers)
(url-http-debug "Calling initial content-length for extra data at end of headers")
(url-http-content-length-after-change-function
(marker-position url-http-end-of-headers)
nd
(- nd url-http-end-of-headers)))
(t
nil)))
(t
(url-http-debug "No content-length, being dumb.")
(setq url-http-after-change-function
'url-http-simple-after-change-function)))))
(url-http-debug "Spinning waiting for headers..."))
(goto-char (point-max)))
(defun url-http (url callback cbargs)
"Retrieve URL via HTTP asynchronously.
URL must be a parsed URL. See `url-generic-parse-url' for details.
When retrieval is completed, the function CALLBACK is executed with
CBARGS as the arguments."
(check-type url vector "Need a pre-parsed URL.")
(declare (special url-current-object
url-http-end-of-headers
url-http-content-type
url-http-content-length
url-http-transfer-encoding
url-http-after-change-function
url-callback-function
url-callback-arguments
url-http-method
url-http-extra-headers
url-http-data
url-http-chunked-length
url-http-chunked-start
url-http-chunked-counter
url-http-process))
(let* ((host (url-host (or url-using-proxy url)))
(port (url-port (or url-using-proxy url)))
(connection (url-http-find-free-connection host port))
(buffer (generate-new-buffer (format " *http %s:%d*" host port))))
(if (not connection)
(progn
(kill-buffer buffer)
(setq buffer nil)
(error "Could not create connection to %s:%d" host port))
(with-current-buffer buffer
(mm-disable-multibyte)
(setq url-current-object url
mode-line-format "%b [%s]")
(dolist (var '(url-http-end-of-headers
url-http-content-type
url-http-content-length
url-http-transfer-encoding
url-http-after-change-function
url-http-response-version
url-http-response-status
url-http-chunked-length
url-http-chunked-counter
url-http-chunked-start
url-callback-function
url-callback-arguments
url-http-process
url-http-method
url-http-extra-headers
url-http-data
url-http-target-url
url-http-connection-opened
url-http-proxy))
(set (make-local-variable var) nil))
(setq url-http-method (or url-request-method "GET")
url-http-extra-headers url-request-extra-headers
url-http-data url-request-data
url-http-process connection
url-http-chunked-length nil
url-http-chunked-start nil
url-http-chunked-counter 0
url-callback-function callback
url-callback-arguments cbargs
url-http-after-change-function 'url-http-wait-for-headers-change-function
url-http-target-url url-current-object
url-http-connection-opened nil
url-http-proxy url-using-proxy)
(set-process-buffer connection buffer)
(set-process-filter connection 'url-http-generic-filter)
(let ((status (process-status connection)))
(cond
((eq status 'connect)
(set-process-sentinel connection 'url-http-async-sentinel))
((eq status 'failed)
(error "Could not create connection to %s:%d" host port))
(t
(set-process-sentinel connection 'url-http-end-of-document-sentinel)
(process-send-string connection (url-http-create-request)))))))
buffer))
(defun url-http-async-sentinel (proc why)
(declare (special url-callback-arguments))
(with-current-buffer (process-buffer proc)
(cond
(url-http-connection-opened
(url-http-end-of-document-sentinel proc why))
((string= (substring why 0 4) "open")
(setq url-http-connection-opened t)
(process-send-string proc (url-http-create-request)))
(t
(setf (car url-callback-arguments)
(nconc (list :error (list 'error 'connection-failed why
:host (url-host (or url-http-proxy url-current-object))
:service (url-port (or url-http-proxy url-current-object))))
(car url-callback-arguments)))
(url-http-activate-callback)))))
(defun url-http-generic-filter (proc data)
(declare (special url-http-after-change-function))
(and (process-buffer proc)
(/= (length data) 0)
(with-current-buffer (process-buffer proc)
(url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc)
(funcall url-http-after-change-function
(point-max)
(progn
(goto-char (point-max))
(insert data)
(point-max))
(length data)))))
(defalias 'url-http-symbol-value-in-buffer
(if (fboundp 'symbol-value-in-buffer)
'symbol-value-in-buffer
(lambda (symbol buffer &optional unbound-value)
"Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
(with-current-buffer buffer
(if (not (boundp symbol))
unbound-value
(symbol-value symbol))))))
(defun url-http-head (url)
(let ((url-request-method "HEAD")
(url-request-data nil))
(url-retrieve-synchronously url)))
(defun url-http-file-exists-p (url)
(let ((status nil)
(exists nil)
(buffer (url-http-head url)))
(if (not buffer)
(setq exists nil)
(setq status (url-http-symbol-value-in-buffer 'url-http-response-status
buffer 500)
exists (and (integerp status)
(>= status 200) (< status 300)))
(kill-buffer buffer))
exists))
(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
(defun url-http-head-file-attributes (url &optional id-format)
(let ((buffer (url-http-head url)))
(when buffer
(prog1
(list
nil 1 0 0 nil nil nil (url-http-symbol-value-in-buffer 'url-http-content-length
buffer -1)
(eval-when-compile (make-string 10 ?-))
nil nil nil) (kill-buffer buffer)))))
(defun url-http-file-attributes (url &optional id-format)
(if (url-dav-supported-p url)
(url-dav-file-attributes url id-format)
(url-http-head-file-attributes url id-format)))
(defun url-http-options (url)
"Return a property list describing options available for URL.
This list is retrieved using the `OPTIONS' HTTP method.
Property list members:
methods
A list of symbols specifying what HTTP methods the resource
supports.
dav
A list of numbers specifying what DAV protocol/schema versions are
supported.
dasl
A list of supported DASL search types supported (string form)
ranges
A list of the units available for use in partial document fetches.
p3p
The `Platform For Privacy Protection' description for the resource.
Currently this is just the raw header contents. This is likely to
change once P3P is formally supported by the URL package or
Emacs/W3."
(let* ((url-request-method "OPTIONS")
(url-request-data nil)
(buffer (url-retrieve-synchronously url))
(header nil)
(options nil))
(when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer
'url-http-response-status buffer 0) 100)))
(with-current-buffer buffer
(save-restriction
(save-match-data
(mail-narrow-to-head)
(when (setq header (mail-fetch-field "allow"))
(setq options (plist-put
options 'methods
(mapcar 'intern (split-string header "[ ,]+")))))
(when (setq header (mail-fetch-field "dav"))
(setq options (plist-put
options 'dav
(delq 0
(mapcar 'string-to-number
(split-string header "[, ]+"))))))
(when (setq header (mail-fetch-field "dasl"))
(setq options (plist-put
options 'dasl
(split-string header "[, ]+"))))
(when (setq header (mail-fetch-field "p3p"))
(setq options (plist-put options 'p3p header)))
(when (setq header (mail-fetch-field "accept-ranges"))
(setq options (plist-put
options 'ranges
(delq 'none
(mapcar 'intern
(split-string header "[, ]+"))))))
))))
(if buffer (kill-buffer buffer))
options))
(require 'tls)
(defconst url-https-default-port 443 "Default HTTPS port.")
(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
(defalias 'url-https-expand-file-name 'url-http-expand-file-name)
(defmacro url-https-create-secure-wrapper (method args)
`(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args
,(format "HTTPS wrapper around `%s' call." (or method "url-http"))
(let ((url-gateway-method 'tls))
(,(intern (format (if method "url-http-%s" "url-http") method))
,@(remove '&rest (remove '&optional args))))))
(url-https-create-secure-wrapper nil (url callback cbargs))
(url-https-create-secure-wrapper file-exists-p (url))
(url-https-create-secure-wrapper file-readable-p (url))
(url-https-create-secure-wrapper file-attributes (url &optional id-format))
(provide 'url-http)