Emacs library to communicate with CouchDB databases.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

205 lines

  1. ;;; elexandria.el --- Alexandria-inspired library -*- lexical-binding: t; -*-
  2. ;;; Commentary:
  3. ;; A collection of Emacs macros and functions that seem like they
  4. ;; ought to be built-in. Inspired by CL's Alexandria package.
  5. ;;; License:
  6. ;; This program is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation, either version 3 of the License, or
  9. ;; (at your option) any later version.
  10. ;; This program is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; GNU General Public License for more details.
  14. ;; You should have received a copy of the GNU General Public License
  15. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  16. ;;; Code:
  17. (require 'url)
  18. ;;;;; URL-retrieve
  19. (defvar-local url-with-retrieve-async-timeout-timer nil
  20. "When a response buffer has a timeout, this variable stores the
  21. timer object so that it may be canceled if the request
  22. completes successfully.")
  23. (cl-defun url-with-retrieve-async (url &key cbargs silent inhibit-cookies data
  24. (method "GET") extra-headers query timeout success error
  25. parser (query-on-exit t))
  26. ;; FIXME: Ensure docstring is up-to-date with all recent changes.
  27. ;; TODO: Work around url calling callbacks multiple times. Sigh. See
  28. ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=20159> and
  29. ;; <https://github.com/skeeto/elisp-latch/issues/1#issuecomment-397910988>.
  30. "Retrieve URL asynchronously with `url-retrieve'.
  31. Arguments CBARGS, SILENT, and INHIBIT-COOKIES are passed to
  32. `url-retrieve', which see.
  33. DATA is bound to `url-request-data', which see.
  34. METHOD may be a symbol or string, which is bound as a capitalized
  35. string to `url-request-method', which see.
  36. EXTRA-HEADERS is an alist of header-value pairs, which is bound
  37. to `url-request-extra-headers', which see.
  38. QUERY is an alist of key-value pairs which is appended to the URL
  39. as the query.
  40. SUCCESS may be a function symbol or a body form, which is called
  41. with zero arguments upon successful completion of the request.
  42. In the call to SUCCESS, these variables will be bound:
  43. `status': See `url-retrieve'.
  44. `cbargs': See `url-retrieve'.
  45. `headers': The HTTP response headers as a string.
  46. `data': The HTTP response body as a string.
  47. ERROR may be a function symbol or a body form, which is called
  48. with zero arguments if the request fails. In the error call,
  49. these variables will be bound, in addition to the ones bound for
  50. SUCCESS:
  51. `errors': The list of `url' error symbols for the most recent
  52. error, e.g. `(error http 404)' for an HTTP 404 error.
  53. In the SUCCESS and ERROR calls, the current buffer is the
  54. response buffer, and it is automatically killed when the call
  55. completes.
  56. PARSER may be a function which parses the response body and
  57. returns a value to bind `data' to. The point is positioned after
  58. the headers, at the beginning of the body, before calling the
  59. function. For example, `json-read' may be used to parse JSON
  60. documents, after which the parsed JSON would be available in
  61. SUCCESS and ERROR as `data'. Or, if the body is not needed,
  62. `ignore' could be used to prevent the body from being parsed."
  63. (declare (indent defun))
  64. (let* ((success-body-fn (cl-typecase success
  65. (function success)
  66. (otherwise (byte-compile
  67. `(cl-function
  68. (lambda (&key cbargs status headers data)
  69. ,success))))))
  70. (error-body-fn (cl-typecase error
  71. (function error)
  72. (otherwise (byte-compile
  73. `(cl-function
  74. (lambda (&key cbargs status error headers data)
  75. ,error))))))
  76. (url-request-data data)
  77. (url-request-method (upcase (cl-typecase method
  78. (symbol (symbol-name method))
  79. (string method))))
  80. ;; TODO: Note that extra-headers must be an alist, and both keys and values must be strings.
  81. (url-request-extra-headers extra-headers)
  82. ;; FIXME: Document how `url-http-attempt-keepalives' is set.
  83. (url-http-attempt-keepalives (and (not timeout)
  84. url-http-attempt-keepalives))
  85. (callback (lambda (status &optional cbargs)
  86. (unwind-protect
  87. ;; This is called by `url-http-activate-callback' with the response buffer
  88. ;; as the current buffer.
  89. ;; Check for errors
  90. (pcase status
  91. ;; NOTE: This may need to be updated to correctly handle multiple errors
  92. (`(:error . ,_) (funcall error-body-fn
  93. :url url
  94. :cbargs cbargs
  95. :status status
  96. :error (plist-get status :error)))
  97. ((or 'nil
  98. `(:peer (:certificate . ,_))
  99. `(:redirect . ,_))
  100. (if (not url-http-end-of-headers)
  101. ;; HACK: It seems that the callback can be called with `nil' when
  102. ;; the connection fails before getting any headers, like:
  103. ;; url-http-end-of-document-sentinel(#<process matrix.org<5>>
  104. ;; "connection broken by remote peer\n"), in which case
  105. ;; `url-http-end-of-headers' is nil, so we need to call the error
  106. ;; fn. Would like to structure this more cleanly.
  107. (funcall error-body-fn
  108. :url url
  109. :cbargs cbargs
  110. :status status
  111. :error (plist-get status :error))
  112. (let ((headers (buffer-substring (point) url-http-end-of-headers))
  113. (data (if parser
  114. (progn
  115. (goto-char (1+ url-http-end-of-headers))
  116. (funcall parser))
  117. (buffer-substring (1+ url-http-end-of-headers) (point-max)))))
  118. (funcall success-body-fn
  119. :cbargs cbargs
  120. :status status
  121. :headers headers
  122. :data data))))
  123. (_ (error "Response status unrecognized; please report this error: %s" (pp-to-string status))))
  124. (when url-with-retrieve-async-timeout-timer
  125. (cancel-timer url-with-retrieve-async-timeout-timer))
  126. (unless (kill-buffer (current-buffer))
  127. (warn "Unable to kill response buffer: %s" (current-buffer))))))
  128. url-obj query-string query-params response-buffer)
  129. (when query
  130. ;; Build and append query string to URL
  131. (progn
  132. ;; Transform alist to plain list for `url-build-query-string'
  133. (setq query-params (cl-loop for (key . val) in query
  134. when val
  135. collect (list key val)))
  136. (setq url-obj (url-generic-parse-url url))
  137. (setq query-string (url-build-query-string query-params))
  138. (setf (url-filename url-obj) (concat (url-filename url-obj) "?" query-string))
  139. (setq url (url-recreate-url url-obj))))
  140. (setq response-buffer (url-retrieve url callback cbargs silent inhibit-cookies))
  141. (when timeout
  142. (with-current-buffer response-buffer
  143. (setq-local url-with-retrieve-async-timeout-timer
  144. (run-with-timer timeout nil
  145. (lambda ()
  146. (when (and (buffer-live-p response-buffer)
  147. (get-buffer-process response-buffer))
  148. (with-current-buffer response-buffer
  149. ;; Since we are handling the timeout ourselves, when we kill the
  150. ;; process, url.el considers it a "success", and therefore does not kill
  151. ;; the buffer (it seems to only kill its own buffers when it detects a
  152. ;; HTTP response error code, which we aren't getting). So we first add
  153. ;; an errors list to the first element of the callback args (the
  154. ;; `status' arg), then we delete the process, causing the process's
  155. ;; sentinel to be called, which then calls the callback, which detects
  156. ;; the error and calls the error-body-fn.
  157. ;; FIXME: Sometimes this seems to stop catching timeouts.
  158. ;; When that happens, it seems that the response buffer
  159. ;; process does not get deleted, as it remains listed in
  160. ;; `list-processes'. Maybe the solution is to bind
  161. ;; `url-http-attempt-keepalives' to nil when a timeout is
  162. ;; set, because maybe that would prevent processes from
  163. ;; being left around, which seems to contribute to the
  164. ;; problem.
  165. ;; NOTE: This may be loosely relevant: <https://github.com/jorgenschaefer/circe/issues/327>
  166. (setq url-callback-arguments (list (list :error 'timeout) url-callback-arguments))
  167. ;; Since `get-buffer-process' is a C function, we just call it again
  168. ;; instead of storing the buffer process in a variable.
  169. (delete-process (get-buffer-process response-buffer))
  170. (setq url-with-retrieve-async-timeout-timer nil))))))))
  171. (unless query-on-exit
  172. (set-process-query-on-exit-flag (get-buffer-process response-buffer) nil))
  173. response-buffer))
  174. ;;;; Footer
  175. (provide 'elexandria)
  176. ;;; elexandria.el ends here