[elpa] externals/srht 0e2038516e 01/27: Initial commit.

[ELPA Syncer]

branch: externals/srht
commit 0e2038516edcad1d5f7f38d1d87f423901567078
Author: Aleksandr Vityazev <avityazev@posteo.org>
Commit: Aleksandr Vityazev <avityazev@posteo.org>

    Initial commit.
---
 .gitignore    |   1 +
 Eldev         |   8 +++
 srht-paste.el | 173 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 srht-pkg.el   |  13 +++++
 srht.el       | 162 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 357 insertions(+)

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000000..50eaf51fd2
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+/.eldev/
diff --git a/Eldev b/Eldev
new file mode 100644
index 0000000000..4baf234893
--- /dev/null
+++ b/Eldev
@@ -0,0 +1,8 @@
+; -*- mode: emacs-lisp; lexical-binding: t -*-
+
+;; Uncomment some calls below as needed for your project.
+;(eldev-use-package-archive 'gnu)
+;(eldev-use-package-archive 'nongnu)
+;(eldev-use-package-archive 'melpa)
+
+(eldev-use-plugin 'autoloads)
diff --git a/srht-paste.el b/srht-paste.el
new file mode 100644
index 0000000000..e30b565350
--- /dev/null
+++ b/srht-paste.el
@@ -0,0 +1,173 @@
+;;; srht-paste.el --- Sourcehut paste                -*- lexical-binding: t; 
-*-
+
+;; Copyright © 2022 Aleksandr Vityazev <avityazev@posteo.org>
+
+;; Author: Aleksandr Vityazev <avityazev@posteo.org>
+;; Keywords: comm
+;; Package-Version: 0.1.0
+;; Homepage: https://sr.ht/~akagi/srht.el/
+;; Package-Requires: ((emacs "27.1"))
+
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;  https://man.sr.ht/paste.sr.ht/api.md#paste-resource
+;;
+
+;;; Code:
+
+(require 'srht)
+
+(defvar srht-paste-all-pastes nil
+  "Stores pastes info.")
+
+(defun srht-paste--make-crud (path &optional body)
+  "Make crud for paste service.
+PATH is the path for the URI.  BODY is the body sent to the URI."
+  (srht-generic-crud 'paste path body))
+
+(cl-defun srht-paste-make (&key (visibility "unlisted") (filename 'null) 
contents)
+  "Make paste parameters.
+VISIBILITY must be one of \"public\", \"private\", or \"unlisted\".
+FILENAME string or null by default.
+CONTENTS must be a UTF-8 encoded string; binary files are not allowed."
+  `((visibility . ,visibility)
+    (files . [((filename . ,filename)
+               (contents . ,contents))])))
+
+(defun srht-pastes ()
+  "Retrieve all the pastes that belong to the user."
+  (srht-paste--make-crud "/api/pastes"))
+
+(defun srht-paste-blob (sha)
+  "Retrieve a blob resource with the hash SHA."
+  (srht-paste--make-crud (format "/api/blobs/%s" sha)))
+
+(defun srht-paste--candidates ()
+  "Return completion candidates."
+  (seq-map (pcase-lambda ((map (:created c)
+                               (:visibility v)
+                               (:sha sha)
+                               (:files (seq (map (:filename fn))))))
+             (list fn c v sha))
+           (plist-get (or srht-paste-all-pastes
+                          (setq srht-paste-all-pastes
+                                (srht-retrive (srht-pastes))))
+                      :results)))
+
+(defun srht-paste--annot (str)
+  "Function to add annotations in the completions buffer for STR."
+  (pcase-let* (((seq _f c v _s) (assoc str (srht-paste--candidates)))
+               (l (- 40 (length (substring-no-properties str))))
+               (bb (make-string l (string-to-char " ")))
+               (sb (if (string= v "public") "      " "    ")))
+    (concat bb (format "%s%s%s" v sb c))))
+
+(defun srht-paste--sha ()
+  "Read a FILENAME in the minibuffer, with completion and return SHA."
+  (let* ((p (srht-paste--candidates))
+         (table
+          (lambda (string pred action)
+            (if (eq action 'metadata)
+                `(metadata
+                  (annotation-function . srht-paste--annot)
+                  (cycle-sort-function . identity)
+                  (display-sort-function . identity))
+              (complete-with-action action p string pred)))))
+    (car (last (assoc (completing-read "Select paste: " table) p)))))
+
+(defun srht-paste (&optional sha &rest details)
+  "Create, retrieve or delete a paste.
+
+When retrieving or deleting a paste SHA must the the hash
+corresponding to the paste.
+
+When creating a new paste, SHA must be nil and one has to
+specify the DETAILS (see `srht-paste-make') of the paste."
+  (cond
+   ((stringp sha)
+    (srht-paste--make-crud (format "/api/pastes/%s" sha)))
+   ((stringp (plist-get details :contents))
+    (apply #'srht-paste-make details))))
+
+(defun srht-paste--get-content ()
+  "Extract the content we want to paste.
+Either the active region or, if no region is active (i.e. text selected)
+the whole buffer."
+  (if (use-region-p)
+      (buffer-substring-no-properties (region-beginning) (region-end))
+    (buffer-string)))
+
+(defun srht-paste--kill-link (name sha)
+  "Make URL constructed from NAME and SHA the latest kill in the kill ring."
+  (kill-new (file-name-concat (srht--make-uri 'paste nil nil) name sha))
+  (message "Paste URL in kill-ring"))
+
+(defun srht-paste--else (plz-error)
+  "An optional callback function.
+Called when the request fails with one argument, a ‘plz-error’ struct 
PLZ-ERROR."
+  (pcase-let* (((cl-struct plz-error response) plz-error)
+               ((cl-struct plz-response status body) response))
+    (pcase status
+      (201 (pcase-let* ((json-object-type 'plist)
+                        (json-key-type 'keyword)
+                        (json-array-type 'list)
+                        ((map (:sha sha)
+                              (:user (map (:canonical_name name))))
+                         (json-read-from-string body)))
+             (srht-paste--kill-link name sha)
+             (srht-retrive (srht-pastes)
+                           :then (lambda (resp)
+                                   (setq srht-paste-all-pastes resp)))))
+      (204 (srht-retrive (srht-pastes)
+                         :then (lambda (resp)
+                                 (setq srht-paste-all-pastes resp)
+                                 (message "Deleted!"))))
+      (_ (error "Unkown error with status %s: %S" status plz-error)))))
+
+;;;###autoload
+(defun srht-paste-region (visibility filename)
+  "Paste region or buffer to sourcehut under FILENAME with VISIBILITY."
+  (interactive
+   (list (completing-read "Visibility: "
+                         '("private" "public" "unlisted") nil t)
+        (read-string (format "Filename (default: %s): " (buffer-name))
+                     nil nil (buffer-name))))
+  (let ((content (srht-paste--get-content)))
+    (srht-create
+     (srht-paste--make-crud
+      "/api/pastes"
+      (srht-paste nil :visibility visibility :filename filename :contents 
content))
+     :then (lambda (_resp))
+     :else #'srht-paste--else)))
+
+;;;###autoload
+(defun srht-paste-delete (sha)
+  "Detete paste with SHA."
+  (interactive
+   (list (srht-paste--sha)))
+  (srht-delete (srht-paste sha)
+               :then (lambda (resp)
+                       (message "%s" resp))
+               :else #'srht-paste--else))
+
+;;;###autoload
+(defun srht-paste-link (user)
+  "Kill the link of the selected paste owned by the USER."
+  (interactive (list (read-string "User: ")))
+  (srht-paste--kill-link user (srht-paste--sha)))
+
+(provide 'srht-paste)
+;;; srht-paste.el ends here
diff --git a/srht-pkg.el b/srht-pkg.el
new file mode 100644
index 0000000000..e90c4c1933
--- /dev/null
+++ b/srht-pkg.el
@@ -0,0 +1,13 @@
+;;; -*- no-byte-compile: t -*-
+(define-package
+  "srht"
+  "0.1.0"
+  "Sourcehut"
+  '((emacs "28.1"))
+  :authors '(("Aleksandr Vityazev" . "avityazev@posteo.org"))
+  :maintainer '("Aleksandr Vityazev" . "avityazev@posteo.org")
+  :keywords '("comm"))
+
+;; Local Variables:
+;; eval: (flymake-mode -1)
+;; End:
diff --git a/srht.el b/srht.el
new file mode 100644
index 0000000000..2748826a00
--- /dev/null
+++ b/srht.el
@@ -0,0 +1,162 @@
+;;; srht.el --- Sourcehut               -*- lexical-binding: t; -*-
+
+;; Copyright © 2022 Aleksandr Vityazev <avityazev@posteo.org>
+
+;; Author: Aleksandr Vityazev <avityazev@posteo.org>
+;; Keywords: comm
+;; Package-Version: 0.1.0
+;; Homepage: https://sr.ht/~akagi/srht.el/
+;; Keywords: comm
+;; Package-Requires: ((emacs "27.1") (plz "0.1-pre"))
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; comment
+;;
+
+;;; Code:
+(require 'cl-lib)
+(require 'plz)
+(require 'rx)
+(require 'auth-source)
+
+(defgroup srht nil
+  "Customize options."
+  :prefix "srht"
+  :group 'comm)
+
+(defcustom srht-domain "sr.ht"
+  "Sourcehut domain."
+  :type 'string
+  :group 'srht)
+
+(defcustom srht-token
+  (if-let ((f (plist-get (car (auth-source-search :host "paste.sr.ht"))
+                         :secret)))
+      (funcall f) "")
+  "Personal access token for Sourcehut instance."
+  :type 'string
+  :group 'srht)
+
+(cl-defun srht--build-uri-string (scheme &key host path query)
+  "Construct a URI string.
+SCHEME should be a symbol.  HOST should be strings or nil
+PATH should be strings or nil.  QUERY should be strings or nil."
+  (concat
+   (if scheme (concat (symbol-name scheme) ":") "")
+   (if host
+       (concat "//"
+               (if (string-match-p ":" host)
+                   (format "[%s]" host)
+                 host))
+     "")
+   (pcase path
+     ((or (pred null) (pred string-empty-p)) "")
+     ((rx bol "/" (zero-or-more alnum)) path)
+     (_ (error "Expected absolute path starting with \"/\" or empty string: 
%s" path)))
+   (if query (concat "?" query) "")))
+
+(defun srht--make-uri (service path query)
+  "Construct a URI for making a request to Sourcehut.
+SERVICE is name of the service, PATH is the path for the URI, and
+QUERY is the query for the URI."
+  (let ((host (format "%s.%s" service srht-domain)))
+    (srht--build-uri-string
+     'https :host host :path path :query query)))
+
+(defun srht--else (plz-error)
+  "An optional callback function.
+Called when the request fails with one argument, a ‘plz-error’ struct 
PLZ-ERROR."
+  (pcase-let* (((cl-struct plz-error response) plz-error)
+               ((cl-struct plz-response status) response))
+    (pcase status
+      (201 (message "Created. Successful with status %s." status))
+      (204 (message "No Content. Successful with status %s" status))
+      (_ (error "Unkown error with status %s: %S" status plz-error)))))
+
+(defun srht--as ()
+  "Parse and return the JSON object following point.
+A function, which is called in the response buffer with it
+narrowed to the response body."
+  (let ((json-object-type 'plist)
+        (json-key-type 'keyword)
+        (json-array-type 'list))
+    (json-read)))
+
+(cl-defun srht--api-request (method &key service path query
+                                    body (else #'srht--else)
+                                    form (then 'sync) (as #'srht--as)
+                                    &allow-other-keys)
+  "Request METHOD from SERVICE.
+Return the curl process object or, for a synchronous request, the
+selected result.
+
+HEADERS may be an alist of extra headers to send with the
+request.
+
+PATH is the path for the URI and QUERY is the query for the URI.
+
+If FORM is non nil, the content type used will be
+`multipart/from-data' instead of `application/json'.
+
+BODY is the body sent to the URI.
+
+AS selects the kind of result to pass to the callback function
+THEN (see `plz').
+THEN is a callback function, which is called in the response data.
+ELSE is an optional callback function called when the request
+fails with one argument, a `plz-error' struct."
+  (let ((uri (srht--make-uri service path query))
+        (content-type (if form "multipart-form-data" "application/json")))
+    (plz method uri
+      :headers `(,(cons "Content-Type" content-type)
+                 ,(cons "Authorization" (concat "token " srht-token)))
+      :body body
+      :then then
+      :else else
+      :as as)))
+
+(defun srht-generic-crud (service path &optional body form)
+  "Return a list of arguments to pass to `srht--make-crud-request'.
+SERVICE is the service to used, and PATH is the path for the URI.
+BODY is optional, if it is an empty list, the resulting list will not
+contain the body at all.  FORM is optional."
+  (let ((crud `(:service ,service :path ,path :form ,form)))
+    (if body
+        (append crud `(:body ,(json-encode body)))
+      crud)))
+
+(defun srht--make-crud-request (method args)
+  "Make API request with METHOD and ARGS."
+  (apply #'srht--api-request method (append (car args) (cdr args))))
+
+(defun srht-create (&rest args)
+  "Create an API request with ARGS using the POST method."
+  (srht--make-crud-request 'post args))
+
+(defun srht-retrive (&rest args)
+  "Create an API request with ARGS using the GET method."
+  (srht--make-crud-request 'get args))
+
+(defun srht-update (&rest args)
+  "Create an API request with ARGS using the PUT method."
+  (srht--make-crud-request 'put args))
+
+(defun srht-delete (&rest args)
+  "Create an API request with ARGS using the DELETE method."
+  (srht--make-crud-request 'delete args))
+
+(provide 'srht)
+;;; srht.el ends here