[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/srht dd72e0f630 1/2: Ability to interact with multiple
|
From: |
ELPA Syncer |
|
Subject: |
[elpa] externals/srht dd72e0f630 1/2: Ability to interact with multiple instances. |
|
Date: |
Thu, 19 May 2022 11:57:49 -0400 (EDT) |
branch: externals/srht
commit dd72e0f6300f2285582a6c0a9350168308ccdebc
Author: Aleksandr Vityazev <avityazev@posteo.org>
Commit: Aleksandr Vityazev <avityazev@posteo.org>
Ability to interact with multiple instances.
* README: Add links to elpa badges. Add Copyright assignment section.
* lisp/srht-git: Add the required domain argument to functions. Update doc
strings.
* lisp/srht-paste: -/-/-.
* lisp/srht (srht-domain): Rename to srht-domains and change the type to
list.
(srht--make-uri, srht--api-request, srht-generic-crud): Add the required
domain argument.
(srht-read-domain, srht-read-visibility, srht-results-get): New functions.
(srht-annotation, srht-put): New macros.
---
README.md | 15 +++-
README.org | 11 ++-
lisp/srht-git.el | 217 +++++++++++++++++++++++++++--------------------------
lisp/srht-paste.el | 123 ++++++++++++++++--------------
lisp/srht.el | 81 ++++++++++++++++----
5 files changed, 269 insertions(+), 178 deletions(-)
diff --git a/README.md b/README.md
index 6e3bf4f9cc..2511824065 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,7 @@
+<a href="https://elpa.gnu.org/packages/srht.html";><img alt="GNU ELPA"
src="https://elpa.gnu.org/packages/srht.svg"/></a>
+
+<a href="https://elpa.gnu.org/devel/srht.html";><img alt="GNU-devel ELPA"
src="https://elpa.gnu.org/devel/srht.svg"/></a>
+
<a href="https://builds.sr.ht/~akagi/srht.el/commits/master/.build.yml";><img
alt="Build"
src="https://builds.sr.ht/~akagi/srht.el/commits/master/.build.yml.svg"/></a>
@@ -50,7 +54,7 @@ You also need to set srht-username:
If you are using a self-hosted instanse:
- (setq srht-domain DOMAIN)
+ (setq srht-domain '(DOMAIN ...))
# Commands
@@ -109,6 +113,15 @@ If you are using a self-hosted instanse:
</table>
+# Copyright assignment
+
+This package is part of [GNU Emacs](https://www.gnu.org/software/emacs/),
being distributed in [GNU ELPA](https://elpa.gnu.org/). Contributions
+to this project must follow GNU guidelines, which means that, as with other
+parts of Emacs, patches of more than a few lines must be accompanied by having
+assigned copyright for the contribution to the FSF. Contributors who wish to
do
+so may contact [emacs-devel@gnu.org](mailto:emacs-devel@gnu.org) to request
the assignment form.
+
+
# License
GPLv3
diff --git a/README.org b/README.org
index ccacc6632b..6008b2c295 100644
--- a/README.org
+++ b/README.org
@@ -1,5 +1,7 @@
#+OPTIONS: toc:nil
+#+html: <a href="https://elpa.gnu.org/packages/srht.html";><img alt="GNU ELPA"
src="https://elpa.gnu.org/packages/srht.svg"/></a>
+#+html: <a href="https://elpa.gnu.org/devel/srht.html";><img alt="GNU-devel
ELPA" src="https://elpa.gnu.org/devel/srht.svg"/></a>
#+html: <a
href="https://builds.sr.ht/~akagi/srht.el/commits/master/.build.yml";><img
alt="Build"
src="https://builds.sr.ht/~akagi/srht.el/commits/master/.build.yml.svg"/></a>
*** Version 0.1
@@ -54,7 +56,7 @@ You also need to set srht-username:
If you are using a self-hosted instanse:
#+begin_src elisp :lexical t
-(setq srht-domain DOMAIN)
+(setq srht-domain '(DOMAIN ...))
#+end_src
* Commands
@@ -68,6 +70,13 @@ If you are using a self-hosted instanse:
| =srht-paste-delete= | Detete paste with SHA |
| =srht-paste-region= | Paste region or buffer to sourcehut |
+* Copyright assignment
+
+This package is part of [[https://www.gnu.org/software/emacs/][GNU Emacs]],
being distributed in [[https://elpa.gnu.org/][GNU ELPA]]. Contributions
+to this project must follow GNU guidelines, which means that, as with other
+parts of Emacs, patches of more than a few lines must be accompanied by having
+assigned copyright for the contribution to the FSF. Contributors who wish to
do
+so may contact [[mailto:emacs-devel@gnu.org][emacs-devel@gnu.org]] to request
the assignment form.
* License
diff --git a/lisp/srht-git.el b/lisp/srht-git.el
index f317cc33ce..893734c12f 100644
--- a/lisp/srht-git.el
+++ b/lisp/srht-git.el
@@ -28,31 +28,32 @@
(require 'srht)
(defvar srht-git-repos nil
- "Authenticated user repos.")
+ "Authenticated user repos plist of the form (:domain repos ...).")
-(defun srht-git--make-crud (path &optional query body form)
- "Make crud for git service.
+(defun srht-git--make-crud (domain path &optional query body form)
+ "Make a crud for the git service for the DOMAIN of the Sourcehut instance.
PATH is the path for the URI. BODY is the body sent to the URI.
FORM is a content type. QUERY is the query for the URI."
- (srht-generic-crud 'git path query body form))
+ (declare (indent 1))
+ (srht-generic-crud domain 'git path query body form))
-(defun srht-git-user (&optional username)
- "Retrieves a user resource.
+(defun srht-git-user (domain &optional username)
+ "Retrieves a user resource from DOMAIN.
If USERNAME is nil, the authenticated user is assumed."
(let ((path (if username
(concat "/api/user/~" (string-trim-left username "~"))
"/api/user")))
- (srht-git--make-crud path)))
+ (srht-git--make-crud domain path)))
-(defun srht-git-repos (&optional username query)
- "Retrive list of repository resources owned by this USERNAME.
+(defun srht-git-repos (domain &optional username query)
+ "Retrive list of repository resources owned by this USERNAME from DOMAIN.
If USERNAME is nil the authenticated user is assumed.
QUERY is the query for the URI. To retrieve the next page of results,
add start=:id to your QUERY, using the :id given by \"next\"."
(let ((path (if username
(format "/api/~%s/repos" (string-trim-left username "~"))
"/api/repos")))
- (srht-git--make-crud path query)))
+ (srht-git--make-crud domain path query)))
(cl-defun srht-git-make (&key visibility description name)
"Make paste parameters.
@@ -65,8 +66,8 @@ NAME is repository name."
(description . ,description)
(visibility . ,visibility)))
-(defun srht-git-repo (repo-name &optional username &rest details)
- "Create, retrieve, delete or update a git repository.
+(defun srht-git-repo (domain repo-name &optional username &rest details)
+ "Create, retrieve, delete or update a git repository from DOMAIN.
When retrieving, deleting or updating a repository, REPO-NAME must be
the name of an existing repository.
@@ -80,16 +81,17 @@ When creating repository omit REPO-NAME and specify DETAILS
\(see `srht-git-make'\)."
(cond
((and (stringp repo-name) (stringp username))
- (srht-git--make-crud
- (format "/api/~%s/repos/%s" (string-trim-left username "~") repo-name)))
+ (srht-git--make-crud domain
+ (format "/api/~%s/repos/%s" (string-trim-left username "~") repo-name)))
((and (stringp repo-name) details)
- (srht-git--make-crud
- (format "/api/repos/%s" repo-name) nil (apply #'srht-git-make details)))
- ((stringp repo-name) (srht-git--make-crud (format "/api/repos/%s"
repo-name)))
- (t (srht-git--make-crud "/api/repos" nil (apply #'srht-git-make details)))))
-
-(defmacro srht-git--endpoint (endpoint name username &optional query body form)
- "Generate crud for ENDPOINT and repository NAME.
+ (srht-git--make-crud domain
+ (format "/api/repos/%s" repo-name) nil (apply #'srht-git-make details)))
+ ((stringp repo-name)
+ (srht-git--make-crud domain (format "/api/repos/%s" repo-name)))
+ (t (srht-git--make-crud domain "/api/repos" nil (apply #'srht-git-make
details)))))
+
+(defmacro srht-git--endpoint (domain endpoint name username &optional query
body form)
+ "Generate crud for ENDPOINT and repository NAME for DOMAIN.
If USERNAME is nil the authenticated user is assumed.
QUERY is the query for the URI. To retrieve the next page of results,
add start=:id to your QUERY, using the :id given by \"next\".
@@ -100,168 +102,169 @@ FORM is a content type."
(format "/api/~%s/repos/%s/%s"
(string-trim-left ,username "~") ,name ,endpoint)
(format "/api/repos/%s/%s" ,name ,endpoint))))
- (srht-git--make-crud ,path ,query ,body ,form))))
+ (srht-git--make-crud ,domain ,path ,query ,body ,form))))
-(defun srht-git--endpoint-widen (endpoint name end &optional username
body-or-query)
- "Extends the ENDPOINT for the repository NAME to include END.
+(defun srht-git--endpoint-widen (endpoint domain name end &optional username
body-or-query)
+ "Extend the ENDPOINT for the repository NAME from DOMAIN to include END.
If USERNAME is nil the authenticated user is assumed.
BODY-OR-QUERY is the body or query sent to the URI."
(let* ((plist (if body-or-query
- (funcall endpoint name username body-or-query)
- (funcall endpoint name username)))
+ (funcall domain endpoint name username body-or-query)
+ (funcall domain endpoint name username)))
(path (plist-get plist :path)))
(setf (plist-get plist :path)
(concat path "/" end))
plist))
-(defun srht-git--artifact (name username body)
+(defun srht-git--artifact (domain name username body)
"Helper function for `srht-git-repo-artifact'."
- (srht-git--endpoint "artifacts" name username body "multipart/form-data"))
+ (srht-git--endpoint domain "artifacts" name username body
"multipart/form-data"))
-(defun srht-git-repo-readme (name &optional username body form)
- "Retrieve, update or delete README override for repository NAME.
+(defun srht-git-repo-readme (domain name &optional username body form)
+ "Retrieve, update or delete README override for repository NAME from DOMAIN.
If USERNAME is nil the authenticated user is assumed.
BODY is the body sent to the URI. FORM is a content type."
- (srht-git--endpoint "readme" name username body form))
+ (srht-git--endpoint domain "readme" name username body form))
-(defun srht-git-repo-refs (name &optional username query)
- "Endpoints for fetching git data from repository NAME.
+(defun srht-git-repo-refs (domain name &optional username query)
+ "Endpoints for fetching git data from repository NAME from DOMAIN.
If USERNAME is nil the authenticated user is assumed.
QUERY is the query for the URI."
- (srht-git--endpoint "refs" name username query))
+ (srht-git--endpoint domain "refs" name username query))
-(defun srht-git-repo-log (name &optional username query)
- "List of the latest commit log for repository NAME.
+(defun srht-git-repo-log (domain name &optional username query)
+ "List of the latest commit log for repository NAME from DOMAIN.
If USERNAME is nil the authenticated user is assumed.
QUERY is the query for the URI."
- (srht-git--endpoint "log" name username query))
+ (srht-git--endpoint domain "log" name username query))
-(defun srht-git-repo-artifact (name ref body &optional username)
- "Attaches a file artifact to the specified REF and repository NAME.
+(defun srht-git-repo-artifact (domain name ref body &optional username)
+ "Attaches a file artifact to the specified REF and repository NAME from
DOMAIN.
Note: this endpoint does not accept JSON. Submit your request
as `multipart/form-data', with a single field: file in BODY."
- (srht-git--endpoint-widen #'srht-git--artifact name ref username body))
+ (srht-git--endpoint-widen #'srht-git--artifact domain name ref username
body))
-(defun srht-git-repo-log-ref (name ref &optional username query)
- "List of the latest commit resources starting from the given REF.
+(defun srht-git-repo-log-ref (domain name ref &optional username query)
+ "List of the latest commit resources starting from the given REF and DOMAIN.
NAME is a repository name. If USERNAME is nil the authenticated user
is assumed. QUERY is the query for the URI."
- (srht-git--endpoint-widen #'srht-git-repo-log name ref username query))
+ (srht-git--endpoint-widen #'srht-git-repo-log domain name ref username
query))
-(defun srht-git-repo-tree-ref (name ref &optional username query)
- "Return the tree resource for the given REF.
+(defun srht-git-repo-tree-ref (domain name ref &optional username query)
+ "Return the tree resource for the given REF from DOMAIN.
Following the parent trees until the requested tree is found.
In other words, this lists the contents of a subdirectory by path.
NAME is a repository name. If USERNAME is nil the authenticated user
is assumed. QUERY is the query for the URI."
- (srht-git--endpoint-widen #'srht-git-repo-tree name ref username query))
+ (srht-git--endpoint-widen #'srht-git-repo-tree domain name ref username
query))
-(defun srht-git-repo-tree-id (name id &optional username query)
- "Return the tree resource with the given ID.
+(defun srht-git-repo-tree-id (domain name id &optional username query)
+ "Return the tree resource with the given ID from DOMAIN.
NAME is a repository name. If USERNAME is nil the authenticated user
is assumed. QUERY is the query for the URI."
- (srht-git--endpoint-widen #'srht-git-repo-tree name id username query))
+ (srht-git--endpoint-widen #'srht-git-repo-tree domain name id username
query))
-(defun srht-git-repo-tree (name &optional username)
+(defun srht-git-repo-tree (domain name &optional username)
"Return the tree resource for the latest commit to the default branch.
+DOMAIN is the domain name of the Sourcehut instance.
NAME is a repository name. If USERNAME is nil the authenticated user
is assumed."
- (srht-git--endpoint "tree" name username))
+ (srht-git--endpoint domain "tree" name username))
-(defun srht-git--candidates ()
- "Return completion candidates."
+(defun srht-git--candidates (domain)
+ "Return completion candidates for DOMAIN."
(seq-map (pcase-lambda ((map (:created c)
(:visibility v)
(:name n)))
(list n c v))
- (plist-get (or srht-git-repos
- (setq srht-git-repos
- (srht-retrive (srht-git-repos))))
- :results)))
-
-(defun srht-git--annot (str)
- "Function to add annotations in the completions buffer for STR."
- (pcase-let* (((seq _n c v) (assoc str (srht-git--candidates)))
- (l (- 40 (length (substring-no-properties str))))
- (bb (make-string l (string-to-char " ")))
- (sb (cond
- ((string= v "public") " ")
- ((string= v "private") " ")
- ((string= v "unlisted") " "))))
- (concat bb (format "%s%s%s" v sb c))))
-
-(defun srht-git--repo-name-read ()
- "Read a repository name in the minibuffer, with completion."
+ (srht-results-get domain
+ (or srht-git-repos
+ (srht-put srht-git-repos
+ domain (srht-retrive (srht-git-repos domain)))))))
+
+(defun srht-git--annot (domain str)
+ "Function to add annotations in the completions buffer for STR and DOMAIN."
+ (srht-annotation (seq _n created visibility)
+ (srht-git--candidates domain) str))
+
+(defun srht-git--repo-name-read (domain)
+ "Read a repository name in the minibuffer, with completion.
+DOMAIN is the domain name of the Sourcehut instance."
(srht-read-with-annotaion "Select repository: "
- (srht-git--candidates) #'srht-git--annot 'sourcehut-git-repository))
+ (srht-git--candidates domain)
+ (lambda (str) (srht-git--annot domain str))
+ 'sourcehut-git-repository))
(defvar srht-git-repo-name-history nil
"History variable.")
-(defun srht-git--else (plz-error)
+(defun srht-git--else (domain plz-error)
"An optional callback function.
-Called when the request fails with one argument, a ‘plz-error’ struct
PLZ-ERROR."
+Called when the request fails with two arguments, a ‘plz-error’ struct
PLZ-ERROR
+and domain name DOMAIN."
(pcase-let* (((cl-struct plz-error response) plz-error)
((cl-struct plz-response status body) response))
(pcase status
(201 (srht-with-json-read-from-string body
(map (:name repo-name)
(:owner (map (:canonical_name username))))
- (srht-kill-link 'git username repo-name)
- (srht-retrive (srht-git-repos)
+ (srht-kill-link domain 'git username repo-name)
+ (srht-retrive (srht-git-repos domain)
:then (lambda (resp)
- (setq srht-git-repos resp)))))
- (204 (srht-retrive (srht-git-repos)
+ (srht-put srht-git-repos domain resp)))))
+ (204 (srht-retrive (srht-git-repos domain)
:then (lambda (resp)
- (setq srht-git-repos resp)
+ (srht-put srht-git-repos domain resp)
(message "Deleted!"))))
(_ (error "Unkown error with status %s: %S" status plz-error)))))
;;;###autoload
-(defun srht-git-repo-create (visibility name description)
- "Create repository NAME with selected VISIBILITY and DESCRIPTION."
+(defun srht-git-repo-create (domain visibility name description)
+ "Create the NAME repository on an instance with the domain name DOMAIN.
+Set VISIBILITY and DESCRIPTION."
(interactive
- (list (completing-read "Visibility: "
- '("private" "public" "unlisted") nil t)
+ (list (srht-read-domain "Instance: ")
+ (srht-read-visibility "Visibility: ")
(read-string "New git repository name: " nil
'srht-git-repo-name-history)
(read-string "Repository description (markdown): ")))
- (srht-create (srht-git-repo nil nil
+ (srht-create (srht-git-repo domain nil nil
:visibility visibility
:name name
:description description)
:then (lambda (_r))
- :else #'srht-git--else))
+ :else (lambda (err) (srht-git--else domain err))))
-(defun srht-git--find-info (repo-name)
- "Find repository information by REPO-NAME."
+(defun srht-git--find-info (domain repo-name)
+ "Find repository information by REPO-NAME from the DOMAIN instance."
(catch 'found
- (seq-doseq (repo (plist-get srht-git-repos :results))
+ (seq-doseq (repo (plist-get (plist-get srht-git-repos domain) :results))
(when (equal (cl-getf repo :name) repo-name)
(throw 'found repo)))))
;;;###autoload
-(defun srht-git-repo-update (repo-name visibility new-name description)
- "Update repository REPO-NAME.
+(defun srht-git-repo-update (domain repo-name visibility new-name description)
+ "Update the REPO-NAME repository from the DOMAIN instance.
Set VISIBILITY, NEW-NAME and DESCRIPTION."
(interactive
- (pcase-let* ((name (srht-git--repo-name-read))
+ (pcase-let* ((instance (srht-read-domain "Instance: "))
+ (name (srht-git--repo-name-read instance))
((map (:visibility v)
(:description d))
- (srht-git--find-info name)))
- (list name
- (completing-read "Visibility: "
- '("private" "public" "unlisted") nil t v)
+ (srht-git--find-info instance name)))
+ (list instance
+ name
+ (srht-read-visibility "Visibility: " v)
(read-string "Repository name: " nil
'srht-git-repo-name-history)
(read-string "Repository description (markdown): " d))))
(when (yes-or-no-p (format "Update %s repository?" repo-name))
- (srht-update (srht-git-repo repo-name nil
+ (srht-update (srht-git-repo domain repo-name nil
:visibility visibility
:name new-name
:description description)
- :else #'srht-git--else
+ :else (lambda (err) (srht-git--else domain err))
:then (lambda (_resp)
;; NOTE: resp examle
;; (:id 110277
@@ -271,19 +274,23 @@ Set VISIBILITY, NEW-NAME and DESCRIPTION."
;; :owner (:canonical_name ~akagi :name akagi)
;; :description nil
;; :visibility unlisted)
- (srht-retrive (srht-git-repos)
+ (message "Updated!")
+ (srht-retrive (srht-git-repos domain)
:then (lambda (resp)
- (setq srht-git-repos resp)))))))
+ (srht-put srht-git-repos domain
resp)
+ ))))))
;;;###autoload
-(defun srht-git-repo-delete (name)
- "Delete NAME repository."
- (interactive (list (srht-git--repo-name-read)))
+(defun srht-git-repo-delete (domain repo-name)
+ "Delete the REPO-NAME repository from the DOMAIN instance."
+ (interactive
+ (let ((instance (srht-read-domain "Instance: ")))
+ (list instance (srht-git--repo-name-read instance))))
(when (yes-or-no-p
- (format "This action cannot be undone.\n Delete %s repository?" name))
- (srht-delete (srht-git-repo name)
+ (format "This action cannot be undone.\n Delete %s repository?"
repo-name))
+ (srht-delete (srht-git-repo domain repo-name)
:then (lambda (_r))
- :else #'srht-git--else)))
+ :else (lambda (err) (srht-git--else domain err)))))
(provide 'srht-git)
;;; srht-git.el ends here
diff --git a/lisp/srht-paste.el b/lisp/srht-paste.el
index 5522529e7f..c09535a5f0 100644
--- a/lisp/srht-paste.el
+++ b/lisp/srht-paste.el
@@ -26,13 +26,13 @@
(require 'srht)
(defvar srht-paste-all-pastes nil
- "Stores pastes info.")
+ "Stores pastes plist of the form (:domain pastes ...).")
-(defun srht-paste--make-crud (path &optional query body)
- "Make crud for paste service.
+(defun srht-paste--make-crud (domain path &optional query body)
+ "Make crud for paste service for the DOMAIN of the Sourcehut instance.
PATH is the path for the URI. BODY is the body sent to the URI.
QUERY is the query for the URI."
- (srht-generic-crud 'paste path query body))
+ (srht-generic-crud domain 'paste path query body))
(cl-defun srht-paste-make (&key (visibility "unlisted") (filename 'null)
contents)
"Make paste parameters.
@@ -44,45 +44,51 @@ CONTENTS must be a UTF-8 encoded string; binary files are
not allowed."
(files . [((filename . ,filename)
(contents . ,contents))])))
-(defun srht-pastes (&optional query)
- "Retrieve all the pastes that belong to the user.
+(defun srht-pastes (domain &optional query)
+ "Get all pastes owned by the authenticated user and instance with DOMAIN.
QUERY is the query for the URI."
- (srht-paste--make-crud "/api/pastes" query))
+ (srht-paste--make-crud domain "/api/pastes" query))
-(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-blob (domain sha)
+ "Retrieve a blob resource with the hash SHA from the DOMAIN instance."
+ (srht-paste--make-crud domain (format "/api/blobs/%s" sha)))
-(defun srht-paste--candidates ()
- "Return completion candidates."
+(defun srht-paste--domain-results-get (domain pastes)
+ "Extract the value for the :results property.
+For the existing PASTES for the DOMAIN domain name."
+ (declare (indent 1))
+ (plist-get (plist-get pastes (intern domain)) :results))
+
+(defun srht-paste--candidates (domain)
+ "Return completion candidates for DOMAIN."
(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 ((cand (srht-paste--candidates)))
+ (srht-results-get domain
+ (or srht-paste-all-pastes
+ (srht-put srht-paste-all-pastes
+ domain (srht-retrive (srht-pastes domain)))))))
+
+(defun srht-paste--annot (domain str)
+ "Function to add annotations in the completions buffer for STR and DOMAIN."
+ (srht-annotation (seq _f created visibility)
+ (assoc str (srht-paste--candidates domain)) str))
+
+(defun srht-paste--sha (domain)
+ "Read a FILENAME in the minibuffer, with completion and return SHA.
+DOMAIN is the domain name of the Sourcehut instance."
+ (let ((cand (srht-paste--candidates domain)))
(car (last (assoc
(srht-read-with-annotaion
- "Select paste: " cand #'srht-paste--annot 'sourcehut-paste)
+ "Select paste: " cand
+ (lambda (str) (srht-paste--annot domain str))
+ 'sourcehut-paste)
cand)))))
-(defun srht-paste (&optional sha &rest details)
- "Create, retrieve or delete a paste.
+(defun srht-paste (domain &optional sha &rest details)
+ "Create, retrieve or delete a paste from DOMAIN.
When retrieving or deleting a paste SHA must the the hash
corresponding to the paste.
@@ -91,9 +97,9 @@ 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)))
+ (srht-paste--make-crud domain (format "/api/pastes/%s" sha)))
((stringp (plist-get details :contents))
- (srht-paste--make-crud "/api/pastes" nil (apply #'srht-paste-make
details)))))
+ (srht-paste--make-crud domain "/api/pastes" nil (apply #'srht-paste-make
details)))))
(defun srht-paste--get-content ()
"Extract the content we want to paste.
@@ -103,55 +109,62 @@ the whole buffer."
(buffer-substring-no-properties (region-beginning) (region-end))
(buffer-string)))
-(defun srht-paste--else (plz-error)
+(defun srht-paste--else (domain plz-error)
"An optional callback function.
-Called when the request fails with one argument, a ‘plz-error’ struct
PLZ-ERROR."
+Called when the request fails with one argument, a ‘plz-error’ struct PLZ-ERROR
+and domain name DOMAIN."
(pcase-let* (((cl-struct plz-error response) plz-error)
((cl-struct plz-response status body) response))
(pcase status
(201 (srht-with-json-read-from-string body
(map (:sha sha)
(:user (map (:canonical_name name))))
- (srht-kill-link 'paste name sha)
- (srht-retrive (srht-pastes)
+ (srht-kill-link domain 'paste name sha)
+ (srht-retrive (srht-pastes domain)
:then (lambda (resp)
- (setq srht-paste-all-pastes resp)))))
- (204 (srht-retrive (srht-pastes)
+ (srht-put srht-paste-all-pastes domain
resp)))))
+ (204 (srht-retrive (srht-pastes domain)
:then (lambda (resp)
- (setq srht-paste-all-pastes resp)
+ (srht-put srht-paste-all-pastes domain 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."
+(defun srht-paste-region (domain visibility filename)
+ "Paste region or buffer to Sourcehut instance with DOMAIN.
+Set FILENAME and VISIBILITY."
(interactive
- (list (completing-read "Visibility: "
- '("private" "public" "unlisted") nil t)
+ (list (srht-read-domain "Instance: ")
+ (srht-read-visibility "Visibility: ")
(read-string (format "Filename (default: %s): " (buffer-name))
nil nil (buffer-name))))
(let ((content (srht-paste--get-content)))
(srht-create
- (srht-paste nil :visibility visibility :filename filename :contents
content)
+ (srht-paste domain nil
+ :visibility visibility
+ :filename filename
+ :contents content)
:then (lambda (_r))
- :else #'srht-paste--else)))
+ :else (lambda (err) (srht-paste--else domain err)))))
;;;###autoload
-(defun srht-paste-delete (sha)
- "Detete paste with SHA."
+(defun srht-paste-delete (domain sha)
+ "Detete paste with SHA from the DOMAIN instance."
(interactive
- (list (srht-paste--sha)))
- (srht-delete (srht-paste sha)
+ (let ((instance (srht-read-domain "Instance: ")))
+ (list instance (srht-paste--sha instance))))
+ (srht-delete (srht-paste domain sha)
:then (lambda (_r))
- :else #'srht-paste--else))
+ :else (lambda (err) (srht-paste--else domain err))))
;;;###autoload
-(defun srht-paste-link ()
- "Kill the link of the selected paste owned by the USER."
- (interactive)
+(defun srht-paste-link (domain)
+ "Kill the link of the selected paste owned by the USER from the DOMAIN
instance."
+ (interactive (list (srht-read-domain "Instance: ")))
(when (string-empty-p srht-username)
(error "`srht-username' must be set"))
- (srht-kill-link 'paste (concat "~" srht-username) (srht-paste--sha)))
+ (srht-kill-link domain 'paste (concat "~" (string-trim-left srht-username
"~"))
+ (srht-paste--sha domain)))
(provide 'srht-paste)
;;; srht-paste.el ends here
diff --git a/lisp/srht.el b/lisp/srht.el
index 9fb12f684d..4db9090179 100644
--- a/lisp/srht.el
+++ b/lisp/srht.el
@@ -40,9 +40,11 @@
:prefix "srht"
:group 'comm)
-(defcustom srht-domain "sr.ht"
- "Sourcehut domain."
- :type 'string
+(defcustom srht-domains '("sr.ht")
+ "Sourcehut instance domain names."
+ :type '(list (repeat :tag "Domain"
+ :inline t
+ (string :format "%v")))
:group 'srht)
(defcustom srht-token
@@ -76,11 +78,13 @@ PATH should be strings or nil. QUERY should be strings or
nil."
(_ (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.
+(defun srht--make-uri (domain service path query)
+ "Construct a URI for making a request to Sourcehut DOMAIN.
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)))
+ (cl-assert (and (not (string-empty-p domain)) domain)
+ nil "Require domain")
+ (let ((host (format "%s.%s" service domain)))
(srht--build-uri-string
'https :host host :path path :query query)))
@@ -104,7 +108,7 @@ narrowed to the response body."
(json-read)))
;; TODO add body-type to use with `multipart/from-data'
-(cl-defun srht--api-request (method &key service path query
+(cl-defun srht--api-request (method &key domain service path query
body (else #'srht--else)
form (then 'sync) (as #'srht--as)
&allow-other-keys)
@@ -112,6 +116,8 @@ narrowed to the response body."
Return the curl process object or, for a synchronous request, the
selected result.
+DOMAIN is the domain name of the Sourcehut instance.
+
HEADERS may be an alist of extra headers to send with the
request.
@@ -126,9 +132,9 @@ 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."
- (when (or (string-empty-p srht-token) (not srht-token))
- (error "Need a token"))
- (let ((uri (srht--make-uri service path query))
+ (cl-assert (and (not (string-empty-p srht-token)) srht-token)
+ nil "Need a token")
+ (let ((uri (srht--make-uri domain service path query))
(content-type (or form "application/json")))
(plz method uri
:headers `(,(cons "Content-Type" content-type)
@@ -138,13 +144,15 @@ fails with one argument, a `plz-error' struct."
:else else
:as as)))
-(defun srht-generic-crud (service path &optional query body form)
+(defun srht-generic-crud (domain service path &optional query body form)
"Return a list of arguments to pass to `srht--make-crud-request'.
+DOMAIN is the domain name of the Sourcehut instance.
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. QUERY is the query for the
URI."
- (let ((crud `(:service ,service :path ,path :query , query :form ,form)))
+ (let ((crud `(:domain ,domain :service ,service
+ :path ,path :query , query :form ,form)))
(if body
(append crud `(:body ,(if form body (json-encode body))))
crud)))
@@ -187,12 +195,12 @@ completion function is trying to complete."
(cycle-sort-function . identity)
(display-sort-function . identity))
(complete-with-action action collection string pred)))))
- (completing-read prompt table)))
+ (completing-read prompt table nil t)))
-(defun srht-kill-link (service name resource)
+(defun srht-kill-link (domain service name resource)
"Make URL the latest kill in the kill ring.
-Constructed from SERVICE, NAME and RESOURCE."
- (kill-new (srht--make-uri service (format "/%s/%s" name resource) nil))
+Constructed from DOMAIN, SERVICE, NAME and RESOURCE."
+ (kill-new (srht--make-uri domain service (format "/%s/%s" name resource)
nil))
(message "URL in kill-ring"))
(defmacro srht-with-json-read-from-string (string pattern &rest body)
@@ -205,5 +213,46 @@ Bind it with the ‘pcase’ PATTERN and do BODY."
(,pattern (json-read-from-string ,string)))
,@body))
+(defun srht-read-domain (prompt)
+ "Read domain name of the Sourcehut instance from `srht-domains' collection.
+If the collection contains only one name, return it without completion.
+PROMPT is a string to prompt with; normally it ends in a colon and a space."
+ (if (eq (length srht-domains) 1)
+ (car srht-domains)
+ (completing-read prompt srht-domains nil t)))
+
+(defun srht-read-visibility (prompt &optional initial-input)
+ "Select a visibility through `completing-read'.
+PROMPT, INITIAL-INPUT see `completing-read' doc."
+ (completing-read prompt '("private" "public" "unlisted") nil t
initial-input))
+
+(defun srht-results-get (domain plist)
+ "Extract the value for the :results property.
+For the existing PLIST for the DOMAIN domain name."
+ (declare (indent 1))
+ (plist-get (plist-get plist (intern domain)) :results))
+
+(defmacro srht-put (plist domain val)
+ "Change value in PLIST of DOMAIN to VAL if is not nil."
+ (declare (indent 1))
+ `(when ,val (setq ,plist (plist-put ,plist (intern ,domain) ,val))))
+
+(defmacro srht-annotation (pattern candidates str)
+ "Annotate STR.
+The value of the first CANDIDATES elements whose car equal STR is bind
+to pcase PATTERN."
+ (declare (indent 1))
+ (let ((bb (gensym "bb"))
+ (sb (gensym "sb"))
+ (l (gensym "l")))
+ `(pcase-let* ((,pattern (assoc ,str ,candidates))
+ (,l (- 40 (length (substring-no-properties ,str))))
+ (,bb (make-string ,l (string-to-char " ")))
+ (,sb (cond
+ ((string= visibility "public") " ")
+ ((string= visibility "private") " ")
+ ((string= visibility "unlisted") " "))))
+ (concat ,bb (format "%s%s%s" visibility ,sb created)))))
+
(provide 'srht)
;;; srht.el ends here