dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

request.el (51958B)


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