Browse Source

Try replacing request with elexandria

elexandria
Damien Cassou 2 years ago
parent
commit
f836c50086
No known key found for this signature in database GPG Key ID: A7123815F5DCE914
3 changed files with 243 additions and 40 deletions
  1. +2
    -3
      Makefile
  2. +204
    -0
      elexandria.el
  3. +37
    -37
      libelcouch.el

+ 2
- 3
Makefile View File

@@ -1,7 +1,7 @@
SRCS = libelcouch.el
TESTS = test/libelcouch-test.el

LOAD_PATH = -L . -L ../package-lint -L ../request
LOAD_PATH = -L . -L ../package-lint

EMACSBIN ?= emacs
BATCH = $(EMACSBIN) -Q --batch $(LOAD_PATH) \
@@ -19,8 +19,7 @@ ci-dependencies:
# Install dependencies in ~/.emacs.d/elpa
$(BATCH) \
--funcall package-refresh-contents \
--eval "(package-install 'package-lint)" \
--eval "(package-install 'request)"
--eval "(package-install 'package-lint)"

check: lint test



+ 204
- 0
elexandria.el View File

@@ -0,0 +1,204 @@
;;; elexandria.el --- Alexandria-inspired library -*- lexical-binding: t; -*-

;;; Commentary:

;; A collection of Emacs macros and functions that seem like they
;; ought to be built-in. Inspired by CL's Alexandria package.

;;; License:

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.

;;; Code:

