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.

257 lines
9.4KB

  1. ;;; libelcouch.el --- Communication with CouchDB -*- lexical-binding: t; -*-
  2. ;; Copyright (C) 2018 Damien Cassou
  3. ;; Author: Damien Cassou <damien@cassou.me>
  4. ;; Keywords: tools
  5. ;; Url: https://gitlab.petton.fr/elcouch/libelcouch/
  6. ;; Package-requires: ((emacs "25.1"))
  7. ;; Version: 0.8.0
  8. ;; This program is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation, either version 3 of the License, or
  11. ;; (at your option) any later version.
  12. ;; This program is distributed in the hope that it will be useful,
  13. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;; GNU General Public License for more details.
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
  18. ;;; Commentary:
  19. ;; The package libelcouch is an Emacs library client to communicate with
  20. ;; CouchDB (https://couchdb.apache.org/), a database focusing on ease of
  21. ;; use and having a scalable architecture. For a user interface, please
  22. ;; check the elcouch project instead (which depends on this one).
  23. ;;; Code:
  24. (require 'cl-lib)
  25. (require 'elexandria)
  26. (require 'json)
  27. (require 'map)
  28. (require 'subr-x)
  29. ;;; Customization
  30. (defgroup libelcouch nil
  31. "View and manipulate CouchDB databases."
  32. :group 'external)
  33. (defcustom libelcouch-couchdb-instances nil
  34. "List of CouchDB instances."
  35. :type 'list)
  36. (defcustom libelcouch-timeout 10
  37. "Timeout in seconds for calls to the CouchDB instance.
  38. Number of seconds before a call to CouchDB without answer is
  39. considered to have failed."
  40. :type 'number)
  41. ;;; Structures
  42. (cl-defstruct (libelcouch-named-entity
  43. (:constructor libelcouch--named-entity-create)
  44. (:conc-name libelcouch--named-entity-))
  45. (name nil :read-only t))
  46. (cl-defstruct (libelcouch-instance
  47. (:include libelcouch-named-entity)
  48. (:constructor libelcouch--instance-create)
  49. (:conc-name libelcouch--instance-))
  50. (url nil :read-only t))
  51. (cl-defstruct (libelcouch-database
  52. (:include libelcouch-named-entity)
  53. (:constructor libelcouch--database-create)
  54. (:conc-name libelcouch--database-))
  55. (instance nil :read-only t))
  56. (cl-defstruct (libelcouch-document
  57. (:include libelcouch-named-entity)
  58. (:constructor libelcouch--document-create)
  59. (:conc-name libelcouch--document-))
  60. (database nil :read-only t))
  61. ;;; Accessors
  62. (cl-defgeneric libelcouch-entity-name ((entity libelcouch-named-entity))
  63. "Return the name of ENTITY."
  64. (libelcouch--named-entity-name entity))
  65. (cl-defgeneric libelcouch-entity-full-name ((entity libelcouch-named-entity))
  66. "Return the full name of ENTITY's parent followed by ENTITY name."
  67. (format "%s/%s"
  68. (libelcouch-entity-name (libelcouch-entity-parent entity))
  69. (libelcouch-entity-name entity)))
  70. (cl-defmethod libelcouch-entity-full-name ((entity libelcouch-instance))
  71. (libelcouch-entity-name entity))
  72. (cl-defgeneric libelcouch-entity-parent (entity)
  73. "Return the entity containing ENTITY.")
  74. (cl-defmethod libelcouch-entity-parent ((database libelcouch-database))
  75. (libelcouch--database-instance database))
  76. (cl-defmethod libelcouch-entity-parent ((document libelcouch-document))
  77. (libelcouch--document-database document))
  78. (cl-defgeneric libelcouch-entity-instance (entity)
  79. "Return the CouchDB instance of ENTITY.")
  80. (cl-defmethod libelcouch-entity-instance ((instance libelcouch-instance))
  81. instance)
  82. (cl-defmethod libelcouch-entity-instance ((database libelcouch-database))
  83. (libelcouch--database-instance database))
  84. (cl-defmethod libelcouch-entity-instance ((document libelcouch-document))
  85. (libelcouch-entity-instance (libelcouch--document-database document)))
  86. (cl-defgeneric libelcouch-entity-url (entity)
  87. "Return the url of ENTITY."
  88. (format "%s/%s"
  89. (libelcouch-entity-url (libelcouch-entity-parent entity))
  90. (libelcouch-entity-name entity)))
  91. (cl-defmethod libelcouch-entity-url ((instance libelcouch-instance))
  92. (libelcouch--instance-url instance))
  93. (defun libelcouch-entity-from-url (url)
  94. "Return an entity by reading URL, a string."
  95. (let* ((url-obj (url-generic-parse-url url))
  96. (host (url-host url-obj))
  97. (path (car (url-path-and-query url-obj)))
  98. (path-components (split-string path "/" t))
  99. ;; authority is the beginning of the url until the path starts:
  100. (authority (substring url 0 (unless (string-empty-p path)
  101. (- (length path)))))
  102. (instance (libelcouch--instance-create
  103. :name host
  104. :url authority))
  105. (database (when (and instance (>= (length path-components) 1))
  106. (libelcouch--database-create
  107. :name (car path-components)
  108. :instance instance)))
  109. (document (when (and database (>= (length path-components) 2))
  110. (libelcouch--document-create
  111. :name (cadr path-components)
  112. :database database))))
  113. (or document database instance)))
  114. (defun libelcouch-choose-instance ()
  115. "Ask user for a CouchDB instance among `libelcouch-couchdb-instances'."
  116. (let* ((instances (libelcouch-instances))
  117. (instance-name (completing-read "CouchDB instance: "
  118. (mapcar #'libelcouch-entity-name instances)
  119. nil
  120. t)))
  121. (cl-find instance-name instances :test #'string= :key #'libelcouch-entity-name)))
  122. ;;; Private helpers
  123. (cl-defgeneric libelcouch--entity-create-children-from-json (entity json)
  124. "Create and return children of ENTITY from a JSON object.")
  125. (cl-defmethod libelcouch--entity-create-children-from-json ((instance libelcouch-instance) json)
  126. (mapcar
  127. (lambda (database-name) (libelcouch--database-create :name database-name :instance instance))
  128. json))
  129. (cl-defmethod libelcouch--entity-create-children-from-json ((database libelcouch-database) json)
  130. (let ((documents-json (map-elt json 'rows)))
  131. (mapcar
  132. (lambda (document-json)
  133. (libelcouch--document-create
  134. :name (map-elt document-json 'id)
  135. :database database))
  136. documents-json)))
  137. (cl-defgeneric libelcouch--entity-children-url (entity)
  138. "Return the path to query all children of ENTITY.")
  139. (cl-defmethod libelcouch--entity-children-url ((instance libelcouch-instance))
  140. (format "%s/%s" (libelcouch-entity-url instance) "_all_dbs"))
  141. (cl-defmethod libelcouch--entity-children-url ((database libelcouch-database))
  142. (format "%s/%s" (libelcouch-entity-url database) "_all_docs"))
  143. (cl-defun libelcouch--request-error (&rest args &key error-thrown &allow-other-keys)
  144. "Report an error when communication with an instance fails."
  145. (message "Got error: %S" error-thrown))
  146. ;;; Navigating
  147. (defun libelcouch-instances ()
  148. "Return a list of couchdb instances built from `libelcouch-couchdb-instances'."
  149. (mapcar
  150. (lambda (instance-data)
  151. (libelcouch--instance-create
  152. :name (car instance-data)
  153. :url (cadr instance-data)))
  154. libelcouch-couchdb-instances))
  155. (cl-defgeneric libelcouch-entity-list (entity function)
  156. "Evaluate function with the children of ENTITY as parameter."
  157. (url-with-retrieve-async
  158. (url-encode-url (libelcouch--entity-children-url entity))
  159. :timeout libelcouch-timeout
  160. :extra-headers '(("Content-Type" . "application/json")
  161. ("Accept" . "application/json"))
  162. :parser 'json-read
  163. :success (cl-function
  164. (lambda (&key data &allow-other-keys)
  165. (let* ((children (libelcouch--entity-create-children-from-json entity data)))
  166. (funcall function children))))
  167. :error #'libelcouch--request-error)
  168. nil)
  169. (defun libelcouch-document-content (document function)
  170. "Evaluate FUNCTION with the content of DOCUMENT as parameter."
  171. (url-with-retrieve-async
  172. (url-encode-url (libelcouch-entity-url document))
  173. :timeout libelcouch-timeout
  174. :parser (lambda () (decode-coding-string (buffer-substring-no-properties (point) (point-max)) 'utf-8))
  175. :extra-headers '(("Accept" . "application/json"))
  176. :success (cl-function
  177. (lambda (&key data &allow-other-keys)
  178. (funcall function data)))
  179. :error #'libelcouch--request-error)
  180. nil)
  181. (defun libelcouch-document-save (document content function)
  182. "Evaluate FUNCTION when CONTENT is saved as new value for DOCUMENT."
  183. (url-with-retrieve-async
  184. (url-encode-url (libelcouch-entity-url document))
  185. :method "PUT"
  186. :extra-headers '(("Content-Type" . "application/json"))
  187. :data (or content (encode-coding-string (buffer-substring-no-properties (point-min) (point-max)) 'utf-8))
  188. :success (cl-function (lambda (&rest _args) (funcall function)))
  189. :error #'libelcouch--request-error)
  190. nil)
  191. (defun libelcouch-document-delete (document revision function)
  192. "Delete DOCUMENT at REVISION and evaluate FUNCTION."
  193. (url-with-retrieve-async
  194. (url-encode-url (libelcouch-entity-url document))
  195. :method "DELETE"
  196. :query `(("rev" . ,revision))
  197. :extra-headers '(("Content-Type" . "application/json")
  198. ("Accept" . "application/json"))
  199. :success (cl-function (lambda (&rest _args) (funcall function)))
  200. :error #'libelcouch--request-error)
  201. nil)
  202. (provide 'libelcouch)
  203. ;;; libelcouch.el ends here