branch: externals/srht
commit 0e2038516edcad1d5f7f38d1d87f423901567078
Author: Aleksandr Vityazev <avitya...@posteo.org>
Commit: Aleksandr Vityazev <avitya...@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 <avitya...@posteo.org>
+
+;; Author: Aleksandr Vityazev <avitya...@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" . "avitya...@posteo.org"))
+ :maintainer '("Aleksandr Vityazev" . "avitya...@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 <avitya...@posteo.org>
+
+;; Author: Aleksandr Vityazev <avitya...@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
