Klimi's new dotfiles with stow.
Nevar pievienot vairāk kā 25 tēmas Tēmai ir jāsākas ar burtu vai ciparu, tā var saturēt domu zīmes ('-') un var būt līdz 35 simboliem gara.

1284 rindas
51 KiB

pirms 4 gadiem
  1. ;;; request.el --- Compatible layer for URL request in Emacs -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2012 Takafumi Arakaki
  3. ;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
  4. ;; Free Software Foundation, Inc.
  5. ;; Author: Takafumi Arakaki <aka.tkf at gmail.com>
  6. ;; URL: https://github.com/tkf/emacs-request
  7. ;; Package-Version: 20191022.615
  8. ;; Package-Requires: ((emacs "24.4"))
  9. ;; Version: 0.3.2
  10. ;; This file is NOT part of GNU Emacs.
  11. ;; request.el is free software: you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation, either version 3 of the License, or
  14. ;; (at your option) any later version.
  15. ;; request.el is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;; GNU General Public License for more details.
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with request.el.
  21. ;; If not, see <http://www.gnu.org/licenses/>.
  22. ;;; Commentary:
  23. ;; Request.el is a HTTP request library with multiple backends. It
  24. ;; supports url.el which is shipped with Emacs and curl command line
  25. ;; program. User can use curl when s/he has it, as curl is more reliable
  26. ;; than url.el. Library author can use request.el to avoid imposing
  27. ;; external dependencies such as curl to users while giving richer
  28. ;; experience for users who have curl.
  29. ;; Following functions are adapted from GNU Emacs source code.
  30. ;; Free Software Foundation holds the copyright of them.
  31. ;; * `request--process-live-p'
  32. ;; * `request--url-default-expander'
  33. ;;; Code:
  34. (eval-when-compile
  35. (defvar url-http-method)
  36. (defvar url-http-response-status))
  37. (require 'cl-lib)
  38. (require 'url)
  39. (require 'mail-utils)
  40. (require 'autorevert)
  41. (defgroup request nil
  42. "Compatible layer for URL request in Emacs."
  43. :group 'comm
  44. :prefix "request-")
  45. (defconst request-version "0.3.0")
  46. ;;; Customize variables
  47. (defcustom request-storage-directory
  48. (concat (file-name-as-directory user-emacs-directory) "request")
  49. "Directory to store data related to request.el."
  50. :type 'directory)
  51. (defcustom request-curl "curl"
  52. "Executable for curl command."
  53. :type 'string)
  54. (defcustom request-curl-options nil
  55. "curl command options.
  56. List of strings that will be passed to every curl invocation. You can pass
  57. extra options here, like setting the proxy."
  58. :type '(repeat string))
  59. (defcustom request-backend (if (executable-find request-curl)
  60. 'curl
  61. 'url-retrieve)
  62. "Backend to be used for HTTP request.
  63. Automatically set to `curl' if curl command is found."
  64. :type '(choice (const :tag "cURL backend" curl)
  65. (const :tag "url-retrieve backend" url-retrieve)))
  66. (defcustom request-timeout nil
  67. "Default request timeout in second.
  68. `nil' means no timeout."
  69. :type '(choice (integer :tag "Request timeout seconds")
  70. (boolean :tag "No timeout" nil)))
  71. (defcustom request-temp-prefix "emacs-request"
  72. "Prefix for temporary files created by Request."
  73. :type 'string
  74. :risky t)
  75. (defcustom request-log-level -1
  76. "Logging level for request.
  77. One of `error'/`warn'/`info'/`verbose'/`debug'/`trace'/`blather'.
  78. -1 means no logging."
  79. :type '(choice (integer :tag "No logging" -1)
  80. (const :tag "Level error" error)
  81. (const :tag "Level warn" warn)
  82. (const :tag "Level info" info)
  83. (const :tag "Level Verbose" verbose)
  84. (const :tag "Level DEBUG" debug)
  85. (const :tag "Level TRACE" trace)
  86. (const :tag "Level BLATHER" blather)))
  87. (defcustom request-message-level 'warn
  88. "Logging level for request.
  89. See `request-log-level'."
  90. :type '(choice (integer :tag "No logging" -1)
  91. (const :tag "Level error" error)
  92. (const :tag "Level warn" warn)
  93. (const :tag "Level info" info)
  94. (const :tag "Level Verbose" verbose)
  95. (const :tag "Level DEBUG" debug)
  96. (const :tag "Level TRACE" trace)
  97. (const :tag "Level BLATHER" blather)))
  98. ;;; Utilities
  99. (defun request--safe-apply (function &rest arguments)
  100. "Apply FUNCTION with ARGUMENTS, suppressing any errors."
  101. (condition-case nil
  102. (apply #'apply function arguments)
  103. ((debug error))))
  104. (defun request--safe-call (function &rest arguments)
  105. (request--safe-apply function arguments))
  106. ;; (defun request--url-no-cache (url)
  107. ;; "Imitate `cache=false' of `jQuery.ajax'.
  108. ;; See: http://api.jquery.com/jQuery.ajax/"
  109. ;; ;; FIXME: parse URL before adding ?_=TIME.
  110. ;; (concat url (format-time-string "?_=%s")))
  111. (defmacro request--document-function (function docstring)
  112. "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
  113. (declare (indent defun)
  114. (doc-string 2))
  115. `(put ',function 'function-documentation ,docstring))
  116. (defun request--process-live-p (process)
  117. "Copied from `process-live-p' for backward compatibility (Emacs < 24).
  118. Adapted from lisp/subr.el.
  119. FSF holds the copyright of this function:
  120. Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012
  121. Free Software Foundation, Inc."
  122. (memq (process-status process) '(run open listen connect stop)))
  123. ;;; Logging
  124. (defconst request--log-level-def
  125. '(;; debugging
  126. (blather . 60) (trace . 50) (debug . 40)
  127. ;; information
  128. (verbose . 30) (info . 20)
  129. ;; errors
  130. (warn . 10) (error . 0))
  131. "Named logging levels.")
  132. (defun request--log-level-as-int (level)
  133. (if (integerp level)
  134. level
  135. (or (cdr (assq level request--log-level-def))
  136. 0)))
  137. (defvar request-log-buffer-name " *request-log*")
  138. (defun request--log-buffer ()
  139. (get-buffer-create request-log-buffer-name))
  140. (defmacro request-log (level fmt &rest args)
  141. (declare (indent 1))
  142. `(let ((level (request--log-level-as-int ,level))
  143. (log-level (request--log-level-as-int request-log-level))
  144. (msg-level (request--log-level-as-int request-message-level)))
  145. (when (<= level (max log-level msg-level))
  146. (let ((msg (format "[%s] %s" ,level
  147. (condition-case err
  148. (format ,fmt ,@args)
  149. (error (format "
  150. !!! Logging error while executing:
  151. %S
  152. !!! Error:
  153. %S"
  154. ',args err))))))
  155. (when (<= level log-level)
  156. (with-current-buffer (request--log-buffer)
  157. (setq buffer-read-only t)
  158. (let ((inhibit-read-only t))
  159. (goto-char (point-max))
  160. (insert msg "\n"))))
  161. (when (<= level msg-level)
  162. (message "REQUEST %s" msg))))))
  163. ;;; HTTP specific utilities
  164. (defconst request--url-unreserved-chars
  165. '(?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
  166. ?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
  167. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
  168. ?- ?_ ?. ?~)
  169. "`url-unreserved-chars' copied from Emacs 24.3 release candidate.
  170. This is used for making `request--urlencode-alist' RFC 3986 compliant
  171. for older Emacs versions.")
  172. (defun request--urlencode-alist (alist)
  173. ;; FIXME: make monkey patching `url-unreserved-chars' optional
  174. (let ((url-unreserved-chars request--url-unreserved-chars))
  175. (cl-loop for sep = "" then "&"
  176. for (k . v) in alist
  177. concat sep
  178. concat (url-hexify-string (format "%s" k))
  179. concat "="
  180. concat (url-hexify-string (format "%s" v)))))
  181. ;;; Header parser
  182. (defun request--parse-response-at-point ()
  183. "Parse the first header line such as \"HTTP/1.1 200 OK\"."
  184. (when (re-search-forward "\\=[ \t\n]*HTTP/\\([0-9\\.]+\\) +\\([0-9]+\\)" nil t)
  185. (list :version (match-string 1)
  186. :code (string-to-number (match-string 2)))))
  187. (defun request--goto-next-body ()
  188. (re-search-forward "^\r\n"))
  189. ;;; Response object
  190. (cl-defstruct request-response
  191. "A structure holding all relevant information of a request."
  192. status-code history data error-thrown symbol-status url
  193. done-p settings
  194. ;; internal variables
  195. -buffer -raw-header -timer -backend -tempfiles)
  196. (defmacro request--document-response (function docstring)
  197. (declare (indent defun)
  198. (doc-string 2))
  199. `(request--document-function ,function ,(concat docstring "
  200. .. This is an accessor for `request-response' object.
  201. \(fn RESPONSE)")))
  202. (request--document-response request-response-status-code
  203. "Integer HTTP response code (e.g., 200).")
  204. (request--document-response request-response-history
  205. "Redirection history (a list of response object).
  206. The first element is the oldest redirection.
  207. You can use restricted portion of functions for the response
  208. objects in the history slot. It also depends on backend. Here
  209. is the table showing what functions you can use for the response
  210. objects in the history slot.
  211. ==================================== ============== ==============
  212. Slots Backends
  213. ------------------------------------ -----------------------------
  214. \\ curl url-retrieve
  215. ==================================== ============== ==============
  216. request-response-url yes yes
  217. request-response-header yes no
  218. other functions no no
  219. ==================================== ============== ==============
  220. ")
  221. (request--document-response request-response-data
  222. "Response parsed by the given parser.")
  223. (request--document-response request-response-error-thrown
  224. "Error thrown during request.
  225. It takes the form of ``(ERROR-SYMBOL . DATA)``, which can be
  226. re-raised (`signal'ed) by ``(signal ERROR-SYMBOL DATA)``.")
  227. (request--document-response request-response-symbol-status
  228. "A symbol representing the status of request (not HTTP response code).
  229. One of success/error/timeout/abort/parse-error.")
  230. (request--document-response request-response-url
  231. "Final URL location of response.")
  232. (request--document-response request-response-done-p
  233. "Return t when the request is finished or aborted.")
  234. (request--document-response request-response-settings
  235. "Keyword arguments passed to `request' function.
  236. Some arguments such as HEADERS is changed to the one actually
  237. passed to the backend. Also, it has additional keywords such
  238. as URL which is the requested URL.")
  239. (defun request-response-header (response field-name)
  240. "Fetch the values of RESPONSE header field named FIELD-NAME.
  241. It returns comma separated values when the header has multiple
  242. field with the same name, as :RFC:`2616` specifies.
  243. Examples::
  244. (request-response-header response
  245. \"content-type\") ; => \"text/html; charset=utf-8\"
  246. (request-response-header response
  247. \"unknown-field\") ; => nil
  248. "
  249. (let ((raw-header (request-response--raw-header response)))
  250. (when raw-header
  251. (with-temp-buffer
  252. (erase-buffer)
  253. (insert raw-header)
  254. ;; ALL=t to fetch all fields with the same name to get comma
  255. ;; separated value [#rfc2616-sec4]_.
  256. (mail-fetch-field field-name nil t)))))
  257. ;; .. [#rfc2616-sec4] RFC2616 says this is the right thing to do
  258. ;; (see http://tools.ietf.org/html/rfc2616.html#section-4.2).
  259. ;; Python's requests module does this too.
  260. ;;; Backend dispatcher
  261. (defconst request--backend-alist
  262. '((url-retrieve
  263. . ((request . request--url-retrieve)
  264. (request-sync . request--url-retrieve-sync)
  265. (terminate-process . delete-process)
  266. (get-cookies . request--url-retrieve-get-cookies)))
  267. (curl
  268. . ((request . request--curl)
  269. (request-sync . request--curl-sync)
  270. (terminate-process . interrupt-process)
  271. (get-cookies . request--curl-get-cookies))))
  272. "Map backend and method name to actual method (symbol).
  273. It's alist of alist, of the following form::
  274. ((BACKEND . ((METHOD . FUNCTION) ...)) ...)
  275. It would be nicer if I can use EIEIO. But as CEDET is included
  276. in Emacs by 23.2, using EIEIO means abandon older Emacs versions.
  277. It is probably necessary if I need to support more backends. But
  278. let's stick to manual dispatch for now.")
  279. ;; See: (view-emacs-news "23.2")
  280. (defun request--choose-backend (method)
  281. "Return `fucall'able object for METHOD of current `request-backend'."
  282. (assoc-default
  283. method
  284. (or (assoc-default request-backend request--backend-alist)
  285. (error "%S is not valid `request-backend'." request-backend))))
  286. ;;; Cookie
  287. (defun request-cookie-string (host &optional localpart secure)
  288. "Return cookie string (like `document.cookie').
  289. Example::
  290. (request-cookie-string \"127.0.0.1\" \"/\") ; => \"key=value; key2=value2\"
  291. "
  292. (mapconcat (lambda (nv) (concat (car nv) "=" (cdr nv)))
  293. (request-cookie-alist host localpart secure)
  294. "; "))
  295. (defun request-cookie-alist (host &optional localpart secure)
  296. "Return cookies as an alist.
  297. Example::
  298. (request-cookie-alist \"127.0.0.1\" \"/\") ; => ((\"key\" . \"value\") ...)
  299. "
  300. (funcall (request--choose-backend 'get-cookies) host localpart secure))
  301. ;;; Main
  302. (cl-defun request-default-error-callback (url &key symbol-status
  303. &allow-other-keys)
  304. (request-log 'error
  305. "Error (%s) while connecting to %s." symbol-status url))
  306. (cl-defun request (url &rest settings
  307. &key
  308. (params nil)
  309. (data nil)
  310. (headers nil)
  311. (encoding 'utf-8)
  312. (error nil)
  313. (sync nil)
  314. (response (make-request-response))
  315. &allow-other-keys)
  316. "Send request to URL.
  317. Request.el has a single entry point. It is `request'.
  318. ==================== ========================================================
  319. Keyword argument Explanation
  320. ==================== ========================================================
  321. TYPE (string) type of request to make: POST/GET/PUT/DELETE
  322. PARAMS (alist) set \"?key=val\" part in URL
  323. DATA (string/alist) data to be sent to the server
  324. FILES (alist) files to be sent to the server (see below)
  325. PARSER (symbol) a function that reads current buffer and return data
  326. HEADERS (alist) additional headers to send with the request
  327. ENCODING (symbol) encoding for request body (utf-8 by default)
  328. SUCCESS (function) called on success
  329. ERROR (function) called on error
  330. COMPLETE (function) called on both success and error
  331. TIMEOUT (number) timeout in second
  332. STATUS-CODE (alist) map status code (int) to callback
  333. SYNC (bool) If `t', wait until request is done. Default is `nil'.
  334. ==================== ========================================================
  335. * Callback functions
  336. Callback functions STATUS, ERROR, COMPLETE and `cdr's in element of
  337. the alist STATUS-CODE take same keyword arguments listed below. For
  338. forward compatibility, these functions must ignore unused keyword
  339. arguments (i.e., it's better to use `&allow-other-keys' [#]_).::
  340. (CALLBACK ; SUCCESS/ERROR/COMPLETE/STATUS-CODE
  341. :data data ; whatever PARSER function returns, or nil
  342. :error-thrown error-thrown ; (ERROR-SYMBOL . DATA), or nil
  343. :symbol-status symbol-status ; success/error/timeout/abort/parse-error
  344. :response response ; request-response object
  345. ...)
  346. .. [#] `&allow-other-keys' is a special \"markers\" available in macros
  347. in the CL library for function definition such as `cl-defun' and
  348. `cl-function'. Without this marker, you need to specify all arguments
  349. to be passed. This becomes problem when request.el adds new arguments
  350. when calling callback functions. If you use `&allow-other-keys'
  351. (or manually ignore other arguments), your code is free from this
  352. problem. See info node `(cl) Argument Lists' for more information.
  353. Arguments data, error-thrown, symbol-status can be accessed by
  354. `request-response-data', `request-response-error-thrown',
  355. `request-response-symbol-status' accessors, i.e.::
  356. (request-response-data RESPONSE) ; same as data
  357. Response object holds other information which can be accessed by
  358. the following accessors:
  359. `request-response-status-code',
  360. `request-response-url' and
  361. `request-response-settings'
  362. * STATUS-CODE callback
  363. STATUS-CODE is an alist of the following format::
  364. ((N-1 . CALLBACK-1)
  365. (N-2 . CALLBACK-2)
  366. ...)
  367. Here, N-1, N-2,... are integer status codes such as 200.
  368. * FILES
  369. FILES is an alist of the following format::
  370. ((NAME-1 . FILE-1)
  371. (NAME-2 . FILE-2)
  372. ...)
  373. where FILE-N is a list of the form::
  374. (FILENAME &key PATH BUFFER STRING MIME-TYPE)
  375. FILE-N can also be a string (path to the file) or a buffer object.
  376. In that case, FILENAME is set to the file name or buffer name.
  377. Example FILES argument::
  378. `((\"passwd\" . \"/etc/passwd\") ; filename = passwd
  379. (\"scratch\" . ,(get-buffer \"*scratch*\")) ; filename = *scratch*
  380. (\"passwd2\" . (\"password.txt\" :file \"/etc/passwd\"))
  381. (\"scratch2\" . (\"scratch.txt\" :buffer ,(get-buffer \"*scratch*\")))
  382. (\"data\" . (\"data.csv\" :data \"1,2,3\\n4,5,6\\n\")))
  383. .. note:: FILES is implemented only for curl backend for now.
  384. As furl.el_ supports multipart POST, it should be possible to
  385. support FILES in pure elisp by making furl.el_ another backend.
  386. Contributions are welcome.
  387. .. _furl.el: http://code.google.com/p/furl-el/
  388. * PARSER function
  389. PARSER function takes no argument and it is executed in the
  390. buffer with HTTP response body. The current position in the HTTP
  391. response buffer is at the beginning of the buffer. As the HTTP
  392. header is stripped off, the cursor is actually at the beginning
  393. of the response body. So, for example, you can pass `json-read'
  394. to parse JSON object in the buffer. To fetch whole response as a
  395. string, pass `buffer-string'.
  396. When using `json-read', it is useful to know that the returned
  397. type can be modified by `json-object-type', `json-array-type',
  398. `json-key-type', `json-false' and `json-null'. See docstring of
  399. each function for what it does. For example, to convert JSON
  400. objects to plist instead of alist, wrap `json-read' by `lambda'
  401. like this.::
  402. (request
  403. \"http://...\"
  404. :parser (lambda ()
  405. (let ((json-object-type 'plist))
  406. (json-read)))
  407. ...)
  408. This is analogous to the `dataType' argument of jQuery.ajax_.
  409. Only this function can access to the process buffer, which
  410. is killed immediately after the execution of this function.
  411. * SYNC
  412. Synchronous request is functional, but *please* don't use it
  413. other than testing or debugging. Emacs users have better things
  414. to do rather than waiting for HTTP request. If you want a better
  415. way to write callback chains, use `request-deferred'.
  416. If you can't avoid using it (e.g., you are inside of some hook
  417. which must return some value), make sure to set TIMEOUT to
  418. relatively small value.
  419. Due to limitation of `url-retrieve-synchronously', response slots
  420. `request-response-error-thrown', `request-response-history' and
  421. `request-response-url' are unknown (always `nil') when using
  422. synchronous request with `url-retrieve' backend.
  423. * Note
  424. API of `request' is somewhat mixture of jQuery.ajax_ (Javascript)
  425. and requests.request_ (Python).
  426. .. _jQuery.ajax: http://api.jquery.com/jQuery.ajax/
  427. .. _requests.request: http://docs.python-requests.org
  428. "
  429. (request-log 'debug "REQUEST")
  430. ;; FIXME: support CACHE argument (if possible)
  431. ;; (unless cache
  432. ;; (setq url (request--url-no-cache url)))
  433. (unless error
  434. (setq error (apply-partially #'request-default-error-callback url))
  435. (setq settings (plist-put settings :error error)))
  436. (unless (or (stringp data)
  437. (null data)
  438. (assoc-string "Content-Type" headers t))
  439. (setq data (request--urlencode-alist data))
  440. (setq settings (plist-put settings :data data)))
  441. (when params
  442. (cl-assert (listp params) nil "PARAMS must be an alist. Given: %S" params)
  443. (setq url (concat url (if (string-match-p "\\?" url) "&" "?")
  444. (request--urlencode-alist params))))
  445. (setq settings (plist-put settings :url url))
  446. (setq settings (plist-put settings :response response))
  447. (setq settings (plist-put settings :encoding encoding))
  448. (setf (request-response-settings response) settings)
  449. (setf (request-response-url response) url)
  450. (setf (request-response--backend response) request-backend)
  451. ;; Call `request--url-retrieve'(`-sync') or `request--curl'(`-sync').
  452. (apply (if sync
  453. (request--choose-backend 'request-sync)
  454. (request--choose-backend 'request))
  455. url settings)
  456. response)
  457. (defun request--clean-header (response)
  458. "Strip off carriage returns in the header of REQUEST."
  459. (request-log 'debug "-CLEAN-HEADER")
  460. (let ((buffer (request-response--buffer response))
  461. (backend (request-response--backend response))
  462. sep-regexp)
  463. (if (eq backend 'url-retrieve)
  464. ;; FIXME: make this workaround optional.
  465. ;; But it looks like sometimes `url-http-clean-headers'
  466. ;; fails to cleanup. So, let's be bit permissive here...
  467. (setq sep-regexp "^\r?$")
  468. (setq sep-regexp "^\r$"))
  469. (when (buffer-live-p buffer)
  470. (with-current-buffer buffer
  471. (request-log 'trace
  472. "(buffer-string) at %S =\n%s" buffer (buffer-string))
  473. (goto-char (point-min))
  474. (when (and (re-search-forward sep-regexp nil t)
  475. ;; Are \r characters stripped off already?:
  476. (not (equal (match-string 0) "")))
  477. (while (re-search-backward "\r$" (point-min) t)
  478. (replace-match "")))))))
  479. (defun request--cut-header (response)
  480. "Cut the first header part in the buffer of RESPONSE and move it to
  481. raw-header slot."
  482. (request-log 'debug "-CUT-HEADER")
  483. (let ((buffer (request-response--buffer response)))
  484. (when (buffer-live-p buffer)
  485. (with-current-buffer buffer
  486. (goto-char (point-min))
  487. (when (re-search-forward "^$" nil t)
  488. (setf (request-response--raw-header response)
  489. (buffer-substring (point-min) (point)))
  490. (delete-region (point-min) (min (1+ (point)) (point-max))))))))
  491. (defun request-untrampify-filename (file)
  492. "Return FILE as the local file name."
  493. (or (file-remote-p file 'localname) file))
  494. (defun request--parse-data (response parser)
  495. "Run PARSER in current buffer if ERROR-THROWN is nil,
  496. then kill the current buffer."
  497. (request-log 'debug "-PARSE-DATA")
  498. (let ((buffer (request-response--buffer response)))
  499. (request-log 'debug "parser = %s" parser)
  500. (when (and (buffer-live-p buffer) parser)
  501. (with-current-buffer buffer
  502. (request-log 'trace
  503. "(buffer-string) at %S =\n%s" buffer (buffer-string))
  504. (unless (equal (request-response-status-code response) 204)
  505. (goto-char (point-min))
  506. (setf (request-response-data response) (funcall parser)))))))
  507. (cl-defun request--callback (buffer &key parser success error complete status-code response
  508. &allow-other-keys)
  509. (request-log 'debug "REQUEST--CALLBACK")
  510. (request-log 'debug "(buffer-string) =\n%s"
  511. (when (buffer-live-p buffer)
  512. (with-current-buffer buffer (buffer-string))))
  513. ;; Sometimes BUFFER given as the argument is different from the
  514. ;; buffer already set in RESPONSE. That's why it is reset here.
  515. ;; FIXME: Refactor how BUFFER is passed around.
  516. (setf (request-response--buffer response) buffer)
  517. (request-response--cancel-timer response)
  518. (cl-symbol-macrolet
  519. ((error-thrown (request-response-error-thrown response))
  520. (symbol-status (request-response-symbol-status response))
  521. (data (request-response-data response))
  522. (done-p (request-response-done-p response)))
  523. ;; Parse response header
  524. ;; Note: Try to do this even `error-thrown' is set. For example,
  525. ;; timeout error can occur while downloading response body and
  526. ;; header is there in that case.
  527. (let* ((response-url (request-response-url response))
  528. (scheme (and (stringp response-url)
  529. (url-type (url-generic-parse-url response-url))))
  530. (curl-file-p (and (stringp scheme)
  531. (not (string-match-p "^http" scheme))
  532. (eq (request-response--backend response) 'curl))))
  533. ;; curl does not add a header for say file:///foo/bar
  534. (unless curl-file-p
  535. (request--clean-header response)
  536. (request--cut-header response)))
  537. ;; Parse response body
  538. (request-log 'debug "error-thrown = %S" error-thrown)
  539. (condition-case err
  540. (request--parse-data response parser)
  541. (error
  542. ;; If there was already an error (e.g. server timeout) do not set the
  543. ;; status to `parse-error'.
  544. (unless error-thrown
  545. (setq symbol-status 'parse-error)
  546. (setq error-thrown err)
  547. (request-log 'error "Error from parser %S: %S" parser err))))
  548. (kill-buffer buffer)
  549. (request-log 'debug "data = %s" data)
  550. ;; Determine `symbol-status'
  551. (unless symbol-status
  552. (setq symbol-status (if error-thrown 'error 'success)))
  553. (request-log 'debug "symbol-status = %s" symbol-status)
  554. ;; Call callbacks
  555. (let ((args (list :data data
  556. :symbol-status symbol-status
  557. :error-thrown error-thrown
  558. :response response)))
  559. (let* ((success-p (eq symbol-status 'success))
  560. (cb (if success-p success error))
  561. (name (if success-p "success" "error")))
  562. (when cb
  563. (request-log 'debug "Executing %s callback." name)
  564. (request--safe-apply cb args)))
  565. (let ((cb (cdr (assq (request-response-status-code response)
  566. status-code))))
  567. (when cb
  568. (request-log 'debug "Executing status-code callback.")
  569. (request--safe-apply cb args)))
  570. (when complete
  571. (request-log 'debug "Executing complete callback.")
  572. (request--safe-apply complete args)))
  573. (setq done-p t)
  574. ;; Remove temporary files
  575. ;; FIXME: Make tempfile cleanup more reliable. It is possible
  576. ;; callback is never called.
  577. (request--safe-delete-files (request-response--tempfiles response))))
  578. (cl-defun request-response--timeout-callback (response)
  579. (request-log 'debug "-TIMEOUT-CALLBACK")
  580. (setf (request-response-symbol-status response) 'timeout)
  581. (setf (request-response-error-thrown response) '(error . ("Timeout")))
  582. (let* ((buffer (request-response--buffer response))
  583. (proc (and (buffer-live-p buffer) (get-buffer-process buffer))))
  584. (if proc
  585. ;; This will call `request--callback':
  586. (funcall (request--choose-backend 'terminate-process) proc)
  587. (cl-symbol-macrolet ((done-p (request-response-done-p response)))
  588. (unless done-p
  589. (when (buffer-live-p buffer)
  590. (cl-destructuring-bind (&key code &allow-other-keys)
  591. (with-current-buffer buffer
  592. (goto-char (point-min))
  593. (request--parse-response-at-point))
  594. (setf (request-response-status-code response) code)))
  595. (apply #'request--callback
  596. buffer
  597. (request-response-settings response))
  598. (setq done-p t))))))
  599. (defun request-response--cancel-timer (response)
  600. (request-log 'debug "REQUEST-RESPONSE--CANCEL-TIMER")
  601. (cl-symbol-macrolet ((timer (request-response--timer response)))
  602. (when timer
  603. (cancel-timer timer)
  604. (setq timer nil))))
  605. (defun request-abort (response)
  606. "Abort request for RESPONSE (the object returned by `request').
  607. Note that this function invoke ERROR and COMPLETE callbacks.
  608. Callbacks may not be called immediately but called later when
  609. associated process is exited."
  610. (cl-symbol-macrolet ((buffer (request-response--buffer response))
  611. (symbol-status (request-response-symbol-status response))
  612. (done-p (request-response-done-p response)))
  613. (let ((process (get-buffer-process buffer)))
  614. (unless symbol-status ; should I use done-p here?
  615. (setq symbol-status 'abort)
  616. (setq done-p t)
  617. (when (and
  618. (processp process) ; process can be nil when buffer is killed
  619. (request--process-live-p process))
  620. (funcall (request--choose-backend 'terminate-process) process))))))
  621. ;;; Backend: `url-retrieve'
  622. (cl-defun request--url-retrieve-preprocess-settings
  623. (&rest settings &key type data files headers &allow-other-keys)
  624. (when files
  625. (error "`url-retrieve' backend does not support FILES."))
  626. (when (and (equal type "POST")
  627. data
  628. (not (assoc-string "Content-Type" headers t)))
  629. (push '("Content-Type" . "application/x-www-form-urlencoded") headers)
  630. (setq settings (plist-put settings :headers headers)))
  631. settings)
  632. (cl-defun request--url-retrieve (url &rest settings
  633. &key type data timeout response
  634. &allow-other-keys
  635. &aux headers)
  636. (setq settings (apply #'request--url-retrieve-preprocess-settings settings))
  637. (setq headers (plist-get settings :headers))
  638. (let* ((url-request-extra-headers headers)
  639. (url-request-method type)
  640. (url-request-data data)
  641. (buffer (url-retrieve url #'request--url-retrieve-callback
  642. (nconc (list :response response) settings)))
  643. (proc (get-buffer-process buffer)))
  644. (request--install-timeout timeout response)
  645. (setf (request-response--buffer response) buffer)
  646. (process-put proc :request-response response)
  647. (request-log 'debug "Start querying: %s" url)
  648. (set-process-query-on-exit-flag proc nil)))
  649. (cl-defun request--url-retrieve-callback (status &rest settings
  650. &key response url
  651. &allow-other-keys)
  652. (request-log 'debug "-URL-RETRIEVE-CALLBACK")
  653. (request-log 'debug "status = %S" status)
  654. (when (featurep 'url-http)
  655. (request-log 'debug "url-http-method = %s" url-http-method)
  656. (request-log 'debug "url-http-response-status = %s" url-http-response-status)
  657. (setf (request-response-status-code response) url-http-response-status))
  658. (let ((redirect (plist-get status :redirect)))
  659. (when redirect
  660. (setf (request-response-url response) redirect)))
  661. ;; Construct history slot
  662. (cl-loop for v in
  663. (cl-loop with first = t
  664. with l = nil
  665. for (k v) on status by 'cddr
  666. when (eq k :redirect)
  667. if first
  668. do (setq first nil)
  669. else
  670. do (push v l)
  671. finally do (cons url l))
  672. do (let ((r (make-request-response :-backend 'url-retrieve)))
  673. (setf (request-response-url r) v)
  674. (push r (request-response-history response))))
  675. (cl-symbol-macrolet ((error-thrown (request-response-error-thrown response))
  676. (status-error (plist-get status :error)))
  677. (when (and error-thrown status-error)
  678. (request-log 'warn
  679. "Error %S thrown already but got another error %S from \
  680. `url-retrieve'. Ignoring it..." error-thrown status-error))
  681. (unless error-thrown
  682. (setq error-thrown status-error)))
  683. (apply #'request--callback (current-buffer) settings))
  684. (cl-defun request--url-retrieve-sync (url &rest settings
  685. &key type data timeout response
  686. &allow-other-keys
  687. &aux headers)
  688. (setq settings (apply #'request--url-retrieve-preprocess-settings settings))
  689. (setq headers (plist-get settings :headers))
  690. (let* ((url-request-extra-headers headers)
  691. (url-request-method type)
  692. (url-request-data data)
  693. (buffer (if timeout
  694. (with-timeout
  695. (timeout
  696. (setf (request-response-symbol-status response)
  697. 'timeout)
  698. (setf (request-response-done-p response) t)
  699. nil)
  700. (url-retrieve-synchronously url))
  701. (url-retrieve-synchronously url))))
  702. (setf (request-response--buffer response) buffer)
  703. ;; It seems there is no way to get redirects and URL here...
  704. (when buffer
  705. ;; Fetch HTTP response code
  706. (with-current-buffer buffer
  707. (goto-char (point-min))
  708. (cl-destructuring-bind (&key code &allow-other-keys)
  709. (request--parse-response-at-point)
  710. (setf (request-response-status-code response) code)))
  711. ;; Parse response body, etc.
  712. (apply #'request--callback buffer settings)))
  713. response)
  714. (defun request--url-retrieve-get-cookies (host localpart secure)
  715. (mapcar
  716. (lambda (c) (cons (url-cookie-name c) (url-cookie-value c)))
  717. (url-cookie-retrieve host localpart secure)))
  718. ;;; Backend: curl
  719. (defvar request--curl-cookie-jar nil
  720. "Override what the function `request--curl-cookie-jar' returns.
  721. Currently it is used only for testing.")
  722. (defun request--curl-cookie-jar ()
  723. "Cookie storage for curl backend."
  724. (or request--curl-cookie-jar
  725. (expand-file-name "curl-cookie-jar" request-storage-directory)))
  726. (defvar request--curl-capabilities-cache
  727. (make-hash-table :test 'eq :weakness 'key)
  728. "Used to avoid invoking curl more than once for version info. By skeeto/elfeed.")
  729. (defun request--curl-capabilities ()
  730. "Return capabilities plist for curl. By skeeto/elfeed.
  731. :version -- cURL's version string
  732. :compression -- non-nil if --compressed is supported."
  733. (let ((cache-value (gethash request-curl request--curl-capabilities-cache)))
  734. (if cache-value
  735. cache-value
  736. (with-temp-buffer
  737. (call-process request-curl nil t nil "--version")
  738. (let ((version
  739. (progn
  740. (setf (point) (point-min))
  741. (when (re-search-forward "[.0-9]+" nil t)
  742. (match-string 0))))
  743. (compression
  744. (progn
  745. (setf (point) (point-min))
  746. (not (null (re-search-forward "libz\\>" nil t))))))
  747. (setf (gethash request-curl request--curl-capabilities-cache)
  748. `(:version ,version :compression ,compression)))))))
  749. (defconst request--curl-write-out-template
  750. (if (eq system-type 'windows-nt)
  751. "\\n(:num-redirects %{num_redirects} :url-effective %{url_effective})"
  752. "\\n(:num-redirects %{num_redirects} :url-effective \"%{url_effective}\")"))
  753. (defun request--curl-mkdir-for-cookie-jar ()
  754. (ignore-errors
  755. (make-directory (file-name-directory (request--curl-cookie-jar)) t)))
  756. (cl-defun request--curl-command
  757. (url &key type data headers response files* unix-socket encoding
  758. &allow-other-keys
  759. &aux
  760. (cookie-jar (convert-standard-filename
  761. (expand-file-name (request--curl-cookie-jar)))))
  762. "BUG: Simultaneous requests are a known cause of cookie-jar corruption."
  763. (append
  764. (list request-curl "--silent" "--include"
  765. "--location"
  766. "--cookie" cookie-jar "--cookie-jar" cookie-jar
  767. "--write-out" request--curl-write-out-template)
  768. request-curl-options
  769. (when (plist-get (request--curl-capabilities) :compression) (list "--compressed"))
  770. (when unix-socket (list "--unix-socket" unix-socket))
  771. (cl-loop for (name filename path mime-type) in files*
  772. collect "--form"
  773. collect (format "%s=@%s;filename=%s%s" name
  774. (request-untrampify-filename path) filename
  775. (if mime-type
  776. (format ";type=%s" mime-type)
  777. "")))
  778. (when data
  779. (let ((tempfile (request--make-temp-file)))
  780. (push tempfile (request-response--tempfiles response))
  781. ;; We dynamic-let the global `buffer-file-coding-system' to `no-conversion'
  782. ;; in case the user-configured `encoding' doesn't fly.
  783. ;; If we do not dynamic-let the global, `select-safe-coding-system' would
  784. ;; plunge us into an undesirable interactive dialogue.
  785. (let ((buffer-file-coding-system-orig
  786. (default-value 'buffer-file-coding-system))
  787. (select-safe-coding-system-accept-default-p
  788. (lambda (&rest _) t)))
  789. (setf (default-value 'buffer-file-coding-system) 'no-conversion)
  790. (with-temp-file tempfile
  791. (setq-local buffer-file-coding-system encoding)
  792. (insert data))
  793. (setf (default-value 'buffer-file-coding-system)
  794. buffer-file-coding-system-orig))
  795. (list "--data-binary" (concat "@" (request-untrampify-filename tempfile)))))
  796. (when type (list "--request" type))
  797. (cl-loop for (k . v) in headers
  798. collect "--header"
  799. collect (format "%s: %s" k v))
  800. (list url)))
  801. (defun request--curl-normalize-files-1 (files get-temp-file)
  802. (cl-loop for (name . item) in files
  803. collect
  804. (cl-destructuring-bind
  805. (filename &key file buffer data mime-type)
  806. (cond
  807. ((stringp item) (list (file-name-nondirectory item) :file item))
  808. ((bufferp item) (list (buffer-name item) :buffer item))
  809. (t item))
  810. (unless (= (cl-loop for v in (list file buffer data) if v sum 1) 1)
  811. (error "Only one of :file/:buffer/:data must be given. Got: %S"
  812. (cons name item)))
  813. (cond
  814. (file
  815. (list name filename file mime-type))
  816. (buffer
  817. (let ((tf (funcall get-temp-file)))
  818. (with-current-buffer buffer
  819. (write-region (point-min) (point-max) tf nil 'silent))
  820. (list name filename tf mime-type)))
  821. (data
  822. (let ((tf (funcall get-temp-file)))
  823. (with-temp-buffer
  824. (erase-buffer)
  825. (insert data)
  826. (write-region (point-min) (point-max) tf nil 'silent))
  827. (list name filename tf mime-type)))))))
  828. (declare-function tramp-get-remote-tmpdir "tramp")
  829. (declare-function tramp-dissect-file-name "tramp")
  830. (defun request--make-temp-file ()
  831. "Create a temporary file."
  832. (if (file-remote-p default-directory)
  833. (let ((temporary-file-directory
  834. (tramp-get-remote-tmpdir (tramp-dissect-file-name default-directory))))
  835. (make-temp-file request-temp-prefix))
  836. (make-temp-file request-temp-prefix)))
  837. (defun request--curl-normalize-files (files)
  838. "Change FILES into a list of (NAME FILENAME PATH MIME-TYPE).
  839. This is to make `request--curl-command' cleaner by converting
  840. FILES to a homogeneous list. It returns a list (FILES* TEMPFILES)
  841. where FILES* is a converted FILES and TEMPFILES is a list of
  842. temporary file paths."
  843. (let (tempfiles noerror)
  844. (unwind-protect
  845. (let* ((get-temp-file (lambda ()
  846. (let ((tf (request--make-temp-file)))
  847. (push tf tempfiles)
  848. tf)))
  849. (files* (request--curl-normalize-files-1 files get-temp-file)))
  850. (setq noerror t)
  851. (list files* tempfiles))
  852. (unless noerror
  853. ;; Remove temporary files only when an error occurs
  854. (request--safe-delete-files tempfiles)))))
  855. (defun request--safe-delete-files (files)
  856. "Remove FILES but do not raise error when failed to do so."
  857. (mapc (lambda (f) (condition-case err
  858. (delete-file f)
  859. (error (request-log 'error
  860. "Failed delete file %s. Got: %S" f err))))
  861. files))
  862. (defun request--install-timeout (timeout response)
  863. "Out-of-band trigger after TIMEOUT seconds to prevent hangs."
  864. (when (numberp timeout)
  865. (request-log 'debug "Start timer: timeout=%s sec" timeout)
  866. (setf (request-response--timer response)
  867. (run-at-time timeout nil
  868. #'request-response--timeout-callback response))))
  869. (cl-defun request--curl (url &rest settings
  870. &key files timeout response encoding semaphore
  871. &allow-other-keys)
  872. "cURL-based request backend.
  873. Redirection handling strategy
  874. -----------------------------
  875. curl follows redirection when --location is given. However,
  876. all headers are printed when it is used with --include option.
  877. Number of redirects is printed out sexp-based message using
  878. --write-out option (see `request--curl-write-out-template').
  879. This number is used for removing extra headers and parse
  880. location header from the last redirection header.
  881. Sexp at the end of buffer and extra headers for redirects are
  882. removed from the buffer before it is shown to the parser function.
  883. "
  884. (request--curl-mkdir-for-cookie-jar)
  885. (let* (;; Use pipe instead of pty. Otherwise, curl process hangs.
  886. (process-connection-type nil)
  887. ;; Avoid starting program in non-existing directory.
  888. (home-directory (or (file-remote-p default-directory) "~/"))
  889. (default-directory (expand-file-name home-directory))
  890. (buffer (generate-new-buffer " *request curl*"))
  891. (command (cl-destructuring-bind
  892. (files* tempfiles)
  893. (request--curl-normalize-files files)
  894. (setf (request-response--tempfiles response) tempfiles)
  895. (apply #'request--curl-command url :files* files*
  896. :response response :encoding encoding settings)))
  897. (proc (apply #'start-process "request curl" buffer command)))
  898. (request--install-timeout timeout response)
  899. (request-log 'debug "Run: %s" (mapconcat 'identity command " "))
  900. (setf (request-response--buffer response) buffer)
  901. (process-put proc :request-response response)
  902. (set-process-coding-system proc encoding encoding)
  903. (set-process-query-on-exit-flag proc nil)
  904. (set-process-sentinel proc 'request--curl-callback)
  905. (when semaphore
  906. (set-process-sentinel proc (lambda (&rest args)
  907. (apply #'request--curl-callback args)
  908. (apply semaphore args))))))
  909. (defun request--curl-read-and-delete-tail-info ()
  910. "Read a sexp at the end of buffer and remove it and preceding character.
  911. This function moves the point at the end of buffer by side effect.
  912. See also `request--curl-write-out-template'."
  913. (let (forward-sexp-function)
  914. (goto-char (point-max))
  915. (forward-sexp -1)
  916. (let ((beg (1- (point))))
  917. (prog1
  918. (read (current-buffer))
  919. (delete-region beg (point-max))))))
  920. (defconst request--cookie-reserved-re
  921. (mapconcat
  922. (lambda (x) (concat "\\(^" x "\\'\\)"))
  923. '("comment" "commenturl" "discard" "domain" "max-age" "path" "port"
  924. "secure" "version" "expires")
  925. "\\|")
  926. "Uninterested keys in cookie.
  927. See \"set-cookie-av\" in http://www.ietf.org/rfc/rfc2965.txt")
  928. (defun request--consume-100-continue ()
  929. "Remove \"HTTP/* 100 Continue\" header at the point."
  930. (cl-destructuring-bind (&key code &allow-other-keys)
  931. (save-excursion (request--parse-response-at-point))
  932. (when (equal code 100)
  933. (delete-region (point) (progn (request--goto-next-body) (point)))
  934. ;; FIXME: Does this make sense? Is it possible to have multiple 100?
  935. (request--consume-100-continue))))
  936. (defun request--consume-200-connection-established ()
  937. "Remove \"HTTP/* 200 Connection established\" header at the point."
  938. (when (looking-at-p "HTTP/1\\.[0-1] 200 Connection established")
  939. (delete-region (point) (progn (request--goto-next-body) (point)))))
  940. (defun request--curl-preprocess ()
  941. "Pre-process current buffer before showing it to user."
  942. (let (history)
  943. (cl-destructuring-bind (&key num-redirects url-effective)
  944. (request--curl-read-and-delete-tail-info)
  945. (goto-char (point-min))
  946. (request--consume-100-continue)
  947. (request--consume-200-connection-established)
  948. (when (> num-redirects 0)
  949. (cl-loop with case-fold-search = t
  950. repeat num-redirects
  951. ;; Do not store code=100 headers:
  952. do (request--consume-100-continue)
  953. do (let ((response (make-request-response
  954. :-buffer (current-buffer)
  955. :-backend 'curl)))
  956. (request--clean-header response)
  957. (request--cut-header response)
  958. (push response history))))
  959. (goto-char (point-min))
  960. (nconc (list :num-redirects num-redirects :url-effective url-effective
  961. :history (nreverse history))
  962. (request--parse-response-at-point)))))
  963. (defun request--curl-absolutify-redirects (start-url redirects)
  964. "Convert relative paths in REDIRECTS to absolute URLs.
  965. START-URL is the URL requested."
  966. (cl-loop for prev-url = start-url then url
  967. for url in redirects
  968. unless (string-match url-nonrelative-link url)
  969. do (setq url (url-expand-file-name url prev-url))
  970. collect url))
  971. (defun request--curl-absolutify-location-history (start-url history)
  972. "Convert relative paths in HISTORY to absolute URLs.
  973. START-URL is the URL requested."
  974. (when history
  975. (setf (request-response-url (car history)) start-url))
  976. (cl-loop for url in (request--curl-absolutify-redirects
  977. start-url
  978. (mapcar (lambda (response)
  979. (request-response-header response "location"))
  980. history))
  981. for response in (cdr history)
  982. do (setf (request-response-url response) url)))
  983. (defun request--curl-callback (proc event)
  984. (let* ((buffer (process-buffer proc))
  985. (response (process-get proc :request-response))
  986. (symbol-status (request-response-symbol-status response))
  987. (settings (request-response-settings response)))
  988. (request-log 'debug "REQUEST--CURL-CALLBACK event = %s" event)
  989. (request-log 'debug "REQUEST--CURL-CALLBACK proc = %S" proc)
  990. (request-log 'debug "REQUEST--CURL-CALLBACK buffer = %S" buffer)
  991. (request-log 'debug "REQUEST--CURL-CALLBACK symbol-status = %S"
  992. symbol-status)
  993. (cond
  994. ((and (memq (process-status proc) '(exit signal))
  995. (/= (process-exit-status proc) 0))
  996. (setf (request-response-error-thrown response) (cons 'error event))
  997. (apply #'request--callback buffer settings))
  998. ((equal event "finished\n")
  999. (cl-destructuring-bind (&key code history error url-effective &allow-other-keys)
  1000. (condition-case err
  1001. (with-current-buffer buffer
  1002. (request--curl-preprocess))
  1003. ((debug error)
  1004. (list :error err)))
  1005. (request--curl-absolutify-location-history (plist-get settings :url)
  1006. history)
  1007. (setf (request-response-status-code response) code)
  1008. (setf (request-response-url response) url-effective)
  1009. (setf (request-response-history response) history)
  1010. (setf (request-response-error-thrown response)
  1011. (or error (and (numberp code) (>= code 400) `(error . (http ,code)))))
  1012. (apply #'request--callback buffer settings))))))
  1013. (defun request-auto-revert-notify-rm-watch ()
  1014. "Backport of M. Engdegard's fix of `auto-revert-notify-rm-watch'."
  1015. (let ((desc auto-revert-notify-watch-descriptor)
  1016. (table (if (boundp 'auto-revert--buffers-by-watch-descriptor)
  1017. auto-revert--buffers-by-watch-descriptor
  1018. auto-revert-notify-watch-descriptor-hash-list)))
  1019. (when desc
  1020. (let ((buffers (delq (current-buffer) (gethash desc table))))
  1021. (if buffers
  1022. (puthash desc buffers table)
  1023. (remhash desc table)))
  1024. (condition-case nil ;; ignore-errors doesn't work for me, sorry
  1025. (file-notify-rm-watch desc)
  1026. (error))
  1027. (remove-hook 'kill-buffer-hook #'auto-revert-notify-rm-watch t)))
  1028. (setq auto-revert-notify-watch-descriptor nil
  1029. auto-revert-notify-modified-p nil))
  1030. (cl-defun request--curl-sync (url &rest settings &key response &allow-other-keys)
  1031. (let (finished)
  1032. (prog1 (apply #'request--curl url
  1033. :semaphore (lambda (&rest _) (setq finished t))
  1034. settings)
  1035. (let ((proc (get-buffer-process (request-response--buffer response))))
  1036. (auto-revert-set-timer)
  1037. (when auto-revert-use-notify (request-auto-revert-notify-rm-watch))
  1038. (with-local-quit
  1039. (cl-loop with iter = 0
  1040. until (or (>= iter 10) finished)
  1041. do (accept-process-output nil 0.3)
  1042. unless (request--process-live-p proc)
  1043. do (cl-incf iter)
  1044. end
  1045. finally (when (>= iter 10)
  1046. (let ((m "request--curl-sync: semaphore never called"))
  1047. (princ (format "%s\n" m) #'external-debugging-output)
  1048. (request-log 'error m)))))))))
  1049. (defun request--curl-get-cookies (host localpart secure)
  1050. (request--netscape-get-cookies (request--curl-cookie-jar)
  1051. host localpart secure))
  1052. ;;; Netscape cookie.txt parser
  1053. (defun request--netscape-cookie-parse ()
  1054. "Parse Netscape/Mozilla cookie format."
  1055. (goto-char (point-min))
  1056. (let ((tsv-re (concat "^\\(#HttpOnly_\\)?"
  1057. (cl-loop repeat 6 concat "\\([^\t\n]+\\)\t")
  1058. "\\(.*\\)"))
  1059. cookies)
  1060. (while (not (eobp))
  1061. ;; HttpOnly cookie starts with '#' but its line is not comment line(#60)
  1062. (cond ((and (looking-at-p "^#") (not (looking-at-p "^#HttpOnly_"))) t)
  1063. ((looking-at-p "^$") t)
  1064. ((looking-at tsv-re)
  1065. (let ((cookie (cl-loop for i from 1 to 8 collect (match-string i))))
  1066. (push cookie cookies))))
  1067. (forward-line 1))
  1068. (setq cookies (nreverse cookies))
  1069. (cl-loop for (http-only domain flag path secure expiration name value) in cookies
  1070. collect (list domain
  1071. (equal flag "TRUE")
  1072. path
  1073. (equal secure "TRUE")
  1074. (null (not http-only))
  1075. (string-to-number expiration)
  1076. name
  1077. value))))
  1078. (defun request--netscape-filter-cookies (cookies host localpart secure)
  1079. (cl-loop for (domain _flag path secure-1 _http-only _expiration name value) in cookies
  1080. when (and (equal domain host)
  1081. (equal path localpart)
  1082. (or secure (not secure-1)))
  1083. collect (cons name value)))
  1084. (defun request--netscape-get-cookies (filename host localpart secure)
  1085. (when (file-readable-p filename)
  1086. (with-temp-buffer
  1087. (erase-buffer)
  1088. (insert-file-contents filename)
  1089. (request--netscape-filter-cookies (request--netscape-cookie-parse)
  1090. host localpart secure))))
  1091. (provide 'request)
  1092. ;;; request.el ends here