diff options
Diffstat (limited to 'configs/shared/emacs/.emacs.d/elpa/request-20170201.147/request.el')
| -rw-r--r-- | configs/shared/emacs/.emacs.d/elpa/request-20170201.147/request.el | 1224 |
1 files changed, 0 insertions, 1224 deletions
diff --git a/configs/shared/emacs/.emacs.d/elpa/request-20170201.147/request.el b/configs/shared/emacs/.emacs.d/elpa/request-20170201.147/request.el deleted file mode 100644 index e282ade9cc..0000000000 --- a/configs/shared/emacs/.emacs.d/elpa/request-20170201.147/request.el +++ /dev/null @@ -1,1224 +0,0 @@ -;;; 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") - - -;;; 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))) - - -;;; 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))) - - -;;; 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)))))) - - -;;; 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))))) - - -;;; 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")) - - -;;; 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. - - -;;; 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)))) - - -;;; 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)) - - -;;; 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)))))) - - -;;; 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))) - - -;;; 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)) - - -;;; 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 |