(require 'url)

;;;;; URL-retrieve

(defvar-local url-with-retrieve-async-timeout-timer nil
"When a response buffer has a timeout, this variable stores the
timer object so that it may be canceled if the request
completes successfully.")

(cl-defun url-with-retrieve-async (url &key cbargs silent inhibit-cookies data
(method "GET") extra-headers query timeout success error
parser (query-on-exit t))
;; FIXME: Ensure docstring is up-to-date with all recent changes.

;; TODO: Work around url calling callbacks multiple times. Sigh. See
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=20159> and
;; <https://github.com/skeeto/elisp-latch/issues/1#issuecomment-397910988>.
"Retrieve URL asynchronously with `url-retrieve'.

Arguments CBARGS, SILENT, and INHIBIT-COOKIES are passed to
`url-retrieve', which see.

DATA is bound to `url-request-data', which see.

METHOD may be a symbol or string, which is bound as a capitalized
string to `url-request-method', which see.

EXTRA-HEADERS is an alist of header-value pairs, which is bound
to `url-request-extra-headers', which see.

QUERY is an alist of key-value pairs which is appended to the URL
as the query.

SUCCESS may be a function symbol or a body form, which is called
with zero arguments upon successful completion of the request.
In the call to SUCCESS, these variables will be bound:

`status': See `url-retrieve'.
`cbargs': See `url-retrieve'.
`headers': The HTTP response headers as a string.
`data': The HTTP response body as a string.

ERROR may be a function symbol or a body form, which is called
with zero arguments if the request fails. In the error call,
these variables will be bound, in addition to the ones bound for
SUCCESS:

`errors': The list of `url' error symbols for the most recent
error, e.g. `(error http 404)' for an HTTP 404 error.

In the SUCCESS and ERROR calls, the current buffer is the
response buffer, and it is automatically killed when the call
completes.

PARSER may be a function which parses the response body and
returns a value to bind `data' to. The point is positioned after
the headers, at the beginning of the body, before calling the
function. For example, `json-read' may be used to parse JSON
documents, after which the parsed JSON would be available in
SUCCESS and ERROR as `data'. Or, if the body is not needed,
`ignore' could be used to prevent the body from being parsed."
(declare (indent defun))
(let* ((success-body-fn (cl-typecase success
(function success)
(otherwise (byte-compile
`(cl-function
(lambda (&key cbargs status headers data)
,success))))))
(error-body-fn (cl-typecase error
(function error)
(otherwise (byte-compile
`(cl-function
(lambda (&key cbargs status error headers data)
,error))))))
(url-request-data data)
(url-request-method (upcase (cl-typecase method
(symbol (symbol-name method))
(string method))))
;; TODO: Note that extra-headers must be an alist, and both keys and values must be strings.
(url-request-extra-headers extra-headers)
;; FIXME: Document how `url-http-attempt-keepalives' is set.
(url-http-attempt-keepalives (and (not timeout)
url-http-attempt-keepalives))
(callback (lambda (status &optional cbargs)
(unwind-protect
;; This is called by `url-http-activate-callback' with the response buffer
;; as the current buffer.

;; Check for errors
(pcase status
;; NOTE: This may need to be updated to correctly handle multiple errors
(`(:error . ,_) (funcall error-body-fn
:url url
:cbargs cbargs
:status status
:error (plist-get status :error)))
((or 'nil
`(:peer (:certificate . ,_))
`(:redirect . ,_))
(if (not url-http-end-of-headers)
;; HACK: It seems that the callback can be called with `nil' when
;; the connection fails before getting any headers, like:
;; url-http-end-of-document-sentinel(#<process matrix.org<5>>
;; "connection broken by remote peer\n"), in which case
;; `url-http-end-of-headers' is nil, so we need to call the error
;; fn. Would like to structure this more cleanly.
(funcall error-body-fn
:url url
:cbargs cbargs
:status status
:error (plist-get status :error))
(let ((headers (buffer-substring (point) url-http-end-of-headers))
(data (if parser
(progn
(goto-char (1+ url-http-end-of-headers))
(funcall parser))
(buffer-substring (1+ url-http-end-of-headers) (point-max)))))
(funcall success-body-fn
:cbargs cbargs
:status status
:headers headers
:data data))))
(_ (error "Response status unrecognized; please report this error: %s" (pp-to-string status))))
(when url-with-retrieve-async-timeout-timer
(cancel-timer url-with-retrieve-async-timeout-timer))
(unless (kill-buffer (current-buffer))
(warn "Unable to kill response buffer: %s" (current-buffer))))))
url-obj query-string query-params response-buffer)
(when query
;; Build and append query string to URL
(progn
;; Transform alist to plain list for `url-build-query-string'
(setq query-params (cl-loop for (key . val) in query
when val
collect (list key val)))
(setq url-obj (url-generic-parse-url url))
(setq query-string (url-build-query-string query-params))
(setf (url-filename url-obj) (concat (url-filename url-obj) "?" query-string))
(setq url (url-recreate-url url-obj))))
(setq response-buffer (url-retrieve url callback cbargs silent inhibit-cookies))
(when timeout
(with-current-buffer response-buffer
(setq-local url-with-retrieve-async-timeout-timer
(run-with-timer timeout nil
(lambda ()
(when (and (buffer-live-p response-buffer)
(get-buffer-process response-buffer))
(with-current-buffer response-buffer
;; Since we are handling the timeout ourselves, when we kill the
;; process, url.el considers it a "success", and therefore does not kill
;; the buffer (it seems to only kill its own buffers when it detects a
;; HTTP response error code, which we aren't getting). So we first add
;; an errors list to the first element of the callback args (the
;; `status' arg), then we delete the process, causing the process's
;; sentinel to be called, which then calls the callback, which detects
;; the error and calls the error-body-fn.

;; FIXME: Sometimes this seems to stop catching timeouts.
;; When that happens, it seems that the response buffer
;; process does not get deleted, as it remains listed in
;; `list-processes'. Maybe the solution is to bind
;; `url-http-attempt-keepalives' to nil when a timeout is
;; set, because maybe that would prevent processes from
;; being left around, which seems to contribute to the
;; problem.

;; NOTE: This may be loosely relevant: <https://github.com/jorgenschaefer/circe/issues/327>
(setq url-callback-arguments (list (list :error 'timeout) url-callback-arguments))
;; Since `get-buffer-process' is a C function, we just call it again
;; instead of storing the buffer process in a variable.
(delete-process (get-buffer-process response-buffer))
(setq url-with-retrieve-async-timeout-timer nil))))))))
(unless query-on-exit
(set-process-query-on-exit-flag (get-buffer-process response-buffer) nil))
response-buffer))

;;;; Footer

(provide 'elexandria)
;;; elexandria.el ends here

+ 37
- 37
libelcouch.el View File

@@ -5,7 +5,7 @@
;; Author: Damien Cassou <damien@cassou.me>
;; Keywords: tools
;; Url: https://gitlab.petton.fr/elcouch/libelcouch/
;; Package-requires: ((emacs "25.1") (request "0.3.0"))
;; Package-requires: ((emacs "25.1"))
;; Version: 0.8.0

;; This program is free software; you can redistribute it and/or modify
@@ -30,7 +30,7 @@

;;; Code:
(require 'cl-lib)
(require 'request)
(require 'elexandria)
(require 'json)
(require 'map)

@@ -203,53 +203,53 @@ considered to have failed."

(cl-defgeneric libelcouch-entity-list (entity function)
"Evaluate function with the children of ENTITY as parameter."
(request
(url-encode-url (libelcouch--entity-children-url entity))
:timeout libelcouch-timeout
:headers '(("Content-Type" . "application/json")
("Accept" . "application/json"))
:parser 'json-read
:success (cl-function
(lambda (&key data &allow-other-keys)
(let* ((children (libelcouch--entity-create-children-from-json entity data)))
(funcall function children))))
:error #'libelcouch--request-error)
(url-with-retrieve-async
(url-encode-url (libelcouch--entity-children-url entity))
:timeout libelcouch-timeout
:extra-headers '(("Content-Type" . "application/json")
("Accept" . "application/json"))
:parser 'json-read
:success (cl-function
(lambda (&key data &allow-other-keys)
(let* ((children (libelcouch--entity-create-children-from-json entity data)))
(funcall function children))))
:error #'libelcouch--request-error)
nil)

(defun libelcouch-document-content (document function)
"Evaluate FUNCTION with the content of DOCUMENT as parameter."
(request
(url-encode-url (libelcouch-entity-url document))
:timeout libelcouch-timeout
:parser (lambda () (decode-coding-string (buffer-substring-no-properties (point) (point-max)) 'utf-8))
:headers '(("Accept" . "application/json"))
:success (cl-function
(lambda (&key data &allow-other-keys)
(funcall function data)))
:error #'libelcouch--request-error)
(url-with-retrieve-async
(url-encode-url (libelcouch-entity-url document))
:timeout libelcouch-timeout
:parser (lambda () (decode-coding-string (buffer-substring-no-properties (point) (point-max)) 'utf-8))
:extra-headers '(("Accept" . "application/json"))
:success (cl-function
(lambda (&key data &allow-other-keys)
(funcall function data)))
:error #'libelcouch--request-error)
nil)

(defun libelcouch-document-save (document content function)
"Evaluate FUNCTION when CONTENT is saved as new value for DOCUMENT."
(request
(url-encode-url (libelcouch-entity-url document))
:type "PUT"
:headers '(("Content-Type" . "application/json"))
:data (or content (encode-coding-string (buffer-substring-no-properties (point-min) (point-max)) 'utf-8))
:success (cl-function (lambda (&rest _args) (funcall function)))
:error #'libelcouch--request-error)
(url-with-retrieve-async
(url-encode-url (libelcouch-entity-url document))
:method "PUT"
:extra-headers '(("Content-Type" . "application/json"))
:data (or content (encode-coding-string (buffer-substring-no-properties (point-min) (point-max)) 'utf-8))
:success (cl-function (lambda (&rest _args) (funcall function)))
:error #'libelcouch--request-error)
nil)

(defun libelcouch-document-delete (document revision function)
"Delete DOCUMENT at REVISION and evaluate FUNCTION."
(request
(url-encode-url (libelcouch-entity-url document))
:type "DELETE"
:params `(("rev" . ,revision))
:headers '(("Content-Type" . "application/json")
("Accept" . "application/json"))
:success (cl-function (lambda (&rest _args) (funcall function)))
:error #'libelcouch--request-error)
(url-with-retrieve-async
(url-encode-url (libelcouch-entity-url document))
:method "DELETE"
:query `(("rev" . ,revision))
:extra-headers '(("Content-Type" . "application/json")
("Accept" . "application/json"))
:success (cl-function (lambda (&rest _args) (funcall function)))
:error #'libelcouch--request-error)
nil)

(provide 'libelcouch)


Loading…
Cancel
Save