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