Compare commits

..

2 commits

Author SHA1 Message Date
ca697024fd
Rename package 2024-03-31 20:49:29 -04:00
e93990d325
Document almost everything.
Also, prepare to rename the package to sponsor-debian-pkg.el.
2024-03-31 20:48:56 -04:00

View file

@ -1,4 +1,4 @@
;;; sponsor-debian.el --- Make it easy to sponsor packages on Debian. ;;; sponsor-debian-pkg.el --- Make it easy to sponsor packages on Debian.
;;; ;;;
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -33,22 +33,7 @@
:group 'sdj/sponsor-debian-pkg :group 'sdj/sponsor-debian-pkg
:type 'string) :type 'string)
(defun sdj/sponsor--generate-sponsoree-candidates-from-dir () (defun sdj/sponsor-debian-pkg--generate-sponsoree-candidates ()
"Generate a list of sponsoree candidates from the contents of 'sdj/sponsor-debian-pkg-path'.
The idea is that each directory name inside that path corresponds
to a salsa.d.o username."
(flatten-tree
(mapcar
(lambda (e)
(let ((dirname (car e)))
(when (and (nth 2 e)
; Exclude "." and ".." from the list
(not (seq-contains-p '("." "..") dirname)))
dirname)))
(directory-files-and-attributes sdj/sponsor-debian-pkg-path))))
(defun sdj/sponsor--generate-sponsoree-candidates ()
"Generate a list of sponsoree candidates from salsa.d.o. "Generate a list of sponsoree candidates from salsa.d.o.
The idea is to query Debian Brasilia's 'docs' project, obtain a The idea is to query Debian Brasilia's 'docs' project, obtain a
@ -57,11 +42,11 @@ ever commented on those issues.
Return an alist of (user . username)." Return an alist of (user . username)."
(let* ((debian-bsb-users (plz 'get (let* ((debian-bsb-users (plz 'get
(concat sdj/sponsor-debian-pkg-salsa-api-url (concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url
"projects/" "projects/"
(url-hexify-string "debian-brasilia-team/docs") (url-hexify-string "debian-brasilia-team/docs")
"/issues?per_page=100&order_by=updated_at") "/issues?per_page=100&order_by=updated_at")
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
:timeout 60 :timeout 60
:connect-timeout 60 :connect-timeout 60
:as #'json-read))) :as #'json-read)))
@ -74,7 +59,7 @@ Return an alist of (user . username)."
(cons (format "%s (%s)" name username) username))) (cons (format "%s (%s)" name username) username)))
debian-bsb-users)))) debian-bsb-users))))
(defun sdj/sponsor--parse-teams () (defun sdj/sponsor-debian-pkg--parse-teams ()
"Parse a JSON representation of all teams which we are subscribed to. "Parse a JSON representation of all teams which we are subscribed to.
Return an alist of (team . id)." Return an alist of (team . id)."
@ -87,18 +72,25 @@ Return an alist of (team . id)."
(cons (alist-get 'full_path e) (alist-get 'id e)))) (cons (alist-get 'full_path e) (alist-get 'id e))))
parsedteams)))) parsedteams))))
(defun sdj/sponsor--api-endpoint (name) (defun sdj/sponsor-debian-pkg--api-endpoint (name)
(concat sdj/sponsor-debian-pkg-salsa-api-url name "/")) "Return the full URL for an API endpoint ending with 'NAME'.
(defun sdj/sponsor--generate-team-candidates () The endpoint will always end with a slash."
(plz 'get (sdj/sponsor--api-endpoint "namespaces") (concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url name "/"))
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token))
:as #'sdj/sponsor--parse-teams))
(defun sdj/sponsor--team-repo-exists-p (team repo) (defun sdj/sponsor-debian-pkg--generate-team-candidates ()
"Generate a list of candidates for team names.
The generated list is actually a list of namespaces the user is a member of."
(plz 'get (sdj/sponsor-debian-pkg--api-endpoint "namespaces")
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
:as #'sdj/sponsor-debian-pkg--parse-teams))
(defun sdj/sponsor-debian-pkg--team-repo-exists-p (team repo)
"Check if 'REPO' (under 'TEAM' namespace) exists."
(condition-case err (condition-case err
(let ((r (plz 'get (let ((r (plz 'get
(concat (sdj/sponsor--api-endpoint "projects") (concat (sdj/sponsor-debian-pkg--api-endpoint "projects")
(url-hexify-string (concat team "/" repo))) (url-hexify-string (concat team "/" repo)))
:as 'response))) :as 'response)))
(when (plz-response-p r) (when (plz-response-p r)
@ -107,87 +99,115 @@ Return an alist of (team . id)."
(404 nil)))) (404 nil))))
(plz-error nil))) (plz-error nil)))
(defun sdj/sponsor--sanitize-import-url (url) (defun sdj/sponsor-debian-pkg--sanitize-import-url (url)
"Sanitize the git import URL to be used when creating a new project.
This will always make sure to replace 'git@salsa.debian.org:'
with 'https://salsa.debian.org/', and append a '.git' suffix if
needed."
(concat (string-replace "git@salsa.debian.org:" (concat (string-replace "git@salsa.debian.org:"
"https://salsa.debian.org/" "https://salsa.debian.org/"
url) url)
(unless (string-suffix-p ".git" url) (unless (string-suffix-p ".git" url)
".git"))) ".git")))
(defun sdj/sponsor--parse-new-repo-clone-url () (defun sdj/sponsor-debian-pkg--parse-new-repo-clone-url ()
"Parse the JSON returned when creating a new project, returning its clone URL."
(let ((parsenewrepo (json-read))) (let ((parsenewrepo (json-read)))
(alist-get 'ssh_url_to_repo parsenewrepo))) (alist-get 'ssh_url_to_repo parsenewrepo)))
(defun sdj/sponsor--create-team-repo (team projname repourl) (defun sdj/sponsor-debian-pkg--create-team-repo (team projname &optional import-repourl)
(plz 'post (sdj/sponsor--api-endpoint "projects") "Create a repository named 'PROJNAME' under 'TEAM' namespace.
If 'IMPORT-REPOURL' is provided, use it as the initial import."
(plz 'post (sdj/sponsor-debian-pkg--api-endpoint "projects")
:headers `(("Content-Type" . "application/json") :headers `(("Content-Type" . "application/json")
("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) ("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
:body (json-encode :body (json-encode
(delete nil (delete nil
`(("name" . ,projname) `(("name" . ,projname)
("description" . ,(concat "Debian package for " projname)) ("description" . ,(concat "Debian package for " projname))
,(when repourl ,(when import-repourl
`("import_url" . ,(sdj/sponsor--sanitize-import-url repourl))) `("import_url" . ,(sdj/sponsor-debian-pkg--sanitize-import-url import-repourl)))
("namespace_id" . ,(cdr team)) ("namespace_id" . ,(cdr team))
("initialize_with_readme" . false)))) ("initialize_with_readme" . false))))
:as #'sdj/sponsor--parse-new-repo-clone-url)) :as #'sdj/sponsor-debian-pkg--parse-new-repo-clone-url))
(defun sdj/sponsor--make-team-repo-url (team projname) (defun sdj/sponsor-debian-pkg--make-team-repo-url (team projname)
"Given 'TEAM' and 'PROJNAME', return the repository URL.
This URL is used for cloning purposes, and therefore starts with
'git@salsa.debian.org:'."
(concat "git@salsa.debian.org:" (concat "git@salsa.debian.org:"
(car team) "/" (car team) "/"
projname ".git")) projname ".git"))
(defun sdj/sponsor--get-or-create-team-repo (team projname repourl &optional dontask-p) (defun sdj/sponsor-debian-pkg--get-or-create-team-repo (team projname &options import-repourl dontask-p)
(if (sdj/sponsor--team-repo-exists-p (car team) projname) "Get or create a new repository under 'TEAM'.
(sdj/sponsor--make-team-repo-url team projname)
If 'IMPORT-REPOURL' is provided, use it as the initial repository content.
If 'DONTASK-P' is t, don't ask whether the user would like to
create the repository."
(if (sdj/sponsor-debian-pkg--team-repo-exists-p (car team) projname)
(sdj/sponsor-debian-pkg--make-team-repo-url team projname)
(when (or dontask-p (when (or dontask-p
(y-or-n-p "Would you like to create the repository under the team's namespace? ")) (y-or-n-p "Would you like to create the repository under the team's namespace? "))
(message "Creating the team repository (%s/%s.git)..." (message "Creating the team repository (%s/%s.git)..."
(car team) projname) (car team) projname)
(sdj/sponsor--create-team-repo team projname repourl)))) (sdj/sponsor-debian-pkg--create-team-repo team projname import-repourl))))
(defun sdj/sponsor--confirm-username (user) (defun sdj/sponsor-debian-pkg--confirm-username (user)
"Confirm if 'USER' exists."
(let ((u (plz 'get (let ((u (plz 'get
(concat sdj/sponsor-debian-pkg-salsa-api-url "users?username=" (url-hexify-string user)) (concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url "users?username=" (url-hexify-string user))
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
:as #'json-read))) :as #'json-read)))
(and (not (seq-empty-p u)) user))) (and (not (seq-empty-p u)) user)))
(defun sdj/sponsor--confirm-team (team) (defun sdj/sponsor-debian-pkg--confirm-team (team)
"Confirm if 'TEAM' exists.
Note that internally teams are actually treated as namespaces."
(condition-case err (condition-case err
(let ((u (plz 'get (let ((u (plz 'get
(concat sdj/sponsor-debian-pkg-salsa-api-url "namespaces/" (url-hexify-string team)) (concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url "namespaces/" (url-hexify-string team))
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
:as #'json-read))) :as #'json-read)))
(and (not (seq-empty-p u)) (cons team (alist-get 'id u)))) (and (not (seq-empty-p u)) (cons team (alist-get 'id u))))
(plz-error nil))) (plz-error nil)))
(defun sdj/sponsor--read-sponsoree-choice () (defun sdj/sponsor-debian-pkg--read-sponsoree-choice ()
(let* ((sponsoreealist (sdj/sponsor--generate-sponsoree-candidates)) "Read the sponsoree."
(let* ((sponsoreealist (sdj/sponsor-debian-pkg--generate-sponsoree-candidates))
(sponsoreechoice (completing-read "Sponsoree: " sponsoreealist))) (sponsoreechoice (completing-read "Sponsoree: " sponsoreealist)))
(or (alist-get sponsoreechoice sponsoreealist nil nil #'string=) (or (alist-get sponsoreechoice sponsoreealist nil nil #'string=)
(sdj/sponsor--confirm-username sponsoreechoice)))) (sdj/sponsor-debian-pkg--confirm-username sponsoreechoice))))
(defun sdj/sponsor--read-team-choice (&optional dontask-p) (defun sdj/sponsor-debian-pkg--read-team-choice (&optional dontask-p)
"Read the team."
(when (or dontask-p (when (or dontask-p
(y-or-n-p "Would you like to specify a team? ")) (y-or-n-p "Would you like to specify a team? "))
(let* ((teamalist (sdj/sponsor--generate-team-candidates)) (let* ((teamalist (sdj/sponsor-debian-pkg--generate-team-candidates))
(teamchoice (completing-read "Team: " teamalist nil t))) (teamchoice (completing-read "Team: " teamalist nil t)))
(cons teamchoice (cons teamchoice
(alist-get teamchoice teamalist nil nil #'string=))))) (alist-get teamchoice teamalist nil nil #'string=)))))
(defun sdj/sponsor--read-string-or-nil (prompt) (defun sdj/sponsor-debian-pkg--read-string-or-nil (prompt)
"Read a string from the minibuffer or nil."
(let ((r (read-from-minibuffer prompt))) (let ((r (read-from-minibuffer prompt)))
(unless (string-empty-p r) (unless (string-empty-p r)
r))) r)))
(defun sdj/sponsor--read-repourl (&optional prompt) (defun sdj/sponsor-debian-pkg--read-repourl (&optional prompt)
(let ((r (sdj/sponsor--read-string-or-nil (or prompt "Read a repository URL."
(let ((r (sdj/sponsor-debian-pkg--read-string-or-nil (or prompt
"Repository URL: ")))) "Repository URL: "))))
(when r (when r
(string-remove-suffix "/" r)))) (string-remove-suffix "/" r))))
(defun sdj/sponsor--get-namespace-from-repourl (repourl) (defun sdj/sponsor-debian-pkg--get-namespace-from-repourl (repourl)
"Given a repository URL 'REPOURL', return its namespace."
(let ((str-no-url (or (and (string-prefix-p "git@salsa.debian.org:" repourl) (let ((str-no-url (or (and (string-prefix-p "git@salsa.debian.org:" repourl)
(string-remove-prefix "git@salsa.debian.org:" repourl)) (string-remove-prefix "git@salsa.debian.org:" repourl))
(and (string-prefix-p "https://salsa.debian.org/" repourl) (and (string-prefix-p "https://salsa.debian.org/" repourl)
@ -199,19 +219,18 @@ Return an alist of (team . id)."
(file-name-directory (file-name-directory
(string-remove-suffix "/" str-no-url)))))) (string-remove-suffix "/" str-no-url))))))
;; (replace-regexp-in-string (defun sdj/sponsor-debian-pkg--get-project-from-repourl (repourl)
;; (rx "Given a repository URL 'REPOURL', return its project name."
;; (or "git@salsa.debian.org:" "https://salsa.debian.org/")
;; (group (one-or-more (not "/"))) (minimal-match (one-or-more not-newline)))
;; "\\1" repourl nil nil nil ))
(defun sdj/sponsor--get-project-from-repourl (repourl)
(file-name-base (string-remove-suffix "/" repourl))) (file-name-base (string-remove-suffix "/" repourl)))
(defun sdj/sponsor--what-is-this-namespace (namespace) (defun sdj/sponsor-debian-pkg--what-is-this-namespace (namespace)
(let* ((username (sdj/sponsor--confirm-username namespace)) "Given a namespace 'NAMESPACE', identify it.
Return an alist of (ID . DATA), where 'ID' is either 'username or
'team, and 'DATA' is information about the namespace."
(let* ((username (sdj/sponsor-debian-pkg--confirm-username namespace))
(team (and (not username) (team (and (not username)
(sdj/sponsor--confirm-team namespace)))) (sdj/sponsor-debian-pkg--confirm-team namespace))))
(cond (cond
(username (username
(cons 'username username)) (cons 'username username))
@ -220,33 +239,38 @@ Return an alist of (team . id)."
(t (t
(error "Could not find namespace '%s'" namespace))))) (error "Could not find namespace '%s'" namespace)))))
(defun sdj/sponsor-init--read-args () (defun sdj/sponsor-debian-pkg--read-args ()
(let* ((repo (sdj/sponsor--read-repourl)) "Read arguments from the minibuffer."
(namespace (sdj/sponsor--get-namespace-from-repourl repo)) (let* ((repo (sdj/sponsor-debian-pkg--read-repourl))
(result (sdj/sponsor--what-is-this-namespace namespace)) (namespace (sdj/sponsor-debian-pkg--get-namespace-from-repourl repo))
(result (sdj/sponsor-debian-pkg--what-is-this-namespace namespace))
(team (or (and (eq (car result) 'team) (team (or (and (eq (car result) 'team)
(cdr result)) (cdr result))
(sdj/sponsor--read-team-choice))) (sdj/sponsor-debian-pkg--read-team-choice)))
(sponsoree (or (and (eq (car result) 'username) (sponsoree (or (and (eq (car result) 'username)
(cdr result)) (cdr result))
(sdj/sponsor--read-sponsoree-choice)))) (sdj/sponsor-debian-pkg--read-sponsoree-choice))))
(when (y-or-n-p (format "Sponsoree: [%s]; Team: [%s]; OK? " sponsoree (or (car team) "none"))) (when (y-or-n-p (format "Sponsoree: [%s]; Team: [%s]; OK? " sponsoree (or (car team) "none")))
(list sponsoree team repo)))) (list sponsoree team repo))))
;;;###autoload ;;;###autoload
(defun sdj/sponsor-create-team-repo (team projname sponsoree-repourl) (defun sdj/sponsor-debian-pkg-create-team-repo (team projname sponsoree-repourl)
"Create a team repository.
If 'SPONSOREE-REPOURL' is provided, use it as a base for the
initial repository."
(interactive (interactive
(list (list
(sdj/sponsor--read-team-choice t) (sdj/sponsor-debian-pkg--read-team-choice t)
(sdj/sponsor--read-string-or-nil "Project name: ") (sdj/sponsor-debian-pkg--read-string-or-nil "Project name: ")
(sdj/sponsor--read-repourl "Sponsoree repository to import into the new one (optional): "))) (sdj/sponsor-debian-pkg--read-repourl "Sponsoree repository to import into the new one (optional): ")))
(when (or (not team) (not projname)) (when (or (not team) (not projname))
(error "You must provide a valid team and a project name")) (error "You must provide a valid team and a project name"))
(let ((team-repourl (sdj/sponsor--get-or-create-team-repo team projname sponsoree-repourl t))) (let ((team-repourl (sdj/sponsor-debian-pkg--get-or-create-team-repo team projname sponsoree-repourl t)))
(when sponsoree-repourl (when sponsoree-repourl
(when-let* ((sponsoree (sdj/sponsor--get-namespace-from-repourl sponsoree-repourl)) (when-let* ((sponsoree (sdj/sponsor-debian-pkg--get-namespace-from-repourl sponsoree-repourl))
(sponsoreedir (file-name-as-directory (sponsoreedir (file-name-as-directory
(concat sdj/sponsor-debian-pkg-path sponsoree))) (concat sdj/sponsor-debian-pkg-debian-pkg-path sponsoree)))
(projdir (file-name-as-directory (projdir (file-name-as-directory
(concat sponsoreedir projname))) (concat sponsoreedir projname)))
(team-gitdir (file-name-as-directory (team-gitdir (file-name-as-directory
@ -269,14 +293,14 @@ Return an alist of (team . id)."
"fetch" sponsoree)))))))) "fetch" sponsoree))))))))
;;;###autoload ;;;###autoload
(defun sdj/sponsor-init (sponsoree team repo) (defun sdj/sponsor-debian-pkg (sponsoree team repo)
(interactive (interactive
(sdj/sponsor-init--read-args)) (sdj/sponsor-debian-pkg--read-args))
(when (or (not sponsoree) (not repo)) (when (or (not sponsoree) (not repo))
(error "You must provide a valid sponsoree name and a repository URL")) (error "You must provide a valid sponsoree name and a repository URL"))
(let* ((projname (sdj/sponsor--get-project-from-repourl repo)) (let* ((projname (sdj/sponsor-debian-pkg--get-project-from-repourl repo))
(sponsoreedir (file-name-as-directory (sponsoreedir (file-name-as-directory
(concat sdj/sponsor-debian-pkg-path sponsoree))) (concat sdj/sponsor-debian-pkg-debian-pkg-path sponsoree)))
(projdir (file-name-as-directory (projdir (file-name-as-directory
(concat sponsoreedir projname))) (concat sponsoreedir projname)))
(repo-is-private-p (string-search (concat "/" sponsoree "/") repo)) (repo-is-private-p (string-search (concat "/" sponsoree "/") repo))
@ -291,7 +315,7 @@ Return an alist of (team . id)."
(call-process "gbp" nil (get-buffer-create "*gbp output*") nil (call-process "gbp" nil (get-buffer-create "*gbp output*") nil
"clone" repo sponsoree-gitdir)) "clone" repo sponsoree-gitdir))
(when (and team repo-is-private-p) (when (and team repo-is-private-p)
(when-let ((team-repourl (sdj/sponsor--get-or-create-team-repo team projname repo)) (when-let ((team-repourl (sdj/sponsor-debian-pkg--get-or-create-team-repo team projname repo))
(team-gitdir (concat projdir projname))) (team-gitdir (concat projdir projname)))
(unless (file-directory-p team-gitdir) (unless (file-directory-p team-gitdir)
(message "Cloning the team repository...") (message "Cloning the team repository...")
@ -307,6 +331,6 @@ Return an alist of (team . id)."
"fetch" sponsoree)))))) "fetch" sponsoree))))))
(dired sponsoree-gitdir))) (dired sponsoree-gitdir)))
(provide 'sponsor-debian) (provide 'sponsor-debian-pkg)
;;; sponsor-debian.el ends here ;;; sponsor-debian-pkg.el ends here