[nongnu] elpa/request ef231e1 06/11: request-response-headers

[ELPA Syncer]

branch: elpa/request
commit ef231e188654495852d408e8ef816289f6e743e0
Author: dickmao <none>
Commit: dickmao <none>

    request-response-headers
---
 Makefile              |  2 ++
 request.el            | 18 +++++++++++++++++-
 tests/test-request.el | 39 +++++++--------------------------------
 3 files changed, 26 insertions(+), 33 deletions(-)

diff --git a/Makefile b/Makefile
index dce02ea..95e964e 100644
--- a/Makefile
+++ b/Makefile
@@ -44,8 +44,10 @@ README.rst: README.in.rst request.el
 
 .PHONY: cask
 cask: $(CASK_DIR)
+
 $(CASK_DIR): Cask
        $(CASK) install
+       touch $(CASK_DIR)
 
 .PHONY: compile
 compile: cask
diff --git a/request.el b/request.el
index 3827e12..0c3f4ba 100644
--- a/request.el
+++ b/request.el
@@ -44,6 +44,7 @@
 (require 'mail-utils)
 (require 'autorevert)
 (require 'auth-source)
+(require 'mailheader)
 
 (defgroup request nil
   "Compatible layer for URL request in Emacs."
@@ -265,6 +266,21 @@ Examples::
 ;;    (see https://tools.ietf.org/html/rfc2616.html#section-4.2).
 ;;    Python's requests module does this too.
 
+(defun request-response-headers (response)
+  "Return RESPONSE headers as an alist.
+I would have chosen a function name that wasn't so suggestive that
+`headers` is a member of the `request-response` struct, but
+as there's already precedent with `request-response-header', I
+hew to consistency."
+  (let ((raw-header (request-response--raw-header response)))
+    (when raw-header
+      raw-header
+      (with-temp-buffer
+        (save-excursion (insert raw-header))
+        (when (save-excursion (request--parse-response-at-point))
+          (forward-line))
+        (mail-header-extract-no-properties)))))
+
 (defconst request--backend-alist
   '((url-retrieve
      . ((request             . request--url-retrieve)
@@ -527,7 +543,7 @@ and requests.request_ (Python).
             (replace-match "")))))))
 
 (defun request--cut-header (response)
-  "Move the first header to the raw-header slot of RESPONSE object."
+  "Move the header to the raw-header slot of RESPONSE object."
   (let ((buffer (request-response--buffer response)))
     (when (buffer-live-p buffer)
       (with-current-buffer buffer
diff --git a/tests/test-request.el b/tests/test-request.el
index d9b532c..e418f76 100644
--- a/tests/test-request.el
+++ b/tests/test-request.el
@@ -22,7 +22,7 @@
 
 ;;; Commentary:
 
-;;
+;; Test stuff.
 
 ;;; Code:
 
@@ -58,10 +58,6 @@
 ;;   (setq request-log-level 'blather)
 ;;   (setq request-log-level -1)
 
-
-
-;;; GET
-
 (request-deftest request-simple-get ()
   (request-testing-with-response-slots
       (request-testing-sync "report/some-path"
@@ -69,7 +65,10 @@
     (should done-p)
     (should (equal status-code 200))
     (should (equal (assoc-default 'path data) "some-path"))
-    (should (equal (assoc-default 'method data) "GET"))))
+    (should (equal (assoc-default 'method data) "GET"))
+    (should (let ((headers (request-response-headers response)))
+              (cl-every (lambda (h) (memq h (mapcar #'car headers)))
+                        '(content-length content-type server))))))
 
 (request-deftest request-get-with-args ()
   (request-testing-with-response-slots
@@ -219,9 +218,6 @@ See also:
    (should (equal (assoc-default 'path data) "some-path"))
    (should (equal (assoc-default 'method data) "GET"))))
 
-
-;;; POST
-
 (request-deftest request-simple-post ()
   (request-testing-with-response-slots
       (request-testing-sync "report/some-path"
@@ -387,9 +383,6 @@ See also:
                    :headers '(("Expect" . "100-continue")))
                   (should (equal status-code 200))))
 
-
-;;; PUT
-
 (defun request-testing-put-simple-1 ()
   (request-testing-with-response-slots
       (request-testing-sync "report/some-path"
@@ -440,9 +433,6 @@ To check that, run test with:
     (should (equal (request-testing-sort-alist (assoc-default 'json data))
                    '((鍵 . "値"))))))
 
-
-;;; DELETE
-
 (request-deftest request-simple-delete ()
   (request-testing-with-response-slots
       (request-testing-sync "report/some-path"
@@ -452,9 +442,6 @@ To check that, run test with:
     (should (equal (assoc-default 'path data) "some-path"))
     (should (equal (assoc-default 'method data) "DELETE"))))
 
-
-;;; Abort
-
 (request-deftest request-abort-simple ()
   (let (called)
     (request-testing-with-response-slots
@@ -490,9 +477,6 @@ To check that, run test with:
       (should error-thrown)
       (should response))))
 
-
-;;; HEAD
-
 (request-deftest request-simple-head ()
   (request-testing-with-response-slots
    (request-testing-sync "longtextline"
@@ -504,9 +488,6 @@ To check that, run test with:
    (let ((server (request-response-header response "server")))
      (should (string-prefix-p request-testing-server-name (downcase 
server))))))
 
-
-;;; Parse error
-
 (request-deftest request-parse-error-simple ()
   (request-testing-with-response-slots
       (request-testing-sync "report/some-path"
@@ -515,9 +496,6 @@ To check that, run test with:
     (should (equal symbol-status 'parse-error))
     (should (equal error-thrown '(error . ("Bad parser!"))))))
 
-
-;;; Cookie
-
 (request-deftest request-simple-cookie ()
   :tempfiles (request--curl-cookie-jar)
   (request-testing-with-response-slots
@@ -588,9 +566,6 @@ To check that, run test with:
   ;; check login state
   (request-testing-assert-username-is nil))
 
-
-;;; Misc
-
 (request-deftest request-invoke-in-non-existing-directory ()
   "Running request in non-existing directory should work.
 Calling `start-process' in non-existing directory fails.  Command
@@ -601,7 +576,7 @@ based backends (e.g., `curl') should avoid this problem."
     ;; Should not fail:
     (request-testing-sync "report/some-path" :parser 'json-read)))
 
-
+
 ;;; Testing framework
 
 (request-deftest request-tfw-server ()
@@ -609,7 +584,7 @@ based backends (e.g., `curl') should avoid this problem."
          (server (request-response-header response "server")))
     (should (string-prefix-p request-testing-server-name (downcase server)))))
 
-
+
 ;;; `request-backend'-independent tests
 
 ;; Following tests does not depend on the value of `request-backend'.