=== modified file 'lisp/subr.el' --- old/lisp/subr.el 2014-01-01 07:43:34 +0000 +++ new/lisp/subr.el 2014-01-03 17:57:14 +0000 @@ -464,6 +464,30 @@ (aset tree i (copy-tree (aref tree i) vecp))) tree) tree))) + +(defun merge-alists (alis1 alis2 keycmp) + "Merges alists ALIS1 and ALIS2, non-destructively, returning + another alist, containing the keys from both ALIS1 and ALIS2, + with values from ALIS2 taking precedence. For efficiency, a + comparision function KEYCMP have to be supplied, the lists will + be sorted and then merged by having two pointers traverse the + two lists simulateneously." + (let ((alist1 (sort (copy-list alis1) keycmp)) + (alist2 (sort (copy-list alis2) keycmp)) + (res (list))) + (while (and alist1 alist2) + (cond ((equal (car (car alist1)) (car (car alist2))) + (push (car alist1) res) + (setq alist1 (cdr alist1)) + (setq alist2 (cdr alist2))) + ((funcall keycmp (car alist1) (car alist2)) + (push (car alist1) res) + (setq alist1 (cdr alist1))) + (t + (push (car alist2) res) + (setq alist2 (cdr alist2))))) + (nconc res alist1 alist2))) + ;;;; Various list-search functions. === modified file 'lisp/url/url-cookie.el' --- old/lisp/url/url-cookie.el 2014-01-01 07:43:34 +0000 +++ new/lisp/url/url-cookie.el 2014-01-03 17:50:08 +0000 @@ -208,6 +208,7 @@ (if retval (concat retval "; " chunk) (concat "Cookie: " chunk))))) + (message (prin1-to-string retval)) (if retval (concat retval "\r\n") ""))) === modified file 'lisp/url/url-http.el' --- old/lisp/url/url-http.el 2014-01-01 07:43:34 +0000 +++ new/lisp/url/url-http.el 2014-01-03 18:04:03 +0000 @@ -209,20 +209,23 @@ (url-http-mark-connection-as-busy host port connection)))) ;; Building an HTTP request -(defun url-http-user-agent-string () +(defun url-http-user-agent () (if (or (eq url-privacy-level 'paranoid) (and (listp url-privacy-level) (memq 'agent url-privacy-level))) - "" - (format "User-Agent: %sURL/%s\r\n" - (if url-package-name - (concat url-package-name "/" url-package-version " ") - "") - url-version))) + '() + `(("User-agent" . + ,(format "%sURL/%s" + (if url-package-name + (concat url-package-name "/" url-package-version " ") + "") + url-version))))) (defun url-http-create-request (&optional ref-url) "Create an HTTP request for `url-http-target-url', referred to by REF-URL." - (let* ((extra-headers) + (let* ((default-headers) + (extra-headers) + (headers-string) (request nil) (no-cache (cdr-safe (assoc "Pragma" url-http-extra-headers))) (using-proxy url-http-proxy) @@ -235,19 +238,13 @@ (url-get-authentication url-http-proxy nil 'any nil)))) (real-fname (url-filename 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)))) + (auth (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"))) ;; Protection against stupid values in the referrer (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil") @@ -260,14 +257,56 @@ (memq 'lastloc url-privacy-level))) (setq ref-url nil)) - ;; url-http-extra-headers contains an assoc-list of - ;; header/value pairs that we need to put into the request. - (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"))) + ;; Default-headers and url-http-extra-headers are both alists of + ;; header/value pairs + (setq default-headers + `(("Connection" . ,(if (or using-proxy + (not url-http-attempt-keepalives)) + "close" "keep-alive")) + ("Host" . ,(if (/= (url-port url-http-target-url) + (url-scheme-get-property + (url-type url-http-target-url) 'default-port)) + (format "%s:%d" host (url-port url-http-target-url)) + host)) + ("MIME-Version" . "1.0") + ("Accept" . ,(or url-mime-accept-string "*/*")) + ,@(when (and (not no-cache) + (member url-http-method '("GET" nil))) + (let ((tm (url-is-cached url-http-target-url))) + (if tm + `(("If-modified-since" . ,(url-get-normalized-date tm)))))) + ,@(when ref-url + `(("Referer" . ,ref-url))) + ,@(when url-personal-mail-address + `(("From" . ,url-personal-mail-address))) + ,@(when url-mime-encoding-string + `(("Accept-encoding" . ,url-mime-encoding-string))) + ,@(when url-mime-charset-string + `(("Accept-charset" . ,url-mime-charset-string))) + ,@(when url-mime-language-string + `(("Accept-language" . ,url-mime-language-string))) + ,@(when auth + `(("Authorization" . ,auth))) + ,@(when proxy-auth + `(("Proxy-Authorization" . ,proxy-auth))) + ,@(when url-http-data + `(("Content-length" . ,(number-to-string (length url-http-data))))) + ,@(when url-extensions-header + `(("Extension" . ,url-extensions-header))) + ,@(url-http-user-agent))) + + ;;; url-http-extra-headers are merged on top default-headers, any + ;;; headers specified in both will be sent as per value in + ;;; url-http-extra-headers + (setq headers-string + (concat + (mapconcat + (lambda (x) + (concat (car x) ": " (cdr x))) + (merge-alists default-headers url-http-extra-headers + (lambda (a b) (string-lessp (car a) (car b)))) + "\r\n") + "\r\n")) ;; This was done with a call to `format'. Concatenating parts has ;; the advantage of keeping the parts of each header together and @@ -287,78 +326,21 @@ 'string-as-unibyte (delq nil (list - ;; The request + ;; The request line (or url-http-method "GET") " " (if using-proxy (url-recreate-url url-http-target-url) real-fname) " HTTP/" url-http-version "\r\n" - ;; Version of MIME we speak - "MIME-Version: 1.0\r\n" - ;; (maybe) Try to keep the connection open - "Connection: " (if (or using-proxy - (not url-http-attempt-keepalives)) - "close" "keep-alive") "\r\n" - ;; HTTP extensions we support - (if url-extensions-header - (format - "Extension: %s\r\n" url-extensions-header)) - ;; Who we want to talk to - (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)) - ;; Who its from - (if url-personal-mail-address - (concat - "From: " url-personal-mail-address "\r\n")) - ;; Encodings we understand - (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")) - ;; Languages we understand - (if url-mime-language-string - (concat - "Accept-language: " url-mime-language-string "\r\n")) - ;; Types we understand - "Accept: " (or url-mime-accept-string "*/*") "\r\n" - ;; User agent - (url-http-user-agent-string) - ;; Proxy Authorization - proxy-auth - ;; Authorization - auth + ;; Headers + headers-string ;; Cookies - (when (url-use-cookies url-http-target-url) - (url-cookie-generate-header-lines - host real-fname - (equal "https" (url-type url-http-target-url)))) - ;; If-modified-since - (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")))) - ;; Whence we came - (if ref-url (concat - "Referer: " ref-url "\r\n")) - extra-headers - ;; Length of data - (if url-http-data - (concat - "Content-length: " (number-to-string - (length url-http-data)) - "\r\n")) - ;; End request + (when (url-use-cookies url-http-target-url) + (url-cookie-generate-header-lines + host real-fname + (equal "https" (url-type url-http-target-url)))) + ;; End of headers "\r\n" - ;; Any data - url-http-data - ;; If `url-http-data' is nil, avoid two CRLFs (Bug#8931). - (if url-http-data "\r\n"))) + ;; Data + url-http-data)) "")) (url-http-debug "Request is: \n%s" request) request)) === added file 'test/automated/url-http-tests.el' --- old/test/automated/url-http-tests.el 1970-01-01 00:00:00 +0000 +++ new/test/automated/url-http-tests.el 2014-01-03 18:06:21 +0000 @@ -0,0 +1,100 @@ +;;; url-http.el --- Test suite for url-http. + +;; Copyright (C) 2011-2014 Free Software Foundation, Inc. + +;; Author: Jarosław Rzeszótko +;; Keywords: data + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'url-future) + +(ert-deftest url-http-create-request/creates-valid-http-get-request () + (let* ((url-http-extra-headers) + (url-http-proxy nil) + (url-http-method "GET") + (url-http-target-url (url-generic-parse-url "http://www.gnu.org/")) + (url-http-data) + (url-package-name "XYZ") + (url-package-version "2.0")) + (with-temp-buffer + (insert (url-http-create-request)) + (goto-char (point-min)) + (should (looking-at "GET / HTTP/1.1\r\n")) + (should (search-forward "Accept: */*\r\n")) + (should (search-forward "Host: www.gnu.org\r\n")) + (should (search-forward "User-agent: XYZ/2.0 URL/Emacs\r\n"))))) + +(ert-deftest url-http-create-request/sends-singleline-http-cookies () + (let* ((url-http-extra-headers) + (url-http-proxy nil) + (url-http-method "GET") + (url-http-target-url (url-generic-parse-url "http://www.url-http-test-host.com/")) + (url-http-data) + (url-cookie-multiple-line nil)) + (setf (url-use-cookies url-http-target-url) t) + (setq url-cookie-storage nil) + (unwind-protect + (progn + (url-cookie-store "test1" "testvalue1testvalue1testvalue1testvalue1testvalue1" nil "www.url-http-test-host.com" "/") + (url-cookie-store "test2" "testvalue2" nil "www.url-http-test-host.com" "/") + (with-temp-buffer + (insert (url-http-create-request)) + (goto-char (point-min)) + (should (search-forward "Cookie: test1=testvalue1testvalue1testvalue1testvalue1testvalue1; test2=testvalue2\r\n")))) + (setq url-cookie-storage nil)))) + +(ert-deftest url-http-create-request/sends-multiline-http-cookies () + (let* ((url-http-extra-headers) + (url-http-proxy nil) + (url-http-method "GET") + (url-http-target-url (url-generic-parse-url "http://www.url-http-test-host.com/")) + (url-http-data) + (url-cookie-multiple-line t) + (cookie-value)) + (setf (url-use-cookies url-http-target-url) t) + (setq url-cookie-storage nil) + (unwind-protect + (progn + (url-cookie-store "test1" "testvalue1testvalue1testvalue1testvalue1testvalue1" nil "www.url-http-test-host.com" "/") + (url-cookie-store "test2" "testvalue2" nil "www.url-http-test-host.com" "/") + (with-temp-buffer + (insert (url-http-create-request)) + (goto-char (point-min)) + (should (search-forward "Cookie: test1=testvalue1testvalue1testvalue1testvalue1testvalue1\r\n")) + (should (search-forward "Cookie: test2=testvalue2\r\n")))) + (setq url-cookie-storage nil)))) + +(ert-deftest url-http-create-request/creates-valid-http-post-request () + (let* ((url-http-extra-headers) + (url-http-proxy nil) + (url-http-method "POST") + (url-http-target-url (url-generic-parse-url "http://www.gnu.org/")) + (url-http-data "test")) + (with-temp-buffer + (insert (url-http-create-request)) + (goto-char (point-min)) + (should (looking-at "POST / HTTP/1.1\r\n")) + (should (search-forward "Accept: */*\r\n")) + (should (search-forward "Content-length: 4\r\n")) + (should (search-forward "Host: www.gnu.org\r\n")) + (goto-char (point-min)) + (should (search-forward "\r\n\r\n")) + (should (search-forward "test")) + (should (equal (point) (point-max))))))