+++ /dev/null
-;;; request.el --- Compatible layer for URL request in Emacs -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2012 Takafumi Arakaki
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
-;; Free Software Foundation, Inc.
-
-;; Author: Takafumi Arakaki <aka.tkf at gmail.com>
-;; Package-Requires: ((emacs "24") (cl-lib "0.5"))
-;; Package-Version: 20160822.1659
-;; Version: 0.2.0
-
-;; This file is NOT part of GNU Emacs.
-
-;; request.el 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.
-
-;; request.el 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 request.el.
-;; If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Request.el is a HTTP request library with multiple backends. It
-;; supports url.el which is shipped with Emacs and curl command line
-;; program. User can use curl when s/he has it, as curl is more reliable
-;; than url.el. Library author can use request.el to avoid imposing
-;; external dependencies such as curl to users while giving richer
-;; experience for users who have curl.
-
-;; Following functions are adapted from GNU Emacs source code.
-;; Free Software Foundation holds the copyright of them.
-;; * `request--process-live-p'
-;; * `request--url-default-expander'
-
-;;; Code:
-
-(eval-when-compile
- (defvar url-http-method)
- (defvar url-http-response-status))
-
-(require 'cl-lib)
-(require 'url)
-(require 'mail-utils)
-
-(defgroup request nil
- "Compatible layer for URL request in Emacs."
- :group 'comm
- :prefix "request-")
-
-(defconst request-version "0.2.0")
-
-\f
-;;; Customize variables
-
-(defcustom request-storage-directory
- (concat (file-name-as-directory user-emacs-directory) "request")
- "Directory to store data related to request.el."
- :type 'directory)
-
-(defcustom request-curl "curl"
- "Executable for curl command."
- :type 'string)
-
-(defcustom request-backend (if (executable-find request-curl)
- 'curl
- 'url-retrieve)
- "Backend to be used for HTTP request.
-Automatically set to `curl' if curl command is found."
- :type '(choice (const :tag "cURL backend" curl)
- (const :tag "url-retrieve backend" url-retrieve)))
-
-(defcustom request-timeout nil
- "Default request timeout in second.
-`nil' means no timeout."
- :type '(choice (integer :tag "Request timeout seconds")
- (boolean :tag "No timeout" nil)))
-
-(defcustom request-log-level -1
- "Logging level for request.
-One of `error'/`warn'/`info'/`verbose'/`debug'.
--1 means no logging."
- :type '(choice (integer :tag "No logging" -1)
- (const :tag "Level error" error)
- (const :tag "Level warn" warn)
- (const :tag "Level info" info)
- (const :tag "Level Verbose" verbose)
- (const :tag "Level DEBUG" debug)))
-
-(defcustom request-message-level 'warn
- "Logging level for request.
-See `request-log-level'."
- :type '(choice (integer :tag "No logging" -1)
- (const :tag "Level error" error)
- (const :tag "Level warn" warn)
- (const :tag "Level info" info)
- (const :tag "Level Verbose" verbose)
- (const :tag "Level DEBUG" debug)))
-
-\f
-;;; Utilities
-
-(defun request--safe-apply (function &rest arguments)
- (condition-case err
- (apply #'apply function arguments)
- ((debug error))))
-
-(defun request--safe-call (function &rest arguments)
- (request--safe-apply function arguments))
-
-;; (defun request--url-no-cache (url)
-;; "Imitate `cache=false' of `jQuery.ajax'.
-;; See: http://api.jquery.com/jQuery.ajax/"
-;; ;; FIXME: parse URL before adding ?_=TIME.
-;; (concat url (format-time-string "?_=%s")))
-
-(defmacro request--document-function (function docstring)
- "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
- (declare (indent defun)
- (doc-string 2))
- `(put ',function 'function-documentation ,docstring))
-
-(defun request--process-live-p (process)
- "Copied from `process-live-p' for backward compatibility (Emacs < 24).
-Adapted from lisp/subr.el.
-FSF holds the copyright of this function:
- Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
- Free Software Foundation, Inc."
- (memq (process-status process) '(run open listen connect stop)))
-
-\f
-;;; Logging
-
-(defconst request--log-level-def
- '(;; debugging
- (blather . 60) (trace . 50) (debug . 40)
- ;; information
- (verbose . 30) (info . 20)
- ;; errors
- (warn . 10) (error . 0))
- "Named logging levels.")
-
-(defun request--log-level-as-int (level)
- (if (integerp level)
- level
- (or (cdr (assq level request--log-level-def))
- 0)))
-
-(defvar request-log-buffer-name " *request-log*")
-
-(defun request--log-buffer ()
- (get-buffer-create request-log-buffer-name))
-
-(defmacro request-log (level fmt &rest args)
- (declare (indent 1))
- `(let ((level (request--log-level-as-int ,level))
- (log-level (request--log-level-as-int request-log-level))
- (msg-level (request--log-level-as-int request-message-level)))
- (when (<= level (max log-level msg-level))
- (let ((msg (format "[%s] %s" ,level
- (condition-case err
- (format ,fmt ,@args)
- (error (format "
-!!! Logging error while executing:
-%S
-!!! Error:
-%S"
- ',args err))))))
- (when (<= level log-level)
- (with-current-buffer (request--log-buffer)
- (setq buffer-read-only t)
- (let ((inhibit-read-only t))
- (goto-char (point-max))
- (insert msg "\n"))))
- (when (<= level msg-level)
- (message "REQUEST %s" msg))))))
-
-\f
-;;; HTTP specific utilities
-
-(defconst request--url-unreserved-chars
- '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
- ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
- ?- ?_ ?. ?~)
- "`url-unreserved-chars' copied from Emacs 24.3 release candidate.
-This is used for making `request--urlencode-alist' RFC 3986 compliant
-for older Emacs versions.")
-
-(defun request--urlencode-alist (alist)
- ;; FIXME: make monkey patching `url-unreserved-chars' optional
- (let ((url-unreserved-chars request--url-unreserved-chars))
- (cl-loop for sep = "" then "&"
- for (k . v) in alist
- concat sep
- concat (url-hexify-string (format "%s" k))
- concat "="
- concat (url-hexify-string (format "%s" v)))))
-
-\f
-;;; Header parser
-
-(defun request--parse-response-at-point ()
- "Parse the first header line such as \"HTTP/1.1 200 OK\"."
- (when (re-search-forward "\\=[ \t\n]*HTTP/\\([0-9\\.]+\\) +\\([0-9]+\\)" nil t)
- (list :version (match-string 1)
- :code (string-to-number (match-string 2)))))
-
-(defun request--goto-next-body ()
- (re-search-forward "^\r\n"))
-
-\f
-;;; Response object
-
-(cl-defstruct request-response
- "A structure holding all relevant information of a request."
- status-code history data error-thrown symbol-status url
- done-p settings
- ;; internal variables
- -buffer -raw-header -timer -backend -tempfiles)
-
-(defmacro request--document-response (function docstring)
- (declare (indent defun)
- (doc-string 2))
- `(request--document-function ,function ,(concat docstring "
-
-.. This is an accessor for `request-response' object.
-
-\(fn RESPONSE)")))
-
-(request--document-response request-response-status-code
- "Integer HTTP response code (e.g., 200).")
-
-(request--document-response request-response-history
- "Redirection history (a list of response object).
-The first element is the oldest redirection.
-
-You can use restricted portion of functions for the response
-objects in the history slot. It also depends on backend. Here
-is the table showing what functions you can use for the response
-objects in the history slot.
-
-==================================== ============== ==============
-Slots Backends
------------------------------------- -----------------------------
-\\ curl url-retrieve
-==================================== ============== ==============
-request-response-url yes yes
-request-response-header yes no
-other functions no no
-==================================== ============== ==============
-")
-
-(request--document-response request-response-data
- "Response parsed by the given parser.")
-
-(request--document-response request-response-error-thrown
- "Error thrown during request.
-It takes the form of ``(ERROR-SYMBOL . DATA)``, which can be
-re-raised (`signal'ed) by ``(signal ERROR-SYMBOL DATA)``.")
-
-(request--document-response request-response-symbol-status
- "A symbol representing the status of request (not HTTP response code).
-One of success/error/timeout/abort/parse-error.")
-
-(request--document-response request-response-url
- "Final URL location of response.")
-
-(request--document-response request-response-done-p
- "Return t when the request is finished or aborted.")
-
-(request--document-response request-response-settings
- "Keyword arguments passed to `request' function.
-Some arguments such as HEADERS is changed to the one actually
-passed to the backend. Also, it has additional keywords such
-as URL which is the requested URL.")
-
-(defun request-response-header (response field-name)
- "Fetch the values of RESPONSE header field named FIELD-NAME.
-
-It returns comma separated values when the header has multiple
-field with the same name, as :RFC:`2616` specifies.
-
-Examples::
-
- (request-response-header response
- \"content-type\") ; => \"text/html; charset=utf-8\"
- (request-response-header response
- \"unknown-field\") ; => nil
-"
- (let ((raw-header (request-response--raw-header response)))
- (when raw-header
- (with-temp-buffer
- (erase-buffer)
- (insert raw-header)
- ;; ALL=t to fetch all fields with the same name to get comma
- ;; separated value [#rfc2616-sec4]_.
- (mail-fetch-field field-name nil t)))))
-;; .. [#rfc2616-sec4] RFC2616 says this is the right thing to do
-;; (see http://tools.ietf.org/html/rfc2616.html#section-4.2).
-;; Python's requests module does this too.
-
-\f
-;;; Backend dispatcher
-
-(defconst request--backend-alist
- '((url-retrieve
- . ((request . request--url-retrieve)
- (request-sync . request--url-retrieve-sync)
- (terminate-process . delete-process)
- (get-cookies . request--url-retrieve-get-cookies)))
- (curl
- . ((request . request--curl)
- (request-sync . request--curl-sync)
- (terminate-process . interrupt-process)
- (get-cookies . request--curl-get-cookies))))
- "Map backend and method name to actual method (symbol).
-
-It's alist of alist, of the following form::
-
- ((BACKEND . ((METHOD . FUNCTION) ...)) ...)
-
-It would be nicer if I can use EIEIO. But as CEDET is included
-in Emacs by 23.2, using EIEIO means abandon older Emacs versions.
-It is probably necessary if I need to support more backends. But
-let's stick to manual dispatch for now.")
-;; See: (view-emacs-news "23.2")
-
-(defun request--choose-backend (method)
- "Return `fucall'able object for METHOD of current `request-backend'."
- (assoc-default
- method
- (or (assoc-default request-backend request--backend-alist)
- (error "%S is not valid `request-backend'." request-backend))))
-
-\f
-;;; Cookie
-
-(defun request-cookie-string (host &optional localpart secure)
- "Return cookie string (like `document.cookie').
-
-Example::
-
- (request-cookie-string \"127.0.0.1\" \"/\") ; => \"key=value; key2=value2\"
-"
- (mapconcat (lambda (nv) (concat (car nv) "=" (cdr nv)))
- (request-cookie-alist host localpart secure)
- "; "))
-
-(defun request-cookie-alist (host &optional localpart secure)
- "Return cookies as an alist.
-
-Example::
-
- (request-cookie-alist \"127.0.0.1\" \"/\") ; => ((\"key\" . \"value\") ...)
-"
- (funcall (request--choose-backend 'get-cookies) host localpart secure))
-
-\f
-;;; Main
-
-(cl-defun request-default-error-callback (url &key symbol-status
- &allow-other-keys)
- (request-log 'error
- "Error (%s) while connecting to %s." symbol-status url))
-
-(cl-defun request (url &rest settings
- &key
- (type "GET")
- (params nil)
- (data nil)
- (files nil)
- (parser nil)
- (headers nil)
- (success nil)
- (error nil)
- (complete nil)
- (timeout request-timeout)
- (status-code nil)
- (sync nil)
- (response (make-request-response))
- (unix-socket nil))
- "Send request to URL.
-
-Request.el has a single entry point. It is `request'.
-
-==================== ========================================================
-Keyword argument Explanation
-==================== ========================================================
-TYPE (string) type of request to make: POST/GET/PUT/DELETE
-PARAMS (alist) set \"?key=val\" part in URL
-DATA (string/alist) data to be sent to the server
-FILES (alist) files to be sent to the server (see below)
-PARSER (symbol) a function that reads current buffer and return data
-HEADERS (alist) additional headers to send with the request
-SUCCESS (function) called on success
-ERROR (function) called on error
-COMPLETE (function) called on both success and error
-TIMEOUT (number) timeout in second
-STATUS-CODE (alist) map status code (int) to callback
-SYNC (bool) If `t', wait until request is done. Default is `nil'.
-==================== ========================================================
-
-
-* Callback functions
-
-Callback functions STATUS, ERROR, COMPLETE and `cdr's in element of
-the alist STATUS-CODE take same keyword arguments listed below. For
-forward compatibility, these functions must ignore unused keyword
-arguments (i.e., it's better to use `&allow-other-keys' [#]_).::
-
- (CALLBACK ; SUCCESS/ERROR/COMPLETE/STATUS-CODE
- :data data ; whatever PARSER function returns, or nil
- :error-thrown error-thrown ; (ERROR-SYMBOL . DATA), or nil
- :symbol-status symbol-status ; success/error/timeout/abort/parse-error
- :response response ; request-response object
- ...)
-
-.. [#] `&allow-other-keys' is a special \"markers\" available in macros
- in the CL library for function definition such as `cl-defun' and
- `cl-function'. Without this marker, you need to specify all arguments
- to be passed. This becomes problem when request.el adds new arguments
- when calling callback functions. If you use `&allow-other-keys'
- (or manually ignore other arguments), your code is free from this
- problem. See info node `(cl) Argument Lists' for more information.
-
-Arguments data, error-thrown, symbol-status can be accessed by
-`request-response-data', `request-response-error-thrown',
-`request-response-symbol-status' accessors, i.e.::
-
- (request-response-data RESPONSE) ; same as data
-
-Response object holds other information which can be accessed by
-the following accessors:
-`request-response-status-code',
-`request-response-url' and
-`request-response-settings'
-
-* STATUS-CODE callback
-
-STATUS-CODE is an alist of the following format::
-
- ((N-1 . CALLBACK-1)
- (N-2 . CALLBACK-2)
- ...)
-
-Here, N-1, N-2,... are integer status codes such as 200.
-
-
-* FILES
-
-FILES is an alist of the following format::
-
- ((NAME-1 . FILE-1)
- (NAME-2 . FILE-2)
- ...)
-
-where FILE-N is a list of the form::
-
- (FILENAME &key PATH BUFFER STRING MIME-TYPE)
-
-FILE-N can also be a string (path to the file) or a buffer object.
-In that case, FILENAME is set to the file name or buffer name.
-
-Example FILES argument::
-
- `((\"passwd\" . \"/etc/passwd\") ; filename = passwd
- (\"scratch\" . ,(get-buffer \"*scratch*\")) ; filename = *scratch*
- (\"passwd2\" . (\"password.txt\" :file \"/etc/passwd\"))
- (\"scratch2\" . (\"scratch.txt\" :buffer ,(get-buffer \"*scratch*\")))
- (\"data\" . (\"data.csv\" :data \"1,2,3\\n4,5,6\\n\")))
-
-.. note:: FILES is implemented only for curl backend for now.
- As furl.el_ supports multipart POST, it should be possible to
- support FILES in pure elisp by making furl.el_ another backend.
- Contributions are welcome.
-
- .. _furl.el: http://code.google.com/p/furl-el/
-
-
-* PARSER function
-
-PARSER function takes no argument and it is executed in the
-buffer with HTTP response body. The current position in the HTTP
-response buffer is at the beginning of the buffer. As the HTTP
-header is stripped off, the cursor is actually at the beginning
-of the response body. So, for example, you can pass `json-read'
-to parse JSON object in the buffer. To fetch whole response as a
-string, pass `buffer-string'.
-
-When using `json-read', it is useful to know that the returned
-type can be modified by `json-object-type', `json-array-type',
-`json-key-type', `json-false' and `json-null'. See docstring of
-each function for what it does. For example, to convert JSON
-objects to plist instead of alist, wrap `json-read' by `lambda'
-like this.::
-
- (request
- \"http://...\"
- :parser (lambda ()
- (let ((json-object-type 'plist))
- (json-read)))
- ...)
-
-This is analogous to the `dataType' argument of jQuery.ajax_.
-Only this function can access to the process buffer, which
-is killed immediately after the execution of this function.
-
-* SYNC
-
-Synchronous request is functional, but *please* don't use it
-other than testing or debugging. Emacs users have better things
-to do rather than waiting for HTTP request. If you want a better
-way to write callback chains, use `request-deferred'.
-
-If you can't avoid using it (e.g., you are inside of some hook
-which must return some value), make sure to set TIMEOUT to
-relatively small value.
-
-Due to limitation of `url-retrieve-synchronously', response slots
-`request-response-error-thrown', `request-response-history' and
-`request-response-url' are unknown (always `nil') when using
-synchronous request with `url-retrieve' backend.
-
-* Note
-
-API of `request' is somewhat mixture of jQuery.ajax_ (Javascript)
-and requests.request_ (Python).
-
-.. _jQuery.ajax: http://api.jquery.com/jQuery.ajax/
-.. _requests.request: http://docs.python-requests.org
-"
- (request-log 'debug "REQUEST")
- ;; FIXME: support CACHE argument (if possible)
- ;; (unless cache
- ;; (setq url (request--url-no-cache url)))
- (unless error
- (setq error (apply-partially #'request-default-error-callback url))
- (setq settings (plist-put settings :error error)))
- (unless (or (stringp data)
- (null data)
- (assoc-string "Content-Type" headers t))
- (setq data (request--urlencode-alist data))
- (setq settings (plist-put settings :data data)))
- (when params
- (cl-assert (listp params) nil "PARAMS must be an alist. Given: %S" params)
- (setq url (concat url (if (string-match-p "\\?" url) "&" "?")
- (request--urlencode-alist params))))
- (setq settings (plist-put settings :url url))
- (setq settings (plist-put settings :response response))
- (setf (request-response-settings response) settings)
- (setf (request-response-url response) url)
- (setf (request-response--backend response) request-backend)
- ;; Call `request--url-retrieve'(`-sync') or `request--curl'(`-sync').
- (apply (if sync
- (request--choose-backend 'request-sync)
- (request--choose-backend 'request))
- url settings)
- (when timeout
- (request-log 'debug "Start timer: timeout=%s sec" timeout)
- (setf (request-response--timer response)
- (run-at-time timeout nil
- #'request-response--timeout-callback response)))
- response)
-
-(defun request--clean-header (response)
- "Strip off carriage returns in the header of REQUEST."
- (request-log 'debug "-CLEAN-HEADER")
- (let ((buffer (request-response--buffer response))
- (backend (request-response--backend response))
- sep-regexp)
- (if (eq backend 'url-retrieve)
- ;; FIXME: make this workaround optional.
- ;; But it looks like sometimes `url-http-clean-headers'
- ;; fails to cleanup. So, let's be bit permissive here...
- (setq sep-regexp "^\r?$")
- (setq sep-regexp "^\r$"))
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (request-log 'trace
- "(buffer-string) at %S =\n%s" buffer (buffer-string))
- (goto-char (point-min))
- (when (and (re-search-forward sep-regexp nil t)
- ;; Are \r characters stripped off already?:
- (not (equal (match-string 0) "")))
- (while (re-search-backward "\r$" (point-min) t)
- (replace-match "")))))))
-
-(defun request--cut-header (response)
- "Cut the first header part in the buffer of RESPONSE and move it to
-raw-header slot."
- (request-log 'debug "-CUT-HEADER")
- (let ((buffer (request-response--buffer response)))
- (when (buffer-live-p buffer)
- (with-current-buffer buffer
- (goto-char (point-min))
- (when (re-search-forward "^$" nil t)
- (setf (request-response--raw-header response)
- (buffer-substring (point-min) (point)))
- (delete-region (point-min) (min (1+ (point)) (point-max))))))))
-
-(defun request--parse-data (response parser)
- "Run PARSER in current buffer if ERROR-THROWN is nil,
-then kill the current buffer."
- (request-log 'debug "-PARSE-DATA")
- (let ((buffer (request-response--buffer response)))
- (request-log 'debug "parser = %s" parser)
- (when (and (buffer-live-p buffer) parser)
- (with-current-buffer buffer
- (request-log 'trace
- "(buffer-string) at %S =\n%s" buffer (buffer-string))
- (goto-char (point-min))
- (setf (request-response-data response) (funcall parser))))))
-
-(cl-defun request--callback (buffer &key parser success error complete
- timeout status-code response
- &allow-other-keys)
- (request-log 'debug "REQUEST--CALLBACK")
- (request-log 'debug "(buffer-string) =\n%s"
- (when (buffer-live-p buffer)
- (with-current-buffer buffer (buffer-string))))
-
- ;; Sometimes BUFFER given as the argument is different from the
- ;; buffer already set in RESPONSE. That's why it is reset here.
- ;; FIXME: Refactor how BUFFER is passed around.
- (setf (request-response--buffer response) buffer)
- (request-response--cancel-timer response)
- (cl-symbol-macrolet
- ((error-thrown (request-response-error-thrown response))
- (symbol-status (request-response-symbol-status response))
- (data (request-response-data response))
- (done-p (request-response-done-p response)))
-
- ;; Parse response header
- (request--clean-header response)
- (request--cut-header response)
- ;; Note: Try to do this even `error-thrown' is set. For example,
- ;; timeout error can occur while downloading response body and
- ;; header is there in that case.
-
- ;; Parse response body
- (request-log 'debug "error-thrown = %S" error-thrown)
- (condition-case err
- (request--parse-data response parser)
- (error
- ;; If there was already an error (e.g. server timeout) do not set the
- ;; status to `parse-error'.
- (unless error-thrown
- (setq symbol-status 'parse-error)
- (setq error-thrown err)
- (request-log 'error "Error from parser %S: %S" parser err))))
- (kill-buffer buffer)
- (request-log 'debug "data = %s" data)
-
- ;; Determine `symbol-status'
- (unless symbol-status
- (setq symbol-status (if error-thrown 'error 'success)))
- (request-log 'debug "symbol-status = %s" symbol-status)
-
- ;; Call callbacks
- (let ((args (list :data data
- :symbol-status symbol-status
- :error-thrown error-thrown
- :response response)))
- (let* ((success-p (eq symbol-status 'success))
- (cb (if success-p success error))
- (name (if success-p "success" "error")))
- (when cb
- (request-log 'debug "Executing %s callback." name)
- (request--safe-apply cb args)))
-
- (let ((cb (cdr (assq (request-response-status-code response)
- status-code))))
- (when cb
- (request-log 'debug "Executing status-code callback.")
- (request--safe-apply cb args)))
-
- (when complete
- (request-log 'debug "Executing complete callback.")
- (request--safe-apply complete args)))
-
- (setq done-p t)
-
- ;; Remove temporary files
- ;; FIXME: Make tempfile cleanup more reliable. It is possible
- ;; callback is never called.
- (request--safe-delete-files (request-response--tempfiles response))))
-
-(cl-defun request-response--timeout-callback (response)
- (request-log 'debug "-TIMEOUT-CALLBACK")
- (setf (request-response-symbol-status response) 'timeout)
- (setf (request-response-error-thrown response) '(error . ("Timeout")))
- (let* ((buffer (request-response--buffer response))
- (proc (and (buffer-live-p buffer) (get-buffer-process buffer))))
- (when proc
- ;; This will call `request--callback':
- (funcall (request--choose-backend 'terminate-process) proc))
-
- (cl-symbol-macrolet ((done-p (request-response-done-p response)))
- (unless done-p
- ;; This code should never be executed. However, it occurs
- ;; sometimes with `url-retrieve' backend.
- ;; FIXME: In Emacs 24.3.50 or later, this is always executed in
- ;; request-get-timeout test. Find out if it is fine.
- (request-log 'error "Callback is not called when stopping process! \
-Explicitly calling from timer.")
- (when (buffer-live-p buffer)
- (cl-destructuring-bind (&key code &allow-other-keys)
- (with-current-buffer buffer
- (goto-char (point-min))
- (request--parse-response-at-point))
- (setf (request-response-status-code response) code)))
- (apply #'request--callback
- buffer
- (request-response-settings response))
- (setq done-p t)))))
-
-(defun request-response--cancel-timer (response)
- (request-log 'debug "REQUEST-RESPONSE--CANCEL-TIMER")
- (cl-symbol-macrolet ((timer (request-response--timer response)))
- (when timer
- (cancel-timer timer)
- (setq timer nil))))
-
-
-(defun request-abort (response)
- "Abort request for RESPONSE (the object returned by `request').
-Note that this function invoke ERROR and COMPLETE callbacks.
-Callbacks may not be called immediately but called later when
-associated process is exited."
- (cl-symbol-macrolet ((buffer (request-response--buffer response))
- (symbol-status (request-response-symbol-status response))
- (done-p (request-response-done-p response)))
- (let ((process (get-buffer-process buffer)))
- (unless symbol-status ; should I use done-p here?
- (setq symbol-status 'abort)
- (setq done-p t)
- (when (and
- (processp process) ; process can be nil when buffer is killed
- (request--process-live-p process))
- (funcall (request--choose-backend 'terminate-process) process))))))
-
-\f
-;;; Backend: `url-retrieve'
-
-(cl-defun request--url-retrieve-preprocess-settings
- (&rest settings &key type data files headers &allow-other-keys)
- (when files
- (error "`url-retrieve' backend does not support FILES."))
- (when (and (equal type "POST")
- data
- (not (assoc-string "Content-Type" headers t)))
- (push '("Content-Type" . "application/x-www-form-urlencoded") headers)
- (setq settings (plist-put settings :headers headers)))
- settings)
-
-(cl-defun request--url-retrieve (url &rest settings
- &key type data timeout response
- &allow-other-keys
- &aux headers)
- (setq settings (apply #'request--url-retrieve-preprocess-settings settings))
- (setq headers (plist-get settings :headers))
- (let* ((url-request-extra-headers headers)
- (url-request-method type)
- (url-request-data data)
- (buffer (url-retrieve url #'request--url-retrieve-callback
- (nconc (list :response response) settings)))
- (proc (get-buffer-process buffer)))
- (setf (request-response--buffer response) buffer)
- (process-put proc :request-response response)
- (request-log 'debug "Start querying: %s" url)
- (set-process-query-on-exit-flag proc nil)))
-
-(cl-defun request--url-retrieve-callback (status &rest settings
- &key response url
- &allow-other-keys)
- (declare (special url-http-method
- url-http-response-status))
- (request-log 'debug "-URL-RETRIEVE-CALLBACK")
- (request-log 'debug "status = %S" status)
- (request-log 'debug "url-http-method = %s" url-http-method)
- (request-log 'debug "url-http-response-status = %s" url-http-response-status)
-
- (setf (request-response-status-code response) url-http-response-status)
- (let ((redirect (plist-get status :redirect)))
- (when redirect
- (setf (request-response-url response) redirect)))
- ;; Construct history slot
- (cl-loop for v in
- (cl-loop with first = t
- with l = nil
- for (k v) on status by 'cddr
- when (eq k :redirect)
- if first
- do (setq first nil)
- else
- do (push v l)
- finally do (cons url l))
- do (let ((r (make-request-response :-backend 'url-retrieve)))
- (setf (request-response-url r) v)
- (push r (request-response-history response))))
-
- (cl-symbol-macrolet ((error-thrown (request-response-error-thrown response))
- (status-error (plist-get status :error)))
- (when (and error-thrown status-error)
- (request-log 'warn
- "Error %S thrown already but got another error %S from \
-`url-retrieve'. Ignoring it..." error-thrown status-error))
- (unless error-thrown
- (setq error-thrown status-error)))
-
- (apply #'request--callback (current-buffer) settings))
-
-(cl-defun request--url-retrieve-sync (url &rest settings
- &key type data timeout response
- &allow-other-keys
- &aux headers)
- (setq settings (apply #'request--url-retrieve-preprocess-settings settings))
- (setq headers (plist-get settings :headers))
- (let* ((url-request-extra-headers headers)
- (url-request-method type)
- (url-request-data data)
- (buffer (if timeout
- (with-timeout
- (timeout
- (setf (request-response-symbol-status response)
- 'timeout)
- (setf (request-response-done-p response) t)
- nil)
- (url-retrieve-synchronously url))
- (url-retrieve-synchronously url))))
- (setf (request-response--buffer response) buffer)
- ;; It seems there is no way to get redirects and URL here...
- (when buffer
- ;; Fetch HTTP response code
- (with-current-buffer buffer
- (goto-char (point-min))
- (cl-destructuring-bind (&key version code)
- (request--parse-response-at-point)
- (setf (request-response-status-code response) code)))
- ;; Parse response body, etc.
- (apply #'request--callback buffer settings)))
- response)
-
-(defun request--url-retrieve-get-cookies (host localpart secure)
- (mapcar
- (lambda (c) (cons (url-cookie-name c) (url-cookie-value c)))
- (url-cookie-retrieve host localpart secure)))
-
-\f
-;;; Backend: curl
-
-(defvar request--curl-cookie-jar nil
- "Override what the function `request--curl-cookie-jar' returns.
-Currently it is used only for testing.")
-
-(defun request--curl-cookie-jar ()
- "Cookie storage for curl backend."
- (or request--curl-cookie-jar
- (expand-file-name "curl-cookie-jar" request-storage-directory)))
-
-(defconst request--curl-write-out-template
- (if (eq system-type 'windows-nt)
- "\\n(:num-redirects %{num_redirects} :url-effective %{url_effective})"
- "\\n(:num-redirects %{num_redirects} :url-effective \"%{url_effective}\")"))
-
-(defun request--curl-mkdir-for-cookie-jar ()
- (ignore-errors
- (make-directory (file-name-directory (request--curl-cookie-jar)) t)))
-
-(cl-defun request--curl-command
- (url &key type data headers timeout files* unix-socket
- &allow-other-keys
- &aux
- (cookie-jar (convert-standard-filename
- (expand-file-name (request--curl-cookie-jar)))))
- (append
- (list request-curl "--silent" "--include"
- "--location"
- ;; FIXME: test automatic decompression
- "--compressed"
- ;; FIMXE: this way of using cookie might be problem when
- ;; running multiple requests.
- "--cookie" cookie-jar "--cookie-jar" cookie-jar
- "--write-out" request--curl-write-out-template)
- (when unix-socket (list "--unix-socket" unix-socket))
- (cl-loop for (name filename path mime-type) in files*
- collect "--form"
- collect (format "%s=@%s;filename=%s%s" name path filename
- (if mime-type
- (format ";type=%s" mime-type)
- "")))
- (when data (list "--data-binary" "@-"))
- (when type (list "--request" type))
- (cl-loop for (k . v) in headers
- collect "--header"
- collect (format "%s: %s" k v))
- (list url)))
-
-(defun request--curl-normalize-files-1 (files get-temp-file)
- (cl-loop for (name . item) in files
- collect
- (cl-destructuring-bind
- (filename &key file buffer data mime-type)
- (cond
- ((stringp item) (list (file-name-nondirectory item) :file item))
- ((bufferp item) (list (buffer-name item) :buffer item))
- (t item))
- (unless (= (cl-loop for v in (list file buffer data) if v sum 1) 1)
- (error "Only one of :file/:buffer/:data must be given. Got: %S"
- (cons name item)))
- (cond
- (file
- (list name filename file mime-type))
- (buffer
- (let ((tf (funcall get-temp-file)))
- (with-current-buffer buffer
- (write-region (point-min) (point-max) tf nil 'silent))
- (list name filename tf mime-type)))
- (data
- (let ((tf (funcall get-temp-file)))
- (with-temp-buffer
- (erase-buffer)
- (insert data)
- (write-region (point-min) (point-max) tf nil 'silent))
- (list name filename tf mime-type)))))))
-
-(defun request--curl-normalize-files (files)
- "Change FILES into a list of (NAME FILENAME PATH MIME-TYPE).
-This is to make `request--curl-command' cleaner by converting
-FILES to a homogeneous list. It returns a list (FILES* TEMPFILES)
-where FILES* is a converted FILES and TEMPFILES is a list of
-temporary file paths."
- (let (tempfiles noerror)
- (unwind-protect
- (let* ((get-temp-file (lambda ()
- (let ((tf (make-temp-file "emacs-request-")))
- (push tf tempfiles)
- tf)))
- (files* (request--curl-normalize-files-1 files get-temp-file)))
- (setq noerror t)
- (list files* tempfiles))
- (unless noerror
- ;; Remove temporary files only when an error occurs
- (request--safe-delete-files tempfiles)))))
-
-(defun request--safe-delete-files (files)
- "Remove FILES but do not raise error when failed to do so."
- (mapc (lambda (f) (condition-case err
- (delete-file f)
- (error (request-log 'error
- "Failed delete file %s. Got: %S" f err))))
- files))
-
-(cl-defun request--curl (url &rest settings
- &key type data files headers timeout response
- &allow-other-keys)
- "cURL-based request backend.
-
-Redirection handling strategy
------------------------------
-
-curl follows redirection when --location is given. However,
-all headers are printed when it is used with --include option.
-Number of redirects is printed out sexp-based message using
---write-out option (see `request--curl-write-out-template').
-This number is used for removing extra headers and parse
-location header from the last redirection header.
-
-Sexp at the end of buffer and extra headers for redirects are
-removed from the buffer before it is shown to the parser function.
-"
- (request--curl-mkdir-for-cookie-jar)
- (let* (;; Use pipe instead of pty. Otherwise, curl process hangs.
- (process-connection-type nil)
- ;; Avoid starting program in non-existing directory.
- (home-directory (if (file-remote-p default-directory)
- (with-parsed-tramp-file-name default-directory nil
- (tramp-make-tramp-file-name method user host "~/"))
- "~/"))
- (default-directory (expand-file-name home-directory))
- (buffer (generate-new-buffer " *request curl*"))
- (command (cl-destructuring-bind
- (files* tempfiles)
- (request--curl-normalize-files files)
- (setf (request-response--tempfiles response) tempfiles)
- (apply #'request--curl-command url :files* files*
- settings)))
- (proc (apply #'start-file-process "request curl" buffer command)))
- (request-log 'debug "Run: %s" (mapconcat 'identity command " "))
- (setf (request-response--buffer response) buffer)
- (process-put proc :request-response response)
- (set-process-coding-system proc 'binary 'binary)
- (set-process-query-on-exit-flag proc nil)
- (set-process-sentinel proc #'request--curl-callback)
- (when data
- (process-send-string proc data)
- (process-send-eof proc))))
-
-(defun request--curl-read-and-delete-tail-info ()
- "Read a sexp at the end of buffer and remove it and preceding character.
-This function moves the point at the end of buffer by side effect.
-See also `request--curl-write-out-template'."
- (let (forward-sexp-function)
- (goto-char (point-max))
- (forward-sexp -1)
- (let ((beg (1- (point))))
- (prog1
- (read (current-buffer))
- (delete-region beg (point-max))))))
-
-(defconst request--cookie-reserved-re
- (mapconcat
- (lambda (x) (concat "\\(^" x "\\'\\)"))
- '("comment" "commenturl" "discard" "domain" "max-age" "path" "port"
- "secure" "version" "expires")
- "\\|")
- "Uninterested keys in cookie.
-See \"set-cookie-av\" in http://www.ietf.org/rfc/rfc2965.txt")
-
-(defun request--consume-100-continue ()
- "Remove \"HTTP/* 100 Continue\" header at the point."
- (cl-destructuring-bind (&key code &allow-other-keys)
- (save-excursion (request--parse-response-at-point))
- (when (equal code 100)
- (delete-region (point) (progn (request--goto-next-body) (point)))
- ;; FIXME: Does this make sense? Is it possible to have multiple 100?
- (request--consume-100-continue))))
-
-(defun request--consume-200-connection-established ()
- "Remove \"HTTP/* 200 Connection established\" header at the point."
- (when (looking-at-p "HTTP/1\\.0 200 Connection established")
- (delete-region (point) (progn (request--goto-next-body) (point)))))
-
-(defun request--curl-preprocess ()
- "Pre-process current buffer before showing it to user."
- (let (history)
- (cl-destructuring-bind (&key num-redirects url-effective)
- (request--curl-read-and-delete-tail-info)
- (goto-char (point-min))
- (request--consume-100-continue)
- (request--consume-200-connection-established)
- (when (> num-redirects 0)
- (cl-loop with case-fold-search = t
- repeat num-redirects
- ;; Do not store code=100 headers:
- do (request--consume-100-continue)
- do (let ((response (make-request-response
- :-buffer (current-buffer)
- :-backend 'curl)))
- (request--clean-header response)
- (request--cut-header response)
- (push response history))))
-
- (goto-char (point-min))
- (nconc (list :num-redirects num-redirects :url-effective url-effective
- :history (nreverse history))
- (request--parse-response-at-point)))))
-
-(defun request--curl-absolutify-redirects (start-url redirects)
- "Convert relative paths in REDIRECTS to absolute URLs.
-START-URL is the URL requested."
- (cl-loop for prev-url = start-url then url
- for url in redirects
- unless (string-match url-nonrelative-link url)
- do (setq url (url-expand-file-name url prev-url))
- collect url))
-
-(defun request--curl-absolutify-location-history (start-url history)
- "Convert relative paths in HISTORY to absolute URLs.
-START-URL is the URL requested."
- (when history
- (setf (request-response-url (car history)) start-url))
- (cl-loop for url in (request--curl-absolutify-redirects
- start-url
- (mapcar (lambda (response)
- (request-response-header response "location"))
- history))
- for response in (cdr history)
- do (setf (request-response-url response) url)))
-
-(defun request--curl-callback (proc event)
- (let* ((buffer (process-buffer proc))
- (response (process-get proc :request-response))
- (symbol-status (request-response-symbol-status response))
- (settings (request-response-settings response)))
- (request-log 'debug "REQUEST--CURL-CALLBACK event = %s" event)
- (request-log 'debug "REQUEST--CURL-CALLBACK proc = %S" proc)
- (request-log 'debug "REQUEST--CURL-CALLBACK buffer = %S" buffer)
- (request-log 'debug "REQUEST--CURL-CALLBACK symbol-status = %S"
- symbol-status)
- (cond
- ((and (memq (process-status proc) '(exit signal))
- (/= (process-exit-status proc) 0))
- (setf (request-response-error-thrown response) (cons 'error event))
- (apply #'request--callback buffer settings))
- ((equal event "finished\n")
- (cl-destructuring-bind (&key version code num-redirects history error
- url-effective)
- (condition-case err
- (with-current-buffer buffer
- (request--curl-preprocess))
- ((debug error)
- (list :error err)))
- (request--curl-absolutify-location-history (plist-get settings :url)
- history)
- (setf (request-response-status-code response) code)
- (setf (request-response-url response) url-effective)
- (setf (request-response-history response) history)
- (setf (request-response-error-thrown response)
- (or error (when (>= code 400) `(error . (http ,code)))))
- (apply #'request--callback buffer settings))))))
-
-(cl-defun request--curl-sync (url &rest settings &key response &allow-other-keys)
- ;; To make timeout work, use polling approach rather than using
- ;; `call-process'.
- (let (finished)
- (prog1 (apply #'request--curl url
- :complete (lambda (&rest _) (setq finished t))
- settings)
- (let ((proc (get-buffer-process (request-response--buffer response))))
- (while (and (not finished) (request--process-live-p proc))
- (accept-process-output proc))))))
-
-(defun request--curl-get-cookies (host localpart secure)
- (request--netscape-get-cookies (request--curl-cookie-jar)
- host localpart secure))
-
-\f
-;;; Netscape cookie.txt parser
-
-(defun request--netscape-cookie-parse ()
- "Parse Netscape/Mozilla cookie format."
- (goto-char (point-min))
- (let ((tsv-re (concat "^\\="
- (cl-loop repeat 6 concat "\\([^\t\n]+\\)\t")
- "\\(.*\\)"))
- cookies)
- (while
- (and
- (cond
- ((re-search-forward "^\\=#" nil t))
- ((re-search-forward "^\\=$" nil t))
- ((re-search-forward tsv-re)
- (push (cl-loop for i from 1 to 7 collect (match-string i))
- cookies)
- t))
- (= (forward-line 1) 0)
- (not (= (point) (point-max)))))
- (setq cookies (nreverse cookies))
- (cl-loop for (domain flag path secure expiration name value) in cookies
- collect (list domain
- (equal flag "TRUE")
- path
- (equal secure "TRUE")
- (string-to-number expiration)
- name
- value))))
-
-(defun request--netscape-filter-cookies (cookies host localpart secure)
- (cl-loop for (domain flag path secure-1 expiration name value) in cookies
- when (and (equal domain host)
- (equal path localpart)
- (or secure (not secure-1)))
- collect (cons name value)))
-
-(defun request--netscape-get-cookies (filename host localpart secure)
- (when (file-readable-p filename)
- (with-temp-buffer
- (erase-buffer)
- (insert-file-contents filename)
- (request--netscape-filter-cookies (request--netscape-cookie-parse)
- host localpart secure))))
-
-\f
-;;; Monkey patches for url.el
-
-(defun request--url-default-expander (urlobj defobj)
- "Adapted from lisp/url/url-expand.el.
-FSF holds the copyright of this function:
- Copyright (C) 1999, 2004-2012 Free Software Foundation, Inc."
- ;; The default expansion routine - urlobj is modified by side effect!
- (if (url-type urlobj)
- ;; Well, they told us the scheme, let's just go with it.
- nil
- (setf (url-type urlobj) (or (url-type urlobj) (url-type defobj)))
- (setf (url-port urlobj) (or (url-portspec urlobj)
- (and (string= (url-type urlobj)
- (url-type defobj))
- (url-port defobj))))
- (if (not (string= "file" (url-type urlobj)))
- (setf (url-host urlobj) (or (url-host urlobj) (url-host defobj))))
- (if (string= "ftp" (url-type urlobj))
- (setf (url-user urlobj) (or (url-user urlobj) (url-user defobj))))
- (if (string= (url-filename urlobj) "")
- (setf (url-filename urlobj) "/"))
- ;; If the object we're expanding from is full, then we are now
- ;; full.
- (unless (url-fullness urlobj)
- (setf (url-fullness urlobj) (url-fullness defobj)))
- (if (string-match "^/" (url-filename urlobj))
- nil
- (let ((query nil)
- (file nil)
- (sepchar nil))
- (if (string-match "[?#]" (url-filename urlobj))
- (setq query (substring (url-filename urlobj) (match-end 0))
- file (substring (url-filename urlobj) 0 (match-beginning 0))
- sepchar (substring (url-filename urlobj) (match-beginning 0) (match-end 0)))
- (setq file (url-filename urlobj)))
- ;; We use concat rather than expand-file-name to combine
- ;; directory and file name, since urls do not follow the same
- ;; rules as local files on all platforms.
- (setq file (url-expander-remove-relative-links
- (concat (url-file-directory (url-filename defobj)) file)))
- (setf (url-filename urlobj)
- (if query (concat file sepchar query) file))))))
-
-(defadvice url-default-expander
- (around request-monkey-patch-url-default-expander (urlobj defobj))
- "Monkey patch `url-default-expander' to fix bug #12374.
-This patch is applied to Emacs trunk at revno 111291:
- http://bzr.savannah.gnu.org/lh/emacs/trunk/revision/111291.
-Without this patch, port number is not treated when using
-`url-expand-file-name'.
-See: http://thread.gmane.org/gmane.emacs.devel/155698"
- (setq ad-return-value (request--url-default-expander urlobj defobj)))
-
-(unless (equal (url-expand-file-name "/path" "http://127.0.0.1:8000")
- "http://127.0.0.1:8000/path")
- (ad-enable-advice 'url-default-expander
- 'around
- 'request-monkey-patch-url-default-expander)
- (ad-activate 'url-default-expander))
-
-
-(eval-when-compile (require 'url-http)
- (defvar url-http-no-retry)
- (defvar url-http-extra-headers)
- (defvar url-http-data)
- (defvar url-callback-function)
- (defvar url-callback-arguments))
-(declare-function url-http-idle-sentinel "url-http")
-(declare-function url-http-activate-callback "url-http")
-(declare-function url-http "url-http")
-(declare-function url-http-parse-headers "url-http")
-
-(defun request--url-http-end-of-document-sentinel (proc why)
- "Adapted from lisp/url/url-http.el.
-FSF holds the copyright of this function:
- Copyright (C) 1999, 2001, 2004-2012 Free Software Foundation, Inc."
- (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
- (process-buffer proc))
- (url-http-idle-sentinel proc why)
- (when (buffer-name (process-buffer proc))
- (with-current-buffer (process-buffer proc)
- (goto-char (point-min))
- (cond ((not (looking-at "HTTP/"))
- (if url-http-no-retry
- ;; HTTP/0.9 just gets passed back no matter what
- (url-http-activate-callback)
- ;; Call `url-http' again if our connection expired.
- (erase-buffer)
- (let ((url-request-method url-http-method)
- (url-request-extra-headers url-http-extra-headers)
- (url-request-data url-http-data))
- (url-http url-current-object url-callback-function
- url-callback-arguments (current-buffer)))))
- ((url-http-parse-headers)
- (url-http-activate-callback))))))
-
-(defadvice url-http-end-of-document-sentinel
- (around request-monkey-patch-url-http-end-of-document-sentinel (proc why))
- "Monkey patch `url-http-end-of-document-sentinel' to fix bug #11469.
-This patch is applied to Emacs trunk at revno 111291:
- http://bzr.savannah.gnu.org/lh/emacs/trunk/revision/111291.
-Without this patch, PUT method fails every two times.
-See: http://thread.gmane.org/gmane.emacs.devel/155697"
- (setq ad-return-value (request--url-http-end-of-document-sentinel proc why)))
-
-(when (and (version< "24" emacs-version)
- (version< emacs-version "24.3.50.1"))
- (ad-enable-advice 'url-http-end-of-document-sentinel
- 'around
- 'request-monkey-patch-url-http-end-of-document-sentinel)
- (ad-activate 'url-http-end-of-document-sentinel))
-
-
-(provide 'request)
-
-;;; request.el ends here
--- /dev/null
+;;; request.el --- Compatible layer for URL request in Emacs -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2012 Takafumi Arakaki
+;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
+;; Free Software Foundation, Inc.
+
+;; Author: Takafumi Arakaki <aka.tkf at gmail.com>
+;; Package-Requires: ((emacs "24.4"))
+;; Package-Version: 20170201.147
+;; Version: 0.3.0
+
+;; This file is NOT part of GNU Emacs.
+
+;; request.el 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.
+
+;; request.el 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 request.el.
+;; If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Request.el is a HTTP request library with multiple backends. It
+;; supports url.el which is shipped with Emacs and curl command line
+;; program. User can use curl when s/he has it, as curl is more reliable
+;; than url.el. Library author can use request.el to avoid imposing
+;; external dependencies such as curl to users while giving richer
+;; experience for users who have curl.
+
+;; Following functions are adapted from GNU Emacs source code.
+;; Free Software Foundation holds the copyright of them.
+;; * `request--process-live-p'
+;; * `request--url-default-expander'
+
+;;; Code:
+
+(eval-when-compile
+ (defvar url-http-method)
+ (defvar url-http-response-status))
+
+(require 'cl-lib)
+(require 'url)
+(require 'mail-utils)
+
+(defgroup request nil
+ "Compatible layer for URL request in Emacs."
+ :group 'comm
+ :prefix "request-")
+
+(defconst request-version "0.3.0")
+
+\f
+;;; Customize variables
+
+(defcustom request-storage-directory
+ (concat (file-name-as-directory user-emacs-directory) "request")
+ "Directory to store data related to request.el."
+ :type 'directory)
+
+(defcustom request-curl "curl"
+ "Executable for curl command."
+ :type 'string)
+
+(defcustom request-curl-options nil
+ "curl command options.
+
+List of strings that will be passed to every curl invocation. You can pass
+extra options here, like setting the proxy."
+ :type '(repeat string))
+
+(defcustom request-backend (if (executable-find request-curl)
+ 'curl
+ 'url-retrieve)
+ "Backend to be used for HTTP request.
+Automatically set to `curl' if curl command is found."
+ :type '(choice (const :tag "cURL backend" curl)
+ (const :tag "url-retrieve backend" url-retrieve)))
+
+(defcustom request-timeout nil
+ "Default request timeout in second.
+`nil' means no timeout."
+ :type '(choice (integer :tag "Request timeout seconds")
+ (boolean :tag "No timeout" nil)))
+
+(defcustom request-temp-prefix "emacs-request"
+ "Prefix for temporary files created by Request."
+ :type 'string
+ :risky t)
+
+(defcustom request-log-level -1
+ "Logging level for request.
+One of `error'/`warn'/`info'/`verbose'/`debug'.
+-1 means no logging."
+ :type '(choice (integer :tag "No logging" -1)
+ (const :tag "Level error" error)
+ (const :tag "Level warn" warn)
+ (const :tag "Level info" info)
+ (const :tag "Level Verbose" verbose)
+ (const :tag "Level DEBUG" debug)))
+
+(defcustom request-message-level 'warn
+ "Logging level for request.
+See `request-log-level'."
+ :type '(choice (integer :tag "No logging" -1)
+ (const :tag "Level error" error)
+ (const :tag "Level warn" warn)
+ (const :tag "Level info" info)
+ (const :tag "Level Verbose" verbose)
+ (const :tag "Level DEBUG" debug)))
+
+\f
+;;; Utilities
+
+(defun request--safe-apply (function &rest arguments)
+ (condition-case err
+ (apply #'apply function arguments)
+ ((debug error))))
+
+(defun request--safe-call (function &rest arguments)
+ (request--safe-apply function arguments))
+
+;; (defun request--url-no-cache (url)
+;; "Imitate `cache=false' of `jQuery.ajax'.
+;; See: http://api.jquery.com/jQuery.ajax/"
+;; ;; FIXME: parse URL before adding ?_=TIME.
+;; (concat url (format-time-string "?_=%s")))
+
+(defmacro request--document-function (function docstring)
+ "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
+ (declare (indent defun)
+ (doc-string 2))
+ `(put ',function 'function-documentation ,docstring))
+
+(defun request--process-live-p (process)
+ "Copied from `process-live-p' for backward compatibility (Emacs < 24).
+Adapted from lisp/subr.el.
+FSF holds the copyright of this function:
+ Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
+ Free Software Foundation, Inc."
+ (memq (process-status process) '(run open listen connect stop)))
+
+\f
+;;; Logging
+
+(defconst request--log-level-def
+ '(;; debugging
+ (blather . 60) (trace . 50) (debug . 40)
+ ;; information
+ (verbose . 30) (info . 20)
+ ;; errors
+ (warn . 10) (error . 0))
+ "Named logging levels.")
+
+(defun request--log-level-as-int (level)
+ (if (integerp level)
+ level
+ (or (cdr (assq level request--log-level-def))
+ 0)))
+
+(defvar request-log-buffer-name " *request-log*")
+
+(defun request--log-buffer ()
+ (get-buffer-create request-log-buffer-name))
+
+(defmacro request-log (level fmt &rest args)
+ (declare (indent 1))
+ `(let ((level (request--log-level-as-int ,level))
+ (log-level (request--log-level-as-int request-log-level))
+ (msg-level (request--log-level-as-int request-message-level)))
+ (when (<= level (max log-level msg-level))
+ (let ((msg (format "[%s] %s" ,level
+ (condition-case err
+ (format ,fmt ,@args)
+ (error (format "
+!!! Logging error while executing:
+%S
+!!! Error:
+%S"
+ ',args err))))))
+ (when (<= level log-level)
+ (with-current-buffer (request--log-buffer)
+ (setq buffer-read-only t)
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (insert msg "\n"))))
+ (when (<= level msg-level)
+ (message "REQUEST %s" msg))))))
+
+\f
+;;; HTTP specific utilities
+
+(defconst request--url-unreserved-chars
+ '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
+ ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
+ ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+ ?- ?_ ?. ?~)
+ "`url-unreserved-chars' copied from Emacs 24.3 release candidate.
+This is used for making `request--urlencode-alist' RFC 3986 compliant
+for older Emacs versions.")
+
+(defun request--urlencode-alist (alist)
+ ;; FIXME: make monkey patching `url-unreserved-chars' optional
+ (let ((url-unreserved-chars request--url-unreserved-chars))
+ (cl-loop for sep = "" then "&"
+ for (k . v) in alist
+ concat sep
+ concat (url-hexify-string (format "%s" k))
+ concat "="
+ concat (url-hexify-string (format "%s" v)))))
+
+\f
+;;; Header parser
+
+(defun request--parse-response-at-point ()
+ "Parse the first header line such as \"HTTP/1.1 200 OK\"."
+ (when (re-search-forward "\\=[ \t\n]*HTTP/\\([0-9\\.]+\\) +\\([0-9]+\\)" nil t)
+ (list :version (match-string 1)
+ :code (string-to-number (match-string 2)))))
+
+(defun request--goto-next-body ()
+ (re-search-forward "^\r\n"))
+
+\f
+;;; Response object
+
+(cl-defstruct request-response
+ "A structure holding all relevant information of a request."
+ status-code history data error-thrown symbol-status url
+ done-p settings
+ ;; internal variables
+ -buffer -raw-header -timer -backend -tempfiles)
+
+(defmacro request--document-response (function docstring)
+ (declare (indent defun)
+ (doc-string 2))
+ `(request--document-function ,function ,(concat docstring "
+
+.. This is an accessor for `request-response' object.
+
+\(fn RESPONSE)")))
+
+(request--document-response request-response-status-code
+ "Integer HTTP response code (e.g., 200).")
+
+(request--document-response request-response-history
+ "Redirection history (a list of response object).
+The first element is the oldest redirection.
+
+You can use restricted portion of functions for the response
+objects in the history slot. It also depends on backend. Here
+is the table showing what functions you can use for the response
+objects in the history slot.
+
+==================================== ============== ==============
+Slots Backends
+------------------------------------ -----------------------------
+\\ curl url-retrieve
+==================================== ============== ==============
+request-response-url yes yes
+request-response-header yes no
+other functions no no
+==================================== ============== ==============
+")
+
+(request--document-response request-response-data
+ "Response parsed by the given parser.")
+
+(request--document-response request-response-error-thrown
+ "Error thrown during request.
+It takes the form of ``(ERROR-SYMBOL . DATA)``, which can be
+re-raised (`signal'ed) by ``(signal ERROR-SYMBOL DATA)``.")
+
+(request--document-response request-response-symbol-status
+ "A symbol representing the status of request (not HTTP response code).
+One of success/error/timeout/abort/parse-error.")
+
+(request--document-response request-response-url
+ "Final URL location of response.")
+
+(request--document-response request-response-done-p
+ "Return t when the request is finished or aborted.")
+
+(request--document-response request-response-settings
+ "Keyword arguments passed to `request' function.
+Some arguments such as HEADERS is changed to the one actually
+passed to the backend. Also, it has additional keywords such
+as URL which is the requested URL.")
+
+(defun request-response-header (response field-name)
+ "Fetch the values of RESPONSE header field named FIELD-NAME.
+
+It returns comma separated values when the header has multiple
+field with the same name, as :RFC:`2616` specifies.
+
+Examples::
+
+ (request-response-header response
+ \"content-type\") ; => \"text/html; charset=utf-8\"
+ (request-response-header response
+ \"unknown-field\") ; => nil
+"
+ (let ((raw-header (request-response--raw-header response)))
+ (when raw-header
+ (with-temp-buffer
+ (erase-buffer)
+ (insert raw-header)
+ ;; ALL=t to fetch all fields with the same name to get comma
+ ;; separated value [#rfc2616-sec4]_.
+ (mail-fetch-field field-name nil t)))))
+;; .. [#rfc2616-sec4] RFC2616 says this is the right thing to do
+;; (see http://tools.ietf.org/html/rfc2616.html#section-4.2).
+;; Python's requests module does this too.
+
+\f
+;;; Backend dispatcher
+
+(defconst request--backend-alist
+ '((url-retrieve
+ . ((request . request--url-retrieve)
+ (request-sync . request--url-retrieve-sync)
+ (terminate-process . delete-process)
+ (get-cookies . request--url-retrieve-get-cookies)))
+ (curl
+ . ((request . request--curl)
+ (request-sync . request--curl-sync)
+ (terminate-process . interrupt-process)
+ (get-cookies . request--curl-get-cookies))))
+ "Map backend and method name to actual method (symbol).
+
+It's alist of alist, of the following form::
+
+ ((BACKEND . ((METHOD . FUNCTION) ...)) ...)
+
+It would be nicer if I can use EIEIO. But as CEDET is included
+in Emacs by 23.2, using EIEIO means abandon older Emacs versions.
+It is probably necessary if I need to support more backends. But
+let's stick to manual dispatch for now.")
+;; See: (view-emacs-news "23.2")
+
+(defun request--choose-backend (method)
+ "Return `fucall'able object for METHOD of current `request-backend'."
+ (assoc-default
+ method
+ (or (assoc-default request-backend request--backend-alist)
+ (error "%S is not valid `request-backend'." request-backend))))
+
+\f
+;;; Cookie
+
+(defun request-cookie-string (host &optional localpart secure)
+ "Return cookie string (like `document.cookie').
+
+Example::
+
+ (request-cookie-string \"127.0.0.1\" \"/\") ; => \"key=value; key2=value2\"
+"
+ (mapconcat (lambda (nv) (concat (car nv) "=" (cdr nv)))
+ (request-cookie-alist host localpart secure)
+ "; "))
+
+(defun request-cookie-alist (host &optional localpart secure)
+ "Return cookies as an alist.
+
+Example::
+
+ (request-cookie-alist \"127.0.0.1\" \"/\") ; => ((\"key\" . \"value\") ...)
+"
+ (funcall (request--choose-backend 'get-cookies) host localpart secure))
+
+\f
+;;; Main
+
+(cl-defun request-default-error-callback (url &key symbol-status
+ &allow-other-keys)
+ (request-log 'error
+ "Error (%s) while connecting to %s." symbol-status url))
+
+(cl-defun request (url &rest settings
+ &key
+ (type "GET")
+ (params nil)
+ (data nil)
+ (files nil)
+ (parser nil)
+ (headers nil)
+ (success nil)
+ (error nil)
+ (complete nil)
+ (timeout request-timeout)
+ (status-code nil)
+ (sync nil)
+ (response (make-request-response))
+ (unix-socket nil))
+ "Send request to URL.
+
+Request.el has a single entry point. It is `request'.
+
+==================== ========================================================
+Keyword argument Explanation
+==================== ========================================================
+TYPE (string) type of request to make: POST/GET/PUT/DELETE
+PARAMS (alist) set \"?key=val\" part in URL
+DATA (string/alist) data to be sent to the server
+FILES (alist) files to be sent to the server (see below)
+PARSER (symbol) a function that reads current buffer and return data
+HEADERS (alist) additional headers to send with the request
+SUCCESS (function) called on success
+ERROR (function) called on error
+COMPLETE (function) called on both success and error
+TIMEOUT (number) timeout in second
+STATUS-CODE (alist) map status code (int) to callback
+SYNC (bool) If `t', wait until request is done. Default is `nil'.
+==================== ========================================================
+
+
+* Callback functions
+
+Callback functions STATUS, ERROR, COMPLETE and `cdr's in element of
+the alist STATUS-CODE take same keyword arguments listed below. For
+forward compatibility, these functions must ignore unused keyword
+arguments (i.e., it's better to use `&allow-other-keys' [#]_).::
+
+ (CALLBACK ; SUCCESS/ERROR/COMPLETE/STATUS-CODE
+ :data data ; whatever PARSER function returns, or nil
+ :error-thrown error-thrown ; (ERROR-SYMBOL . DATA), or nil
+ :symbol-status symbol-status ; success/error/timeout/abort/parse-error
+ :response response ; request-response object
+ ...)
+
+.. [#] `&allow-other-keys' is a special \"markers\" available in macros
+ in the CL library for function definition such as `cl-defun' and
+ `cl-function'. Without this marker, you need to specify all arguments
+ to be passed. This becomes problem when request.el adds new arguments
+ when calling callback functions. If you use `&allow-other-keys'
+ (or manually ignore other arguments), your code is free from this
+ problem. See info node `(cl) Argument Lists' for more information.
+
+Arguments data, error-thrown, symbol-status can be accessed by
+`request-response-data', `request-response-error-thrown',
+`request-response-symbol-status' accessors, i.e.::
+
+ (request-response-data RESPONSE) ; same as data
+
+Response object holds other information which can be accessed by
+the following accessors:
+`request-response-status-code',
+`request-response-url' and
+`request-response-settings'
+
+* STATUS-CODE callback
+
+STATUS-CODE is an alist of the following format::
+
+ ((N-1 . CALLBACK-1)
+ (N-2 . CALLBACK-2)
+ ...)
+
+Here, N-1, N-2,... are integer status codes such as 200.
+
+
+* FILES
+
+FILES is an alist of the following format::
+
+ ((NAME-1 . FILE-1)
+ (NAME-2 . FILE-2)
+ ...)
+
+where FILE-N is a list of the form::
+
+ (FILENAME &key PATH BUFFER STRING MIME-TYPE)
+
+FILE-N can also be a string (path to the file) or a buffer object.
+In that case, FILENAME is set to the file name or buffer name.
+
+Example FILES argument::
+
+ `((\"passwd\" . \"/etc/passwd\") ; filename = passwd
+ (\"scratch\" . ,(get-buffer \"*scratch*\")) ; filename = *scratch*
+ (\"passwd2\" . (\"password.txt\" :file \"/etc/passwd\"))
+ (\"scratch2\" . (\"scratch.txt\" :buffer ,(get-buffer \"*scratch*\")))
+ (\"data\" . (\"data.csv\" :data \"1,2,3\\n4,5,6\\n\")))
+
+.. note:: FILES is implemented only for curl backend for now.
+ As furl.el_ supports multipart POST, it should be possible to
+ support FILES in pure elisp by making furl.el_ another backend.
+ Contributions are welcome.
+
+ .. _furl.el: http://code.google.com/p/furl-el/
+
+
+* PARSER function
+
+PARSER function takes no argument and it is executed in the
+buffer with HTTP response body. The current position in the HTTP
+response buffer is at the beginning of the buffer. As the HTTP
+header is stripped off, the cursor is actually at the beginning
+of the response body. So, for example, you can pass `json-read'
+to parse JSON object in the buffer. To fetch whole response as a
+string, pass `buffer-string'.
+
+When using `json-read', it is useful to know that the returned
+type can be modified by `json-object-type', `json-array-type',
+`json-key-type', `json-false' and `json-null'. See docstring of
+each function for what it does. For example, to convert JSON
+objects to plist instead of alist, wrap `json-read' by `lambda'
+like this.::
+
+ (request
+ \"http://...\"
+ :parser (lambda ()
+ (let ((json-object-type 'plist))
+ (json-read)))
+ ...)
+
+This is analogous to the `dataType' argument of jQuery.ajax_.
+Only this function can access to the process buffer, which
+is killed immediately after the execution of this function.
+
+* SYNC
+
+Synchronous request is functional, but *please* don't use it
+other than testing or debugging. Emacs users have better things
+to do rather than waiting for HTTP request. If you want a better
+way to write callback chains, use `request-deferred'.
+
+If you can't avoid using it (e.g., you are inside of some hook
+which must return some value), make sure to set TIMEOUT to
+relatively small value.
+
+Due to limitation of `url-retrieve-synchronously', response slots
+`request-response-error-thrown', `request-response-history' and
+`request-response-url' are unknown (always `nil') when using
+synchronous request with `url-retrieve' backend.
+
+* Note
+
+API of `request' is somewhat mixture of jQuery.ajax_ (Javascript)
+and requests.request_ (Python).
+
+.. _jQuery.ajax: http://api.jquery.com/jQuery.ajax/
+.. _requests.request: http://docs.python-requests.org
+"
+ (request-log 'debug "REQUEST")
+ ;; FIXME: support CACHE argument (if possible)
+ ;; (unless cache
+ ;; (setq url (request--url-no-cache url)))
+ (unless error
+ (setq error (apply-partially #'request-default-error-callback url))
+ (setq settings (plist-put settings :error error)))
+ (unless (or (stringp data)
+ (null data)
+ (assoc-string "Content-Type" headers t))
+ (setq data (request--urlencode-alist data))
+ (setq settings (plist-put settings :data data)))
+ (when params
+ (cl-assert (listp params) nil "PARAMS must be an alist. Given: %S" params)
+ (setq url (concat url (if (string-match-p "\\?" url) "&" "?")
+ (request--urlencode-alist params))))
+ (setq settings (plist-put settings :url url))
+ (setq settings (plist-put settings :response response))
+ (setf (request-response-settings response) settings)
+ (setf (request-response-url response) url)
+ (setf (request-response--backend response) request-backend)
+ ;; Call `request--url-retrieve'(`-sync') or `request--curl'(`-sync').
+ (apply (if sync
+ (request--choose-backend 'request-sync)
+ (request--choose-backend 'request))
+ url settings)
+ (when timeout
+ (request-log 'debug "Start timer: timeout=%s sec" timeout)
+ (setf (request-response--timer response)
+ (run-at-time timeout nil
+ #'request-response--timeout-callback response)))
+ response)
+
+(defun request--clean-header (response)
+ "Strip off carriage returns in the header of REQUEST."
+ (request-log 'debug "-CLEAN-HEADER")
+ (let ((buffer (request-response--buffer response))
+ (backend (request-response--backend response))
+ sep-regexp)
+ (if (eq backend 'url-retrieve)
+ ;; FIXME: make this workaround optional.
+ ;; But it looks like sometimes `url-http-clean-headers'
+ ;; fails to cleanup. So, let's be bit permissive here...
+ (setq sep-regexp "^\r?$")
+ (setq sep-regexp "^\r$"))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (request-log 'trace
+ "(buffer-string) at %S =\n%s" buffer (buffer-string))
+ (goto-char (point-min))
+ (when (and (re-search-forward sep-regexp nil t)
+ ;; Are \r characters stripped off already?:
+ (not (equal (match-string 0) "")))
+ (while (re-search-backward "\r$" (point-min) t)
+ (replace-match "")))))))
+
+(defun request--cut-header (response)
+ "Cut the first header part in the buffer of RESPONSE and move it to
+raw-header slot."
+ (request-log 'debug "-CUT-HEADER")
+ (let ((buffer (request-response--buffer response)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (when (re-search-forward "^$" nil t)
+ (setf (request-response--raw-header response)
+ (buffer-substring (point-min) (point)))
+ (delete-region (point-min) (min (1+ (point)) (point-max))))))))
+
+(defun request-untrampify-filename (file)
+ "Return FILE as the local file name."
+ (or (file-remote-p file 'localname) file))
+
+(defun request--parse-data (response parser)
+ "Run PARSER in current buffer if ERROR-THROWN is nil,
+then kill the current buffer."
+ (request-log 'debug "-PARSE-DATA")
+ (let ((buffer (request-response--buffer response)))
+ (request-log 'debug "parser = %s" parser)
+ (when (and (buffer-live-p buffer) parser)
+ (with-current-buffer buffer
+ (request-log 'trace
+ "(buffer-string) at %S =\n%s" buffer (buffer-string))
+ (when (/= (request-response-status-code response) 204)
+ (goto-char (point-min))
+ (setf (request-response-data response) (funcall parser)))))))
+
+(cl-defun request--callback (buffer &key parser success error complete
+ timeout status-code response
+ &allow-other-keys)
+ (request-log 'debug "REQUEST--CALLBACK")
+ (request-log 'debug "(buffer-string) =\n%s"
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer (buffer-string))))
+
+ ;; Sometimes BUFFER given as the argument is different from the
+ ;; buffer already set in RESPONSE. That's why it is reset here.
+ ;; FIXME: Refactor how BUFFER is passed around.
+ (setf (request-response--buffer response) buffer)
+ (request-response--cancel-timer response)
+ (cl-symbol-macrolet
+ ((error-thrown (request-response-error-thrown response))
+ (symbol-status (request-response-symbol-status response))
+ (data (request-response-data response))
+ (done-p (request-response-done-p response)))
+
+ ;; Parse response header
+ (request--clean-header response)
+ (request--cut-header response)
+ ;; Note: Try to do this even `error-thrown' is set. For example,
+ ;; timeout error can occur while downloading response body and
+ ;; header is there in that case.
+
+ ;; Parse response body
+ (request-log 'debug "error-thrown = %S" error-thrown)
+ (condition-case err
+ (request--parse-data response parser)
+ (error
+ ;; If there was already an error (e.g. server timeout) do not set the
+ ;; status to `parse-error'.
+ (unless error-thrown
+ (setq symbol-status 'parse-error)
+ (setq error-thrown err)
+ (request-log 'error "Error from parser %S: %S" parser err))))
+ (kill-buffer buffer)
+ (request-log 'debug "data = %s" data)
+
+ ;; Determine `symbol-status'
+ (unless symbol-status
+ (setq symbol-status (if error-thrown 'error 'success)))
+ (request-log 'debug "symbol-status = %s" symbol-status)
+
+ ;; Call callbacks
+ (let ((args (list :data data
+ :symbol-status symbol-status
+ :error-thrown error-thrown
+ :response response)))
+ (let* ((success-p (eq symbol-status 'success))
+ (cb (if success-p success error))
+ (name (if success-p "success" "error")))
+ (when cb
+ (request-log 'debug "Executing %s callback." name)
+ (request--safe-apply cb args)))
+
+ (let ((cb (cdr (assq (request-response-status-code response)
+ status-code))))
+ (when cb
+ (request-log 'debug "Executing status-code callback.")
+ (request--safe-apply cb args)))
+
+ (when complete
+ (request-log 'debug "Executing complete callback.")
+ (request--safe-apply complete args)))
+
+ (setq done-p t)
+
+ ;; Remove temporary files
+ ;; FIXME: Make tempfile cleanup more reliable. It is possible
+ ;; callback is never called.
+ (request--safe-delete-files (request-response--tempfiles response))))
+
+(cl-defun request-response--timeout-callback (response)
+ (request-log 'debug "-TIMEOUT-CALLBACK")
+ (setf (request-response-symbol-status response) 'timeout)
+ (setf (request-response-error-thrown response) '(error . ("Timeout")))
+ (let* ((buffer (request-response--buffer response))
+ (proc (and (buffer-live-p buffer) (get-buffer-process buffer))))
+ (when proc
+ ;; This will call `request--callback':
+ (funcall (request--choose-backend 'terminate-process) proc))
+
+ (cl-symbol-macrolet ((done-p (request-response-done-p response)))
+ (unless done-p
+ ;; This code should never be executed. However, it occurs
+ ;; sometimes with `url-retrieve' backend.
+ ;; FIXME: In Emacs 24.3.50 or later, this is always executed in
+ ;; request-get-timeout test. Find out if it is fine.
+ (request-log 'error "Callback is not called when stopping process! \
+Explicitly calling from timer.")
+ (when (buffer-live-p buffer)
+ (cl-destructuring-bind (&key code &allow-other-keys)
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (request--parse-response-at-point))
+ (setf (request-response-status-code response) code)))
+ (apply #'request--callback
+ buffer
+ (request-response-settings response))
+ (setq done-p t)))))
+
+(defun request-response--cancel-timer (response)
+ (request-log 'debug "REQUEST-RESPONSE--CANCEL-TIMER")
+ (cl-symbol-macrolet ((timer (request-response--timer response)))
+ (when timer
+ (cancel-timer timer)
+ (setq timer nil))))
+
+
+(defun request-abort (response)
+ "Abort request for RESPONSE (the object returned by `request').
+Note that this function invoke ERROR and COMPLETE callbacks.
+Callbacks may not be called immediately but called later when
+associated process is exited."
+ (cl-symbol-macrolet ((buffer (request-response--buffer response))
+ (symbol-status (request-response-symbol-status response))
+ (done-p (request-response-done-p response)))
+ (let ((process (get-buffer-process buffer)))
+ (unless symbol-status ; should I use done-p here?
+ (setq symbol-status 'abort)
+ (setq done-p t)
+ (when (and
+ (processp process) ; process can be nil when buffer is killed
+ (request--process-live-p process))
+ (funcall (request--choose-backend 'terminate-process) process))))))
+
+\f
+;;; Backend: `url-retrieve'
+
+(cl-defun request--url-retrieve-preprocess-settings
+ (&rest settings &key type data files headers &allow-other-keys)
+ (when files
+ (error "`url-retrieve' backend does not support FILES."))
+ (when (and (equal type "POST")
+ data
+ (not (assoc-string "Content-Type" headers t)))
+ (push '("Content-Type" . "application/x-www-form-urlencoded") headers)
+ (setq settings (plist-put settings :headers headers)))
+ settings)
+
+(cl-defun request--url-retrieve (url &rest settings
+ &key type data timeout response
+ &allow-other-keys
+ &aux headers)
+ (setq settings (apply #'request--url-retrieve-preprocess-settings settings))
+ (setq headers (plist-get settings :headers))
+ (let* ((url-request-extra-headers headers)
+ (url-request-method type)
+ (url-request-data data)
+ (buffer (url-retrieve url #'request--url-retrieve-callback
+ (nconc (list :response response) settings)))
+ (proc (get-buffer-process buffer)))
+ (setf (request-response--buffer response) buffer)
+ (process-put proc :request-response response)
+ (request-log 'debug "Start querying: %s" url)
+ (set-process-query-on-exit-flag proc nil)))
+
+(cl-defun request--url-retrieve-callback (status &rest settings
+ &key response url
+ &allow-other-keys)
+ (declare (special url-http-method
+ url-http-response-status))
+ (request-log 'debug "-URL-RETRIEVE-CALLBACK")
+ (request-log 'debug "status = %S" status)
+ (request-log 'debug "url-http-method = %s" url-http-method)
+ (request-log 'debug "url-http-response-status = %s" url-http-response-status)
+
+ (setf (request-response-status-code response) url-http-response-status)
+ (let ((redirect (plist-get status :redirect)))
+ (when redirect
+ (setf (request-response-url response) redirect)))
+ ;; Construct history slot
+ (cl-loop for v in
+ (cl-loop with first = t
+ with l = nil
+ for (k v) on status by 'cddr
+ when (eq k :redirect)
+ if first
+ do (setq first nil)
+ else
+ do (push v l)
+ finally do (cons url l))
+ do (let ((r (make-request-response :-backend 'url-retrieve)))
+ (setf (request-response-url r) v)
+ (push r (request-response-history response))))
+
+ (cl-symbol-macrolet ((error-thrown (request-response-error-thrown response))
+ (status-error (plist-get status :error)))
+ (when (and error-thrown status-error)
+ (request-log 'warn
+ "Error %S thrown already but got another error %S from \
+`url-retrieve'. Ignoring it..." error-thrown status-error))
+ (unless error-thrown
+ (setq error-thrown status-error)))
+
+ (apply #'request--callback (current-buffer) settings))
+
+(cl-defun request--url-retrieve-sync (url &rest settings
+ &key type data timeout response
+ &allow-other-keys
+ &aux headers)
+ (setq settings (apply #'request--url-retrieve-preprocess-settings settings))
+ (setq headers (plist-get settings :headers))
+ (let* ((url-request-extra-headers headers)
+ (url-request-method type)
+ (url-request-data data)
+ (buffer (if timeout
+ (with-timeout
+ (timeout
+ (setf (request-response-symbol-status response)
+ 'timeout)
+ (setf (request-response-done-p response) t)
+ nil)
+ (url-retrieve-synchronously url))
+ (url-retrieve-synchronously url))))
+ (setf (request-response--buffer response) buffer)
+ ;; It seems there is no way to get redirects and URL here...
+ (when buffer
+ ;; Fetch HTTP response code
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (cl-destructuring-bind (&key version code)
+ (request--parse-response-at-point)
+ (setf (request-response-status-code response) code)))
+ ;; Parse response body, etc.
+ (apply #'request--callback buffer settings)))
+ response)
+
+(defun request--url-retrieve-get-cookies (host localpart secure)
+ (mapcar
+ (lambda (c) (cons (url-cookie-name c) (url-cookie-value c)))
+ (url-cookie-retrieve host localpart secure)))
+
+\f
+;;; Backend: curl
+
+(defvar request--curl-cookie-jar nil
+ "Override what the function `request--curl-cookie-jar' returns.
+Currently it is used only for testing.")
+
+(defun request--curl-cookie-jar ()
+ "Cookie storage for curl backend."
+ (or request--curl-cookie-jar
+ (expand-file-name "curl-cookie-jar" request-storage-directory)))
+
+(defconst request--curl-write-out-template
+ (if (eq system-type 'windows-nt)
+ "\\n(:num-redirects %{num_redirects} :url-effective %{url_effective})"
+ "\\n(:num-redirects %{num_redirects} :url-effective \"%{url_effective}\")"))
+
+(defun request--curl-mkdir-for-cookie-jar ()
+ (ignore-errors
+ (make-directory (file-name-directory (request--curl-cookie-jar)) t)))
+
+(cl-defun request--curl-command
+ (url &key type data headers timeout response files* unix-socket
+ &allow-other-keys
+ &aux
+ (cookie-jar (convert-standard-filename
+ (expand-file-name (request--curl-cookie-jar)))))
+ (append
+ (list request-curl "--silent" "--include"
+ "--location"
+ ;; FIXME: test automatic decompression
+ "--compressed"
+ ;; FIMXE: this way of using cookie might be problem when
+ ;; running multiple requests.
+ "--cookie" cookie-jar "--cookie-jar" cookie-jar
+ "--write-out" request--curl-write-out-template)
+ request-curl-options
+ (when unix-socket (list "--unix-socket" unix-socket))
+ (cl-loop for (name filename path mime-type) in files*
+ collect "--form"
+ collect (format "%s=@%s;filename=%s%s" name
+ (request-untrampify-filename path) filename
+ (if mime-type
+ (format ";type=%s" mime-type)
+ "")))
+ (when data
+ (let ((tempfile (request--make-temp-file)))
+ (push tempfile (request-response--tempfiles response))
+ (let ((file-coding-system-alist nil)
+ (coding-system-for-write 'binary))
+ (with-temp-file tempfile
+ (setq buffer-file-coding-system 'binary)
+ (set-buffer-multibyte nil)
+ (insert data)))
+ (list "--data-binary" (concat "@" (request-untrampify-filename tempfile)))))
+ (when type (list "--request" type))
+ (cl-loop for (k . v) in headers
+ collect "--header"
+ collect (format "%s: %s" k v))
+ (list url)))
+
+(defun request--curl-normalize-files-1 (files get-temp-file)
+ (cl-loop for (name . item) in files
+ collect
+ (cl-destructuring-bind
+ (filename &key file buffer data mime-type)
+ (cond
+ ((stringp item) (list (file-name-nondirectory item) :file item))
+ ((bufferp item) (list (buffer-name item) :buffer item))
+ (t item))
+ (unless (= (cl-loop for v in (list file buffer data) if v sum 1) 1)
+ (error "Only one of :file/:buffer/:data must be given. Got: %S"
+ (cons name item)))
+ (cond
+ (file
+ (list name filename file mime-type))
+ (buffer
+ (let ((tf (funcall get-temp-file)))
+ (with-current-buffer buffer
+ (write-region (point-min) (point-max) tf nil 'silent))
+ (list name filename tf mime-type)))
+ (data
+ (let ((tf (funcall get-temp-file)))
+ (with-temp-buffer
+ (erase-buffer)
+ (insert data)
+ (write-region (point-min) (point-max) tf nil 'silent))
+ (list name filename tf mime-type)))))))
+
+(defun request--make-temp-file ()
+ "Create a temporary file."
+ (if (file-remote-p default-directory)
+ (let ((tramp-temp-name-prefix request-temp-prefix)
+ (vec (tramp-dissect-file-name default-directory)))
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ (tramp-make-tramp-temp-file vec)
+ (tramp-file-name-hop vec)))
+ (make-temp-file request-temp-prefix)))
+
+(defun request--curl-normalize-files (files)
+ "Change FILES into a list of (NAME FILENAME PATH MIME-TYPE).
+This is to make `request--curl-command' cleaner by converting
+FILES to a homogeneous list. It returns a list (FILES* TEMPFILES)
+where FILES* is a converted FILES and TEMPFILES is a list of
+temporary file paths."
+ (let (tempfiles noerror)
+ (unwind-protect
+ (let* ((get-temp-file (lambda ()
+ (let ((tf (request--make-temp-file)))
+ (push tf tempfiles)
+ tf)))
+ (files* (request--curl-normalize-files-1 files get-temp-file)))
+ (setq noerror t)
+ (list files* tempfiles))
+ (unless noerror
+ ;; Remove temporary files only when an error occurs
+ (request--safe-delete-files tempfiles)))))
+
+(defun request--safe-delete-files (files)
+ "Remove FILES but do not raise error when failed to do so."
+ (mapc (lambda (f) (condition-case err
+ (delete-file f)
+ (error (request-log 'error
+ "Failed delete file %s. Got: %S" f err))))
+ files))
+
+(cl-defun request--curl (url &rest settings
+ &key type data files headers timeout response
+ &allow-other-keys)
+ "cURL-based request backend.
+
+Redirection handling strategy
+-----------------------------
+
+curl follows redirection when --location is given. However,
+all headers are printed when it is used with --include option.
+Number of redirects is printed out sexp-based message using
+--write-out option (see `request--curl-write-out-template').
+This number is used for removing extra headers and parse
+location header from the last redirection header.
+
+Sexp at the end of buffer and extra headers for redirects are
+removed from the buffer before it is shown to the parser function.
+"
+ (request--curl-mkdir-for-cookie-jar)
+ (let* (;; Use pipe instead of pty. Otherwise, curl process hangs.
+ (process-connection-type nil)
+ ;; Avoid starting program in non-existing directory.
+ (home-directory (if (file-remote-p default-directory)
+ (let ((vec (tramp-dissect-file-name default-directory)))
+ (tramp-make-tramp-file-name
+ (tramp-file-name-method vec)
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ "~/"
+ (tramp-file-name-hop vec)))
+ "~/"))
+ (default-directory (expand-file-name home-directory))
+ (buffer (generate-new-buffer " *request curl*"))
+ (command (cl-destructuring-bind
+ (files* tempfiles)
+ (request--curl-normalize-files files)
+ (setf (request-response--tempfiles response) tempfiles)
+ (apply #'request--curl-command url :files* files*
+ :response response settings)))
+ (proc (apply #'start-file-process "request curl" buffer command)))
+ (request-log 'debug "Run: %s" (mapconcat 'identity command " "))
+ (setf (request-response--buffer response) buffer)
+ (process-put proc :request-response response)
+ (set-process-coding-system proc 'binary 'binary)
+ (set-process-query-on-exit-flag proc nil)
+ (set-process-sentinel proc #'request--curl-callback)))
+
+(defun request--curl-read-and-delete-tail-info ()
+ "Read a sexp at the end of buffer and remove it and preceding character.
+This function moves the point at the end of buffer by side effect.
+See also `request--curl-write-out-template'."
+ (let (forward-sexp-function)
+ (goto-char (point-max))
+ (forward-sexp -1)
+ (let ((beg (1- (point))))
+ (prog1
+ (read (current-buffer))
+ (delete-region beg (point-max))))))
+
+(defconst request--cookie-reserved-re
+ (mapconcat
+ (lambda (x) (concat "\\(^" x "\\'\\)"))
+ '("comment" "commenturl" "discard" "domain" "max-age" "path" "port"
+ "secure" "version" "expires")
+ "\\|")
+ "Uninterested keys in cookie.
+See \"set-cookie-av\" in http://www.ietf.org/rfc/rfc2965.txt")
+
+(defun request--consume-100-continue ()
+ "Remove \"HTTP/* 100 Continue\" header at the point."
+ (cl-destructuring-bind (&key code &allow-other-keys)
+ (save-excursion (request--parse-response-at-point))
+ (when (equal code 100)
+ (delete-region (point) (progn (request--goto-next-body) (point)))
+ ;; FIXME: Does this make sense? Is it possible to have multiple 100?
+ (request--consume-100-continue))))
+
+(defun request--consume-200-connection-established ()
+ "Remove \"HTTP/* 200 Connection established\" header at the point."
+ (when (looking-at-p "HTTP/1\\.[0-1] 200 Connection established")
+ (delete-region (point) (progn (request--goto-next-body) (point)))))
+
+(defun request--curl-preprocess ()
+ "Pre-process current buffer before showing it to user."
+ (let (history)
+ (cl-destructuring-bind (&key num-redirects url-effective)
+ (request--curl-read-and-delete-tail-info)
+ (goto-char (point-min))
+ (request--consume-100-continue)
+ (request--consume-200-connection-established)
+ (when (> num-redirects 0)
+ (cl-loop with case-fold-search = t
+ repeat num-redirects
+ ;; Do not store code=100 headers:
+ do (request--consume-100-continue)
+ do (let ((response (make-request-response
+ :-buffer (current-buffer)
+ :-backend 'curl)))
+ (request--clean-header response)
+ (request--cut-header response)
+ (push response history))))
+
+ (goto-char (point-min))
+ (nconc (list :num-redirects num-redirects :url-effective url-effective
+ :history (nreverse history))
+ (request--parse-response-at-point)))))
+
+(defun request--curl-absolutify-redirects (start-url redirects)
+ "Convert relative paths in REDIRECTS to absolute URLs.
+START-URL is the URL requested."
+ (cl-loop for prev-url = start-url then url
+ for url in redirects
+ unless (string-match url-nonrelative-link url)
+ do (setq url (url-expand-file-name url prev-url))
+ collect url))
+
+(defun request--curl-absolutify-location-history (start-url history)
+ "Convert relative paths in HISTORY to absolute URLs.
+START-URL is the URL requested."
+ (when history
+ (setf (request-response-url (car history)) start-url))
+ (cl-loop for url in (request--curl-absolutify-redirects
+ start-url
+ (mapcar (lambda (response)
+ (request-response-header response "location"))
+ history))
+ for response in (cdr history)
+ do (setf (request-response-url response) url)))
+
+(defun request--curl-callback (proc event)
+ (let* ((buffer (process-buffer proc))
+ (response (process-get proc :request-response))
+ (symbol-status (request-response-symbol-status response))
+ (settings (request-response-settings response)))
+ (request-log 'debug "REQUEST--CURL-CALLBACK event = %s" event)
+ (request-log 'debug "REQUEST--CURL-CALLBACK proc = %S" proc)
+ (request-log 'debug "REQUEST--CURL-CALLBACK buffer = %S" buffer)
+ (request-log 'debug "REQUEST--CURL-CALLBACK symbol-status = %S"
+ symbol-status)
+ (cond
+ ((and (memq (process-status proc) '(exit signal))
+ (/= (process-exit-status proc) 0))
+ (setf (request-response-error-thrown response) (cons 'error event))
+ (apply #'request--callback buffer settings))
+ ((equal event "finished\n")
+ (cl-destructuring-bind (&key version code num-redirects history error
+ url-effective)
+ (condition-case err
+ (with-current-buffer buffer
+ (request--curl-preprocess))
+ ((debug error)
+ (list :error err)))
+ (request--curl-absolutify-location-history (plist-get settings :url)
+ history)
+ (setf (request-response-status-code response) code)
+ (setf (request-response-url response) url-effective)
+ (setf (request-response-history response) history)
+ (setf (request-response-error-thrown response)
+ (or error (when (>= code 400) `(error . (http ,code)))))
+ (apply #'request--callback buffer settings))))))
+
+(cl-defun request--curl-sync (url &rest settings &key response &allow-other-keys)
+ ;; To make timeout work, use polling approach rather than using
+ ;; `call-process'.
+ (let (finished)
+ (prog1 (apply #'request--curl url
+ :complete (lambda (&rest _) (setq finished t))
+ settings)
+ (let ((proc (get-buffer-process (request-response--buffer response))))
+ (while (and (not finished) (request--process-live-p proc))
+ (accept-process-output proc))))))
+
+(defun request--curl-get-cookies (host localpart secure)
+ (request--netscape-get-cookies (request--curl-cookie-jar)
+ host localpart secure))
+
+\f
+;;; Netscape cookie.txt parser
+
+(defun request--netscape-cookie-parse ()
+ "Parse Netscape/Mozilla cookie format."
+ (goto-char (point-min))
+ (let ((tsv-re (concat "^\\(#HttpOnly_\\)?"
+ (cl-loop repeat 6 concat "\\([^\t\n]+\\)\t")
+ "\\(.*\\)"))
+ cookies)
+ (while (not (eobp))
+ ;; HttpOnly cookie starts with '#' but its line is not comment line(#60)
+ (cond ((and (looking-at-p "^#") (not (looking-at-p "^#HttpOnly_"))) t)
+ ((looking-at-p "^$") t)
+ ((looking-at tsv-re)
+ (let ((cookie (cl-loop for i from 1 to 8 collect (match-string i))))
+ (push cookie cookies))))
+ (forward-line 1))
+ (setq cookies (nreverse cookies))
+ (cl-loop for (http-only domain flag path secure expiration name value) in cookies
+ collect (list domain
+ (equal flag "TRUE")
+ path
+ (equal secure "TRUE")
+ (null (not http-only))
+ (string-to-number expiration)
+ name
+ value))))
+
+(defun request--netscape-filter-cookies (cookies host localpart secure)
+ (cl-loop for (domain flag path secure-1 http-only expiration name value) in cookies
+ when (and (equal domain host)
+ (equal path localpart)
+ (or secure (not secure-1)))
+ collect (cons name value)))
+
+(defun request--netscape-get-cookies (filename host localpart secure)
+ (when (file-readable-p filename)
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-file-contents filename)
+ (request--netscape-filter-cookies (request--netscape-cookie-parse)
+ host localpart secure))))
+
+(provide 'request)
+
+;;; request.el ends here
projects / emacsconfig.git / commitdiff